}
+ emit [ newline "|"]
+]
+
+;-- Section handling:
+
+clear-sects: does [sects: 0.0.0.0]
+
+next-section: func [level /local bump mask] [
+ ; Return next section number. Clear sub numbers.
+ set [bump mask] pick [
+ [1.0.0.0 1.0.0.0]
+ [0.1.0.0 1.1.0.0]
+ [0.0.1.0 1.1.1.0]
+ [0.0.0.1 1.1.1.1]
+ ] level
+ level: form sects: sects + bump * mask
+ clear find level ".0"
+ level
+]
+
+make-heading: func [level num str /toc /local lnk][
+ ; Make a proper heading link or TOC target.
+ ; Determine link target str. Search for [target] in front of heading.
+comment { ; not required .. done thru javascript
+
+ either parse str [
+ "[" copy lnk to "]"
+ s: to end
+ ][
+ str: next s ; remove link target
+ ][
+ lnk: join "section-" num
+ ]
+ if not no-nums [str: rejoin [num pick [". " " "] level = 1 str]]
+ rejoin either toc [
+ [{} str ]
+ ][
+ [{} str {}]
+ ]
+}
+]
+
+; -~^+
+; 2-Jan-2013 GC
+make-heading: func [level num str /toc /local lnk][
+ tmp: copy ""
+ rejoin [
+ newline
+ str
+ newline
+ head insert/dup copy "" pick "-~^^+" level length? str
+ ]
+]
+
+emit-sect: func [level str /local sn] [
+ ; Unindent prior level:
+ ; if all [not no-indent level <= 2 sects/1 > 0] [emit ]
+ sn: next-section level
+ emit make-heading level sn str
+ ; if all [not no-indent level <= 2] [emit ]
+]
+
+; 2-Jan-2013 GC
+emit-toc: func [ ][
+ ; not required. Uses command line options to generate toc
+]
+
+emit-boiler: func [doc /local title info temp] [
+ ; Output top boiler plate:
+ title: any [
+ select doc 'title
+ select doc 'sect1
+ "Untitled"
+ ]
+ emit temp: rejoin [ title newline head insert/dup copy "" "=" length? title newline]
+ foreach [word val] doc [
+ if word = 'code [
+ ;emit {}
+ emit-lines val
+ emit newline
+ ;emit { }
+ remove/part find doc 'code 2
+ break
+ ]
+ if not find [title template options] word [break]
+ ]
+ title
+]
+
+]
+
+do-makedoc: has [in-view? file msg doc] [
+
+ in-view?: all [value? 'view? view?] ; Are we using View?
+
+ ; Get the file name from the script argument:
+ file: system/script/args
+ if any-string? file [file: to-file file] ; makes copy too
+
+ ; If no file provided, should we do the last file again?
+ if all [
+ not file
+ exists? %last-file.tmp
+ ][
+ file: load %last-file.tmp
+ either confirm reform ["Reprocess" file "?"] [
+ system/script/args: none
+ ][
+ file: none
+ ]
+ ]
+
+ ; If no file still, then ask the user for the file name:
+ if not file [
+ either in-view? [
+ file: request-file/only
+ ][
+ file: ask "Filename? "
+ file: all [not empty? trim file to-file file]
+ ]
+ ]
+
+ ; No file provided:
+ if not file [exit]
+
+ ; File must exist:
+ if not exists? file [
+ msg: reform ["Error:" file "does not exist"]
+ either in-view? [alert msg] [ask msg]
+ exit
+ ]
+
+ ; Save this as the last file processed:
+ save %last-file.tmp file
+
+ ; Process the file. Returns [title doc]
+ doc: second gen-html scan-doc read file
+
+ ; Create output file name:
+ append clear find/last file #"." ".txt"
+ write file doc
+
+ if all [in-view? not system/script/args] [browse file]
+ file ; return new file (entire path)
+]
+
+; Start process (but caller may request it only be loaded):
+if system/script/args <> 'load-only [do-makedoc]
diff --git a/Scripts/xml-object.r b/Scripts/xml-object.r
new file mode 100644
index 0000000..8dd850c
--- /dev/null
+++ b/Scripts/xml-object.r
@@ -0,0 +1,303 @@
+
+;; ================================================
+;; Script: xml-object.r
+;; downloaded from: www.REBOL.org
+;; on: 4-Nov-2008
+;; at: 6:09:51 UTC
+;; owner: brianwisti [script library member who can
+;; update this script]
+;; ================================================
+;; ==================================================
+;; email address(es) have been munged to protect them
+;; from spam harvesters.
+;; If you were logged on the email addresses would
+;; not be munged
+;; ==================================================
+REBOL [
+ Title: "Convert an XML-derived block structure into objects."
+ File: %xml-object.r
+
+ Date: 2-Mar-2005
+ Version: 1.0.5
+ Author: "Brian Wisti"
+ Email: %brianwisti--yahoo--com
+ Author: "Gavin F. McKenzie"
+ License: "Unknown"
+ library: [
+ level: 'advanced
+ platform: 'all
+ type: 'module
+ domain: [markup web xml]
+ support: %brianwisti--yahoo--com
+ tested-under: none
+ license: none
+ see-also: "xml-parse.r"
+ ]
+
+ Purpose: {
+ This script creates a function "xml-to-object" that converts
+ a series of nested blocks, created from an XML document by
+ parse-xml, into a series of nested objects that represent
+ the original content of the XML document processed.
+ }
+
+ History: [
+ 1.0.0 [17-Jul-2001 "First public release."]
+ 1.0.1 [17-Jul-2001 "Support for mixed content."]
+ 1.0.2 [06-Sep-2001 "Fixed a bug handling empty elements."]
+ 1.0.3 [22-Sep-2001 {Fixed a bug handling a mixture of
+ unique and multiply occuring elements
+ sharing the same enclosing element.}]
+ 1.0.4 [29-Sep-2001 {Fixed a bug improperly ignoring whitespace.
+ Changed switch-es to use type?/word.}]
+ 1.0.5 [2-Mar-2005 {Downloaded from web.archive.org,
+ changed some names, and uploaded
+ to REBOL.org} ]
+ ]
+
+ Acknowledgments: {
+ Many thanks to Mike Hansen for finding and reporting defects
+ in this script.
+
+ Gavin F. MacKenzie wrote the original releases of this file,
+ so it just plain wouldn't have happened without him. I hope he
+ knows we're grateful and we hope he's doing well - wherever he's
+ disappeared to!
+ }
+
+]
+
+xml-to-object: function [{
+ Convert a series of nested blocks, created from an XML document by
+ parse-xml, into a series of nested objects that represent the original
+ content of the XML document processed.
+
+ Returns the root object.
+}
+ document [block!] "The block representing the processed XML document."
+][
+ name
+ children
+ child attr-list
+ contains-char-content
+ contains-element-content
+ content-model
+ potential-new-content
+ new-content
+ is-allspace
+ do-character-content
+ do-element-content
+ add-mixed-content
+ get-mixed-value
+][
+ is-allspace: function [s] [] [
+ either (type? s) = string! [
+ s: copy s
+ ][
+ s: form copy s
+ ]
+ s: trim/all s
+ either (length? s) = 0 [
+ return true
+ ][
+ return false
+ ]
+ ]
+
+ do-character-content: func [
+ children [string!]
+ ][
+ append new-content reduce [to-set-word 'value? children]
+ remove next next document
+ ]
+
+ do-empty-content: func [
+ ][
+ append new-content reduce [to-set-word 'value? ""]
+ remove next next document
+ ]
+
+ do-element-content: func [
+ children [block!]
+ /local entry
+ ][
+ ;
+ ; Process all child content of this element
+ ;
+ forall children [
+ potential-new-content: xml-to-object children/1
+ ;
+ ; Is there already an object member known by this name?
+ ; (i.e. does it look like this is the beginning of
+ ; multiply occurring elements?)
+ ;
+ entry: find new-content (to-set-word potential-new-content/1)
+ ;
+ ; Yes, there is already an object member known by this name
+ ;
+ either entry [
+ if entry/3 = 'object! [
+ ; ...so we need to transform the existing object member
+ ; from a single object into a block of objects,
+ ; and append the potential-new-content into the block
+ ;
+ change/part at entry 3 reduce ['block! 'reduce] 1
+ change/only at entry 5 reduce [
+ 'make 'object! entry/5
+ ]
+ ]
+ append entry/5 (copy/part at potential-new-content 2 3)
+ ][
+ append new-content potential-new-content
+ ]
+ ]
+ ]
+
+ add-mixed-content: func [
+ children [string! block!]
+ /local v
+ ][
+ either (empty? new-content) or
+ (none? find new-content to-set-word 'content?) [
+ append new-content reduce [
+ to-set-word 'content?
+ 'make 'block! reduce [children]
+ to-set-word 'value?
+ 'does [get-mixed-value self]
+ ]
+ ][
+ v: find new-content to-set-word 'content?
+ either (type? children) = string! [
+ append v/4 children
+ ][
+ append v/4 to-word children/1
+ ]
+ ]
+ ]
+
+ get-mixed-value: function [
+ obj [object!]
+ ][
+ item
+ cooked-value?
+ ][
+ cooked-value?: copy ""
+ foreach item (reduce obj/content?) [
+ either (type? item) = string! [
+ append cooked-value? item
+ ][
+ append cooked-value? item/value?
+ ]
+ ]
+ cooked-value?
+ ]
+
+ name: to-word document/1
+ change document to-set-word document/1
+
+ new-content: copy []
+ contains-char-content: false
+ contains-element-content: false
+ content-model: 'empty
+
+ ;
+ ; Extract attributes and children
+ ;
+ attr-list: document/2
+ children: document/3
+ remove/part next document 2
+
+ ;
+ ; Determine the content model
+ ;
+ if not none? children [
+ for i 1 (length? children) 1 [
+ child: pick children i
+ switch type?/word child [
+ string! [
+ content-model: 'character
+ either is-allspace child [
+ contains-char-content: 'ignoreable-ws
+ ][
+ contains-char-content: 'true
+ ]
+ ]
+ block! [
+ contains-element-content: true
+ content-model: 'element
+ ]
+ ]
+ if (contains-char-content = 'true) and
+ (contains-element-content = true) [
+ content-model: 'mixed
+ break
+ ]
+ ]
+ ]
+
+ ;
+ ; Remove any ignoreable whitespace nodes
+ ;
+ if (contains-char-content = 'ignoreable-ws) and
+ (contains-element-content = true) [
+ content-model: 'element
+ while [not tail? children] [
+ either (type? children/1) = string! [
+ remove children
+ ][
+ children: next children
+ ]
+ ]
+ children: head children
+ ]
+
+ ;
+ ; Actually do the work of 'objectifying' the block
+ ;
+ switch content-model [
+ empty [
+ do-empty-content
+ ]
+ character [
+ do-character-content children/1
+ ]
+ element [
+ do-element-content children
+ ]
+ mixed [
+ forall children [
+ switch type?/word children/1 [
+ string! [
+ add-mixed-content children/1
+ ]
+ block! [
+ add-mixed-content children/1
+ do-element-content copy/part children 1
+ ]
+ ]
+ ]
+ ]
+ ]
+
+ ;
+ ; Process attributes
+ ;
+ if (not none? attr-list) [
+ forskip attr-list 2 [
+ change attr-list to-set-word attr-list/1
+ ]
+ attr-list: head attr-list
+ append new-content attr-list
+ ]
+
+ ;
+ ; Insert the result of all our hard work into the block
+ ;
+ if not empty? new-content [
+ insert/only at document 2 new-content
+ insert at document 2 reduce ['make 'object!]
+ ]
+
+ document
+]
+
diff --git a/Scripts/xml-parse.r b/Scripts/xml-parse.r
new file mode 100644
index 0000000..5e245c0
--- /dev/null
+++ b/Scripts/xml-parse.r
@@ -0,0 +1,1172 @@
+;; ============================================
+;; Script: xml-parse.r
+;; downloaded from: www.REBOL.org
+;; on: 20-Jul-2014
+;; at: 3:51:39.002339 UTC
+;; owner: brianwisti [script library member who
+;; can update this script]
+;; ============================================
+;; ==================================================
+;; email address(es) have been munged to protect them
+;; from spam harvesters.
+;; If you were logged on the email addresses would
+;; not be munged
+;; ==================================================
+REBOL [
+ Title: "A more XML 1.0 compliant set of XML parsing tools."
+ File: %xml-parse.r
+ Date: 1-jul-2009
+ Version: 0.7.6
+ Author: "Gavin F. McKenzie"
+ Email: %brianwisti--yahoo--com
+ Purpose: {
+ REBOL's built-in parse-xml function lacks a number of
+ XML 1.0 compliant features, including:
+ - support for CDATA sections
+ - support for XML Namespaces
+ - exposure of the internal DTD subset
+
+ The intent of this script is to create an XML parser
+ that can operate either via an event/callback mechanism,
+ or produce a block structure similar to REBOL's built-in
+ parse-xml function.
+
+ This XML parser is designed to call-back into a
+ 'parse-handler' object that has been designed to be similar
+ to the well-known XML parsing interface known as "SAX"
+ (Simple API for XML) by David Megginson.
+
+ For more information on SAX, see David's website at:
+ http://www.megginson.com/SAX/index.html
+
+ Several parse-handlers are included here:
+ - the base 'class' xml-parse-handler that contains only empty
+ callback stubs
+ - the debugging aid echo-handler that prints out the callback
+ event stream
+ - the block-handler that produces a superset of the block structure
+ created by REBOL's built-in parse-xml function
+
+ Alternatively, you may choose to build your own parse
+ event handler rather than use the functionality provided
+ here.
+
+ A new function is defined "parse-xml+" that represents
+ the enhanced counterpart to the built-in REBOL parse-xml.
+
+ Additional features provided by this parser:
+ 1. Document prolog information
+
+ The built-in REBOL parse-xml function returns a set of
+ nested blocks where the first two items in the outermost
+ block are the words document and none, such as:
+ [document none [...]]
+
+ The parse-xml+ function provided herein can produce a
+ set of nested blocks where the second item of the outermost
+ block is used to represent prolog and document type
+ information.
+
+ An example of this block is:
+
+ [ version "1.0" encoding "utf-8" standalone "yes"
+ doctype none pubid none sysid none subset none
+ ]
+
+ 2. CDATA Section Processing
+
+ XML provides for enclosing data content within CDATA
+ sections for the convenience of avoiding the need to
+ escape certain XML sensitive characters in the data
+ such as the ampersand (&) and less-than-sign (<).
+
+ An example of a CDATA section:
+
+ abc xyz
+
+ A compliant XML parser would report that the content
+ of element 'foo' is "abc Jack & Jill xyz".
+
+ CDATA sections are also useful when putting text samples
+ of XML within the content of an XML document.
+
+ bar]]>
+
+ Here the value of element 'example' is the text
+ "bar"
+
+ 3. Comments
+
+ This parser provides the opportunity to process
+ comments embedded within the XML.
+
+ 4. Processing Instructions
+
+ This parser provides the opportunity to process
+ processing instructions embedded within the XML.
+
+
+
+ 5. Automatic Character Entity Expansion
+
+ In XML document it is common to encounter "character
+ entities" within the content of the document. These
+ entities are the means for escaping sensitive XML
+ characters so that the character will be processed as
+ data rather than markup. The most common characters
+ that are subjected to this treatment are the
+ ampersand (&) and less-than-sign (<).
+
+ This parser recognizes these common entities and
+ automatically converts them to their character
+ equivalents.
+
+ For example:
+
+ Jack & Jill
+
+ This parser will automatically replace the &
+ character entity reference to the ampersand (&)
+ character; hence, the value of element 'foo' is
+ "Jack & Jill".
+
+ Character entities can also be encoded with their
+ Unicode numeric equivalent rather than the symbolic
+ name in either decimal or hex form, such as:
+
+ Ampersands: &&&
+
+ The value of element 'foo' is "Ampersands: &&&".
+
+ 6. Namespace Processing
+
+ Namespace processing is vital to handling real-world
+ XML.
+
+ @@TBD: say more here
+ }
+ History: [
+ 0.7.4 { Fixed a defect to allow optional space around
+ the '=' on an attribute.
+ Thanks to Brett Handley for reporting the defect.}
+ 0.7.3 { Fixed bug where attr-ns-prefix wasn't getting cleared
+ when processing an un-prefixed attribute.}
+ 0.7.2 { Changed the start-document in the block-handler
+ to perform a copy/deep, fixing a bug that occurred
+ on successive invocations of parse-xml+.}
+ 0.7.1 { First public release. }
+
+ ]
+ Acknowledgements: {
+ Gavin F. MacKenzie wrote the original releases of this file,
+ so it just plain wouldn't have happened without him. I hope he
+ knows we're grateful and we hope he's doing well - wherever he's
+ disappeared to!
+ }
+]
+
+; TO DO
+; - ** WARNING ** Namespace processing is not ready for primetime!
+; - anything that uses xmlQuote is wrong; there is the potential for
+; uncaught mismatched quotes
+; - do some start/end-tag matching and error-checking
+; - process entities defined in the internal DTD subset
+; - add comments, comments, comments!!
+
+xml-parse: make object! [
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;
+ ; XML PARSE CONTENT HANDLERS
+ ;
+ ; This XML parser is designed to call-back into a 'parse-handler' object
+ ; that has been designed to be similar to the well-known XML parsing
+ ; interface known as "SAX" (Simple API for XML) by David Megginson.
+ ;
+ ; For more information on SAX, see David's website at:
+ ; http://www.megginson.com/SAX/index.html
+ ;
+ ; Several parse-handlers are included here:
+ ; - the base 'class' xml-parse-handler that contains only empty
+ ; callback stubs
+ ; - the debugging aid echo-handler that prints out the callback
+ ; event stream
+ ; - the block-handler that produces a superset of the block structure
+ ; created by REBOL's built-in parse-xml function
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;
+ ; This is an 'empty' xml-parse-handler that is provided as a base-object
+ ; for extending into custom xml-parse-handlers.
+ ;
+ xml-parse-handler: make object! [
+ start-document: func [
+ ][
+ ]
+ xml-decl: func [
+ version-info [string! none!]
+ encoding [string! none!]
+ standalone [string! none!]
+ ][
+ ]
+ document-type: func [
+ document-type [string!]
+ public-id [string! none!]
+ system-id [string! none!]
+ internal-subset [string! none!]
+ ][
+ ]
+ start-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ attr-list [block!]
+ ][
+ ]
+ end-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ ][
+ ]
+ characters: func [
+ characters [string! none!]
+ ][
+ ]
+ pi: func [
+ pi-target [string! none!]
+ pi [string! none!]
+ ][
+ ]
+ comment: func [
+ comment [string! none!]
+ ][
+ ]
+ end-document: func [] [
+ ]
+ start-prefix-mapping: func [
+ ns-prefix-uri-pairs [block!]
+ ][
+ ]
+ end-prefix-mapping: func [
+ ns-prefix-uri-pairs [block!]
+ ][
+ ]
+ get-parse-result: func [{
+ This function can be used to return a specific result from
+ the parse operation, such as returning the parse XML as a
+ series of blocks similar to REBOL's built-in parse-xml.
+ By default, returning none from this function will cause the
+ return code from the REBOL parse function to be passed back
+ to the caller of the parse.}
+ ][
+ none
+ ]
+ ]
+
+ ;
+ ; This xml-parse-handler simply echoes the parsing to the console.
+ ; This was primarily useful as a debugging aid during the development
+ ; of the XML parse production rules.
+ ;
+ echo-handler: make xml-parse-handler [
+ start-document: func [
+ ][
+ print remold ['start-doc]
+ ]
+ xml-decl: func [
+ version-info [string! none!]
+ encoding [string! none!]
+ standalone [string! none!]
+ ][
+ print remold ['xml-decl 'version-info version-info
+ 'encoding encoding 'standalone standalone
+ ]
+ ]
+ document-type: func [
+ document-type [string!]
+ public-id [string! none!]
+ system-id [string! none!]
+ internal-subset [string! none!]
+ ][
+ print remold ['doc-type document-type
+ 'public-id public-id
+ 'system-id system-id
+ 'internal-subset internal-subset
+ ]
+ ]
+ start-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ attr-list [block!]
+ ][
+ print remold ['start-elem ns-uri local-name q-name
+ 'attr-list attr-list
+ ]
+ ]
+ end-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ ][
+ print remold ['end-elem ns-uri local-name q-name]
+ ]
+ characters: func [
+ characters [string! none!]
+ ][
+ print remold ['characters characters]
+ ]
+ pi: func [
+ pi-target [string! none!]
+ pi [string! none!]
+ ][
+ print remold ['pi pi-target pi]
+ ]
+ comment: func [
+ comment [string! none!]
+ ][
+ print remold ['comment comment]
+ ]
+ end-document: func [
+ ][
+ print remold ['end-doc]
+ ]
+ start-prefix-mapping: func [
+ ns-prefix-uri-pairs [block!]
+ ][
+ print remold ['start-prefix ns-prefix-uri-pairs]
+ ]
+ end-prefix-mapping: func [
+ ns-prefix-uri-pairs [block!]
+ ][
+ print remold ['end-prefix ns-prefix-uri-pairs]
+ ]
+ ]
+
+ ;
+ ; This xml-parse-handler produces a set of nested blocks representing
+ ; the parsed XML content. The blocks structure is a compatible superset
+ ; of the block structure produced by REBOL's built-in parse-xml function.
+ ; Extensions to the structure are appended to any applicable block;
+ ; hence, existing code intended for use with REBOL's existing post-parse
+ ; block structure should continue to work.
+ ;
+ block-handler: make xml-parse-handler [
+ xml-doc: copy []
+ xml-block: copy []
+ xml-content: copy ""
+
+ start-document: func [
+ ][
+ ;
+ ; Seed the document
+ ;
+ xml-block: reduce copy/deep ['document [version none
+ encoding none
+ standalone none
+ doctype none
+ pubid none
+ sysid none
+ subset none
+ ]
+ none
+ ]
+ ]
+ xml-decl: func [
+ version-info [string! none!]
+ encoding [string! none!]
+ standalone [string! none!]
+ ][
+ change next (find xml-block/2 'version) version-info
+ change next (find xml-block/2 'encoding) encoding
+ change next (find xml-block/2 'standalone) standalone
+ ]
+ document-type: func [
+ document-type [string!]
+ public-id [string! none!]
+ system-id [string! none!]
+ internal-subset [string! none!]
+ ][
+ change next (find xml-block/2 'doctype) document-type
+ change next (find xml-block/2 'pubid) public-id
+ change next (find xml-block/2 'sysid) system-id
+ change next (find xml-block/2 'subset) internal-subset
+ ]
+ start-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ attr-list [block!]
+ ][
+ ;
+ ; Is there any pending content to add before
+ ; we start a new element?
+ ;
+ if not empty? xml-content [
+ add-child copy xml-content
+ clear head xml-content
+ ]
+ insert/only tail xml-doc xml-block
+ xml-block: add-child copy reduce [local-name none none]
+ ;
+ ; Add the attribute list
+ ;
+ if not empty? attr-list [
+ xml-block/2: copy attr-list
+ ]
+ ]
+ characters: func [
+ characters [string! none!]
+ ][
+ ;
+ ; Accumulate more character data
+ ;
+ if not none? characters [
+ append xml-content characters
+ ]
+ ]
+ end-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ ][
+ ;
+ ; Is there any pending content to add before
+ ; we terminate this element?
+ ;
+ if not empty? xml-content [
+ add-child copy xml-content
+ clear head xml-content
+ ]
+ ;
+ ; Basic well-formedness check
+ ;
+; while [q-name <> first xml-block] [
+; if empty? xml-doc [
+; print ["End tag error:" q-name]
+; halt
+; ]
+; pop-xml-block
+; ]
+ pop-xml-block
+ ]
+ add-child: func [child] [
+ if none? third xml-block [xml-block/3: make block! 1]
+ insert/only tail third xml-block child
+ child
+ ]
+ pop-xml-block: func [] [
+ xml-block: last xml-doc
+ remove back tail xml-doc
+ ]
+ get-parse-result: func [] [
+ xml-block
+ ]
+ ]
+
+ ;
+ ; This xml-parse-handler enhances the block-handler with namespace
+ ; processing. It should only be used with a parser that has been
+ ; set to namespace-aware true.
+ ;
+ ns-block-handler: make xml-parse-handler [
+ xml-doc: copy []
+ xml-block: copy []
+ xml-content: copy ""
+ nsinfo-stack: copy []
+
+ start-document: func [
+ ][
+ ;
+ ; Seed the document
+ ;
+ xml-block: reduce copy/deep ['document [version none
+ encoding none
+ standalone none
+ doctype none
+ pubid none
+ sysid none
+ subset none
+ ]
+ none
+ ]
+ ]
+ xml-decl: func [
+ version-info [string! none!]
+ encoding [string! none!]
+ standalone [string! none!]
+ ][
+ change next (find xml-block/2 'version) version-info
+ change next (find xml-block/2 'encoding) encoding
+ change next (find xml-block/2 'standalone) standalone
+ ]
+ document-type: func [
+ document-type [string!]
+ public-id [string! none!]
+ system-id [string! none!]
+ internal-subset [string! none!]
+ ][
+ change next (find xml-block/2 'doctype) document-type
+ change next (find xml-block/2 'pubid) public-id
+ change next (find xml-block/2 'sysid) system-id
+ change next (find xml-block/2 'subset) internal-subset
+ ]
+ start-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ attr-list [block!]
+ ][
+ ;
+ ; Is there any pending content to add before
+ ; we start a new element?
+ ;
+ if not empty? xml-content [
+ add-child copy xml-content
+ clear head xml-content
+ ]
+ insert/only tail xml-doc xml-block
+ xml-block: add-child copy reduce [local-name
+ none
+ none
+ ns-uri
+ ]
+ ;
+ ; Add the attribute list
+ ;
+ if not empty? attr-list [
+ xml-block/2: copy attr-list
+ ]
+ ]
+ characters: func [
+ characters [string! none!]
+ ][
+ ;
+ ; Accumulate more character data
+ ;
+ if not none? characters [
+ append xml-content characters
+ ]
+ ]
+ end-element: func [
+ ns-uri [string! none!]
+ local-name [string! none!]
+ q-name [string!]
+ ][
+ ;
+ ; Is there any pending content to add before
+ ; we terminate this element?
+ ;
+ if not empty? xml-content [
+ add-child copy xml-content
+ clear head xml-content
+ ]
+ ;
+ ; Basic well-formedness check
+ ;
+; while [q-name <> first xml-block] [
+; if empty? xml-doc [
+; print ["End tag error:" q-name]
+; halt
+; ]
+; pop-xml-block
+; ]
+ pop-xml-block
+ ]
+ start-prefix-mapping: func [
+ ns-prefix-uri-pairs [block!]
+ ][
+ insert/only nsinfo-stack ns-prefix-uri-pairs
+ ]
+ end-prefix-mapping: func [
+ ns-prefix-uri-pairs [block!]
+ ][
+ remove nsinfo-stack
+ ]
+ add-child: func [child] [
+ if none? third xml-block [xml-block/3: make block! 1]
+ insert/only tail third xml-block child
+ child
+ ]
+ pop-xml-block: func [] [
+ xml-block: last xml-doc
+ remove back tail xml-doc
+ ]
+ get-parse-result: func [] [
+ xml-block
+ ]
+ ]
+
+
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;
+ ; ACTUAL XML PARSER OBJECT
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ parser: make object! [
+ element-q-name: none
+ element-local-name: none
+ document-type: none
+ system-id: none
+ public-id: none
+ internal-subset: none
+ encoding: none
+ characters: none
+ entity-ref: none
+ char-ref-value: none
+ comment: none
+ pi-target: none
+ pi: none
+ version-info: none
+ encoding: none
+ standalone: none
+ attr-name: none
+ attr-value: none
+ attr-list: copy []
+
+ attr-ns-prefix: none
+ element-ns-prefix: none
+ ns-uri: none
+ nsinfo-stack: copy []
+ nsinfo: copy []
+
+ ;
+ ; Set a default xml-parse-handler
+ ;
+ handler: block-handler
+
+ ;
+ ; Namespace processing, set true to process namespaces
+ ;
+ namespace-aware: no
+
+ ;
+ ; XML 1.0 Production Rules
+ ;
+ xmlLetter: charset [#"A" - #"Z" #"a" - #"z"]
+ xmlDigit: charset [#"0" - #"9"]
+ xmlHexDigit: charset [#"0" - #"9" #"a" - #"f" #"A" - #"F"]
+ xmlAlpha: charset [#"A" - #"Z" #"a" - #"z"]
+ xmlAlphaNum: charset [#"0" - #"9" #"A" - #"Z" #"a" - #"z"]
+ xmlQuote: charset [#"^"" #"^'"]
+ xmlSpace: charset [#"^(20)" #"^(09)" #"^(0D)" #"^(0A)"]
+ xmlNotMarkupChar: complement charset [#"<" #"&"] ;fix this
+ xmlS: [some xmlSpace]
+ xmlEq: [[any xmlSpace] "=" [any xmlSpace]]
+ xmlChar: [any [xmlAlphaNum | xmlSpace]]
+ xmlCharData: [ copy characters
+ some xmlNotMarkupChar
+ (handler/characters characters)
+ ]
+ xmlNameProd: [[xmlLetter | #"_" | #":"] any xmlNameChar]
+ xml10Name: xmlNameProd
+ xmlName: xml10Name
+ xmlNameChar: [ xmlLetter | xmlDigit |
+ #"." | #"-" | #"_" | #":"
+ ]
+ xmlNames: [xmlName any [xmlS xmlName]]
+ xmlNMToken: [some xmlNameChar]
+ xmlNMTokens: [xmlNMToken any [xmlS xmlNMToken]]
+ xmlMisc: [xmlComment | xmlPI | xmlS]
+ xmlPERef: [#"%" xmlNameProd #"%"]
+ xmlEntIntro: charset [#"^^" #"^%" #"^&" #"^""]
+ xmlEntityVal: [#"^"" any [xmlEntIntro | xmlPERef] #"^""]
+ xmlContent: [any [ xmlElement | xmlComment | xmlPI |
+ xmlCDSect | xmlCharData | xmlReference
+ ]
+ ] ;fix this
+ xmlAttValueStrict: [ [#"^"" copy attr-value to #"^"" #"^""] |
+ [#"'" copy attr-value to #"'" #"'"]
+ ] ; fix this
+ xmlAttValue: xmlAttValueStrict
+ xmlAttType: [ xmlStringType |
+ xmlTokenizedType |
+ xmlEnumeratedType
+ ]
+ xml10AttrStrict: [ copy attr-name xmlName
+ xmlEq
+ xmlAttValue
+ (append append
+ attr-list attr-name attr-value
+ )
+ ]
+ xmlAttribute: xml10AttrStrict
+ xmlSTag: [ #"<"
+ copy element-q-name xmlName
+ [ (clear head attr-list clear head nsinfo)
+ any [xmlS xmlAttribute]
+ ]
+ [any xmlSpace]
+ #">"
+ (either namespace-aware [
+ handler/start-prefix-mapping nsinfo
+ insert/only nsinfo-stack copy nsinfo
+ handler/start-element
+ ns-uri
+ element-local-name
+ element-q-name
+ attr-list
+ ][
+ handler/start-element
+ none
+ element-q-name
+ element-q-name
+ attr-list
+ ]
+ )
+ ]
+ xmlETag: [ ""
+ (either namespace-aware [
+ handler/end-element
+ ns-uri
+ element-local-name
+ element-q-name
+ handler/end-prefix-mapping
+ first nsinfo-stack
+ remove nsinfo-stack
+ ][
+ handler/end-element
+ none
+ element-q-name
+ element-q-name
+ ]
+ )
+ ]
+ xmlEmptyElemTag: [ #"<"
+ copy element-q-name xmlName
+ [ (clear head attr-list clear head nsinfo)
+ any [xmlS xmlAttribute]
+ ]
+ [any xmlSpace]
+ "/>"
+ (either namespace-aware [
+ handler/start-prefix-mapping nsinfo
+ insert/only nsinfo-stack copy nsinfo
+ handler/start-element
+ ns-uri
+ element-local-name
+ element-q-name
+ attr-list
+ ][
+ handler/start-element
+ none
+ element-q-name
+ element-q-name
+ attr-list
+ ]
+ characters: none
+ handler/characters characters
+ either namespace-aware [
+ handler/end-element
+ ns-uri
+ element-local-name
+ element-q-name
+ handler/end-prefix-mapping
+ first nsinfo-stack
+ remove nsinfo-stack
+ ][
+ handler/end-element
+ none
+ element-q-name
+ element-q-name
+ ]
+ )
+ ]
+ xmlEmptyElem: [ #"<"
+ copy element-q-name xmlName
+ [ (clear head attr-list clear head nsinfo)
+ any [xmlS xmlAttribute]
+ ]
+ [any xmlSpace]
+ ">"
+ (either namespace-aware [
+ handler/start-prefix-mapping nsinfo
+ insert/only nsinfo-stack copy nsinfo
+ handler/start-element
+ ns-uri
+ element-local-name
+ element-q-name
+ attr-list
+ ][
+ handler/start-element
+ none
+ element-q-name
+ element-q-name
+ attr-list
+ ]
+ characters: none
+ handler/characters characters
+ either namespace-aware [
+ handler/end-element
+ ns-uri
+ element-local-name
+ element-q-name
+ handler/end-prefix-mapping
+ first nsinfo-stack
+ remove nsinfo-stack
+ ][
+ handler/end-element
+ none
+ element-q-name
+ element-q-name
+ ]
+ )
+ ]
+ xmlElementStrict: [ xmlEmptyElemTag |
+ xmlEmptyElem |
+ [xmlSTag opt xmlContent xmlETag]
+ ]
+ xmlElement: xmlElementStrict
+ xmlPI: [ "" "?>"
+ (handler/pi pi-target pi)
+ ]
+ xmlPITarget: [xmlNameProd]
+ xmlComment: [ "" "-->"
+ (handler/comment comment)
+ ]
+ xmlDecl: [ (version-info: encoding: standalone: none)
+ ""
+ (handler/xml-decl
+ version-info
+ encoding
+ standalone
+ )
+ ]
+ xmlVersionInfo: [ "version"
+ xmlEq
+ [ #"^"" copy version-info xmlVersionNum "^"" |
+ #"^'" copy version-info xmlVersionNum "^'"
+ ]
+ ]
+ xmlVersionNum: [some [xmlVersionNumChars | "-"]]
+ xmlVersionNumChars: charset [ #"0" - #"9"
+ #"A" - #"Z"
+ #"a" - #"z"
+ "_.:"
+ ]
+ xmlEncodingDecl: [ (encoding: none)
+ "encoding"
+ xmlEq
+ [ #"^"" copy encoding xmlEncName "^"" |
+ #"^'" copy encoding xmlEncName "^'"
+ ]
+ ]
+ xmlEncName: [xmlAlpha any [xmlEncNameChars]]
+ xmlEncNameChars: charset [ #"0" - #"9"
+ #"A" - #"Z"
+ #"a" - #"z"
+ "_.-"
+ ]
+ xmlDocument: [ (handler/start-document)
+ xmlProlog
+ xmlElement
+ any xmlMisc
+ (handler/end-document)
+ ]
+ xmlProlog: [ opt xmlDecl
+ any xmlMisc
+ opt [xmlDocTypeDecl any xmlMisc]
+ ]
+ xmlDocTypeDecl: [ ""
+ (handler/document-type
+ document-type
+ public-id
+ system-id
+ internal-subset
+ )
+ ]
+ xmlSDDecl: [ (standalone: none)
+ "standalone"
+ xmlEq
+ [ xmlQuote
+ copy standalone ["yes" | "no"]
+ xmlQuote
+ ]
+ ]
+ xmlStringType: "CDATA"
+ xmlTokenizedType: [ "ID" | "IDREF" | "IDREFS" |
+ "ENTITY" | "ENTITIES" |
+ "NMTOKEN" | "NMTOKENS"
+ ]
+ xmlEnumeratedType: [] ; fix this
+ xmlReference: [xmlCharRef | xmlEntityRef]
+ xmlEntityRef: [ ["&" copy entity-ref xmlNameProd ";"]
+ ( char-ref-value:
+ convert-character-entity entity-ref
+ either none? char-ref-value [
+ ;
+ ; couldn't convert the
+ ; chararacter-entity, so pass
+ ; it through as character data,
+ ; unconverted
+ ;
+ handler/characters
+ rejoin ["&" entity-ref ";"]
+ ][
+ ;
+ ; converted the chararacter-entity
+ ; to a character
+ ;
+ handler/characters char-ref-value
+ ]
+ )
+ ]
+ xmlCharRef: [ [ [ "&"
+ [copy entity-ref
+ ["#" some xmlDigit]
+ ]
+ ";"
+ ] |
+ [ "&"
+ [copy entity-ref
+ ["#x" some xmlHexDigit]
+ ]
+ ";"
+ ]
+ ]
+ ( char-ref-value:
+ convert-character-entity entity-ref
+ either none? char-ref-value [
+ ;
+ ; couldn't convert the
+ ; chararacter-entity, so pass
+ ; it through as character data,
+ ; unconverted
+ ;
+ handler/characters
+ rejoin ["&" entity-ref ";"]
+ ][
+ ;
+ ; converted the chararacter-entity
+ ; to a character
+ ;
+ handler/characters char-ref-value
+ ]
+ )
+ ]
+ xmlExternalID: [ ["SYSTEM" xmlSpace xmlSystemLiteral] |
+ ["PUBLIC" xmlSpace xmlPubIDLiteral
+ xmlSpace xmlSystemLiteral
+ ]
+ ]
+ xmlSystemLiteral: [ [#"^"" copy system-id to #"^"" #"^""] |
+ [#"'" copy system-id to #"'" #"'"]
+ ]
+ xmlPubIDLiteral: [ [#"^"" copy public-id to #"^"" #"^""] |
+ [#"'" copy public-id to #"'" #"'"]
+ ]
+ xmlNDataDecl: [xmlS "NDATA" xmlS xmlNameProd]
+ xmlCDSect: [ ""
+ "]]>"
+ (handler/characters characters)
+ ]
+
+ ; XML Namespace-Specific Production Rules
+ ;
+ xmlNSAttribute: [ [ copy attr-name xmlPrefixedAttName
+ xmlEq xmlAttValue
+ (ns-uri: copy attr-value
+ append nsinfo
+ reduce [attr-ns-prefix
+ attr-value
+ ]
+ )
+ ] |
+ [ copy attr-name xmlDefaultAttName
+ xmlEq
+ xmlAttValue
+ (ns-uri: copy attr-value
+ append nsinfo
+ reduce [attr-ns-prefix
+ attr-value
+ ]
+ )
+ ] |
+ [ xmlAQName
+ xmlEq
+ xmlAttValue
+ (append attr-list
+ reduce [attr-name
+ attr-value
+ attr-ns-prefix
+ ]
+ )
+ ]
+ ]
+ xmlPrefixedAttName: ["xmlns:" copy attr-ns-prefix xmlNCName]
+ xmlDefaultAttName: ["xmlns" (attr-ns-prefix: none)]
+ xmlNCName: [[xmlLetter | #"_"] any xmlNCNameChar]
+ xmlNCNameChar: [xmlLetter | xmlDigit | #"." | #"-" | #"_"]
+ xmlAQName: [ [ copy attr-ns-prefix xmlNCName
+ #":"
+ copy attr-name xmlNCName
+ ] |
+ [ copy attr-name xml10Name
+ (attr-ns-prefix: none)
+ ]
+ ]
+ xmlQName: [ [ copy element-ns-prefix xmlNCName
+ #":"
+ copy element-local-name xmlNCName
+ (element-q-name: copy rejoin
+ [element-ns-prefix
+ ":"
+ element-local-name
+ ]
+ )
+ ] |
+ [ copy element-local-name xml10Name
+ (element-q-name: element-ns-prefix: "")
+ ]
+ ]
+ ;
+ ;
+ ; Private XML Parser Methods
+ ;
+ convert-character-entity: func [{
+ Accepts the name reference portion of an entity
+ reference and attempts to return a string containing
+ the actual character referenced by the entity.
+ If the conversion is not successful, the value of
+ none is returned.
+ For example, for the ampersand character this function
+ could accept a entity-ref parameter of either "amp",
+ "#38" or "#x26".
+ }
+ entity-ref [string!]
+ ][
+ switch/default entity-ref [
+ "lt" [ return "<" ]
+ "gt" [ return ">" ]
+ "amp" [ return "&" ]
+ "quot" [ return "^"" ]
+ "apos" [ return "'" ]
+ ][
+ either (first entity-ref) = #"#" [
+ either (second entity-ref) = #"x" [
+ to-string to-char to-integer to-issue
+ skip entity-ref 2
+ ][
+ to-string to-char to-integer
+ skip entity-ref 1
+ ]
+ ][
+ none
+ ]
+ ]
+ ]
+
+ ;
+ ;
+ ; Public XML Parser Methods
+ ;
+ parse-xml: func [{
+ Parses XML code and executes an associated event handler
+ during processing.
+ This is a more XML 1.0 compliant parse than the built-in
+ REBOL parse-xml function.
+ }
+ xml-string [string!]
+ /local parse-result
+ ][
+ ;
+ ; Parse the document and capture the return code from the REBOL
+ ; parse.
+ ;
+ parse-result: parse/case/all xml-string xmlDocument
+ ;
+ ; If the handler doesn't return a specific parse result, then
+ ; return the parse-result we obtained from the REBOL parse.
+ ;
+ either handler/get-parse-result = none [
+ parse-result
+ ][
+ handler/get-parse-result
+ ]
+ ]
+
+ set-parse-handler: func [
+ arg-handler [object!]
+ ][
+ handler: arg-handler
+ ]
+
+ get-parse-handler: does [
+ handler
+ ]
+
+ set-namespace-aware: func [{
+ This function enables the namespace processing
+ of the parser. As a result, the parser will
+ process xmlns attributes and namespace prefixes.
+ The parse-handlers will receive additional
+ namespace specific information.
+ }
+ arg-namespace-aware [logic!]
+ ][
+ namespace-aware: arg-namespace-aware
+ either arg-namespace-aware [
+ xmlName: xmlQName
+ xmlAttribute: xmlNSAttribute
+ ][
+ xmlName: xml10Name
+ xmlAttribute: xml10AttrStrict
+ ]
+ namespace-aware
+ ]
+
+ get-namespace-aware: does [
+ namespace-aware
+ ]
+
+ ]
+
+]
+
+parse-xml+: func [{
+ Parses XML code and returns a tree of blocks.
+ This is a more XML 1.0 compliant parse than the built-in
+ REBOL parse-xml function.
+}
+ code [string!] "XML code to parse"
+][
+ xml-parse/parser/parse-xml code
+]
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;
+; Some samples...
+;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+comment {
+ TBD
+}
diff --git a/comlib/COMLib.r b/comlib/COMLib.r
new file mode 100644
index 0000000..158aa72
--- /dev/null
+++ b/comlib/COMLib.r
@@ -0,0 +1,793 @@
+rebol [
+ Title: "COMLib (the rebol side of the com2rebol interface)"
+ File: %COMLib.r
+ Date: 9-Mar-2007
+ Version: 1.1.9
+ Progress: 0.55
+ Status: "working, everything reengineered"
+ Needs: []
+ Author: "Anton Rolls"
+ Original-Author: "Benjamin Maggi"
+ Language: 'English
+ Purpose: {Create the rebol side of the com2rebol interface}
+ License: {COMLIB is open source software provided under the BSD license.}
+ library: [
+ level: 'advanced
+ platform: 'windows
+ type: []
+ domain: [external-library win-api]
+ tested-under: [view/pro 1.3.2.3.1 on WXP]
+ support: none
+ license: 'BSD
+ see-also: none
+ ]
+ Usage: {
+ do/args %COMLib.r [
+ ; use the comlib api functions and routines here
+ ]
+
+ Or
+
+ COMLib: do %COMLib.r
+ COMLib/initialize
+ do bind [
+ ; use the comlib api functions and routines here
+ ] COMLib/api
+ COMLib/cleanup
+ }
+ History: [
+ 1.0.0 [3-Dec-2005 {First version forked from Benjamin Maggi's COMLib.r,
+ making official rebol style compliant;
+ args were incorrectly "declared" local in the function body, added them as locals to the function
+ spec block correctly;
+ renamed "exaptionThrown" -> "exceptionThrown?" ;
+ renamed "dipsHelper" -> "dispHelper" (needed to recompile DLL)
+ switch to-string type? -> switch type?/word ;
+ removed all the unnecessary COMPOSE/DEEPs when making routines;
+ } "Anton"]
+ 1.0.1 [4-Dec-2005 {Major rework of genericGetVal, made it more rebolish, removed first argument
+ (which wasn't used)
+ } "Anton"]
+ 1.0.2 [17-Dec-2005 {wrapped in context in a format similar to the output of my
+ make-external-library-interface.r} "Anton"]
+ 1.0.3 [18-Dec-2005 {changing the format to be quite different} "Anton"]
+ 1.0.4 [20-Dec-2005 {finished implementing the dependency handling code, finished converting
+ routines to "storage" format} "Anton"]
+ 1.0.5 [21-Dec-2005 {optimized genericGetVal more, removed some unnecessary variables,
+ no longer setting a word to the created routine; renamed lib -> library} "Anton"]
+ 1.0.6 [5-Jun-2006 {routine spec for toggleExceptions was empty (no args) so added the int arg,
+ spec of api functions is now correctly bound to api, fixed bug in genericGetVal where the type?/word
+ return-type was used instead of to-word return-type} "Anton"]
+ 1.0.7 [6-Jun-2006 {initialize now does initDispHelper and cleanup now does closeDispHelper, so both
+ of these are always added to routines} "Anton"]
+ 1.0.8 [10-Jun-2006 {removed makeContainer, was not properly functioning and was not used anywhere,
+ implemented more of setErrorHandler, renamed setErrorHandler -> setExceptionHandler} "Anton"]
+ 1.0.9 [16-Jun-2006 {reworked substantially for new exception handling, split api context into two contexts,
+ api and routines} "Anton"]
+ 1.1.0 [17-Jun-2006 {renamed SendValue -> PutValue, removed any-type! for optional arguments, since it will
+ cause accidental user code errors, switched order of first two arguments in GenericGetVal, renamed
+ retrieveObject -> GetObject, renamed objectMethod -> CallMethod and reworked argument handling} "Anton"]
+ 1.1.1 [18-Jun-2006 {renamed genericGetVal -> do-variadic-routine, and now it checks the arg types} "Anton"]
+ 1.1.2 [20-Jun-2006 {renamed getNumber -> getInteger, renamed getText -> getString, removed installObject} "Anton"]
+ 1.1.3 [25-Jun-2006 {added EnumNextObject, added FOR_EACH (untested)} "Anton"]
+ 1.1.4 [29-Jun-2006 {added optional method of using comlib via do/args -> system/script/args
+ throwing real errors in initialize instead of just printing error messages, initialize catches error
+ during load-library and throws} "Anton"]
+ 1.1.5 [2-Jul-2006 {debugging and completing FOR_EACH, EnumBegin and EnumNextObject} "Anton"]
+ 1.1.6 [7-Jul-2006 {added putRef and PutRef} "Anton"]
+ 1.1.7 [10-Jul-2006 {added missing [catch] to GetObject, PutValue and PutRef} "Anton"]
+ 1.1.8 [11-Jul-2006 {cleanup now releases any forgotten unreleased objects that were created by
+ CreateObject or GetObject} "Anton"]
+ 1.1.9 [9-Mar-2007 {backwards compatibility fixes (only tested on %test-comlib.r):
+ reset series to head after FORALL (necessary in older rebol versions),
+ defining CASE mezzanine function for older rebols (eg. view < 1.2.54),
+ workaround bug in View < 1.2.54 on converting datatype to word (eg. to-word integer!) using MOLD
+ } "Anton"]
+ ]
+ ToDo: {
+ - When user doesn't have External Library Access, the error is not very clear.
+ Also the error caused by a missing com2rebol.dll file is not clear.
+ - release should avoid passing NONE to releaseObject somehow, so can support code like:
+ obj: attempt [CreateObject [...]]
+ release obj
+ - release should accept integer arg directly (not just literal word) too ?
+ (That would allow large lists of anonymous objects stored as a block of integers for instance.)
+
+ - argument syntax errors were causing EXCEL.EXE to hang around (probably because objects were not released).
+ This is probably now fixed by cleanup releasing forgotten objects.
+
+ - I am not clear about this, but speech.r was not trapping an exception in putValue until after
+ I added toggleExceptions 1
+ Now it seems to be trapping it without using toggleExceptions... is the COM system remembering ?
+ (Try again after a restart.)
+ (could be extra confusion with the missing [catch] in PutValue ?)
+
+ - free-library should not error when the library is already freed
+
+ - implement WITH macro ? (see excel.r, just using GetObject and release)
+
+ - name IDispatch * arguments consistently, currently we have "obj" (most popular), "object", "parent" and "ppDisp"
+
+ - all arguments should be passed in a block to be consistent ? These ones are not:
+ - failed?
+ - CreateObject
+ - release
+
+ - fix up the rebol.org library script header, type and license
+
+ - GetString appears to be fine, now also test GetValue %s millions of times, watching mem use.
+
+ - perhaps guard against these buggy problems:
+
+ ; This causes real havoc with Excel, tries to fill every cell with the string, runs out of memory.
+ ;PutValue [xlApp ".ActiveSheet.Cells(1,10) = %s" "abc123"]
+
+ ; This sent my system to hell, used all my memory, which was not freed when I terminated EXCEL.EXE
+ ; The format string parameters must be specified separately, not inline as above, and like this:
+ ;GetString [xlApp ".ActiveSheet.Cells(1,10)"]
+
+ - decide how to handle pointers, as integer! or as binary!
+
+ - maybe make some ansi<->Unicode functions, so we can support unicode in rebol ?
+ - check Ben's existing implementations
+
+ - write the original types for each of the routine arguments (in the storage)
+ - remove toggleExceptions ? It won't be used very often, only if the rebol exception handling fails for some reason.
+ - see Ben's TODO list in his comlib.r
+ - maybe make some functions sizeof_LPCWSTR, sizeof_WCHAR etc. so we can judge the size of memory to allocate accurately?
+ (I wanted this for creating an exception struct, which now seems not necessary.)
+ }
+ Notes: {
+ - exporting from Microsoft Outlook
+ http://www.microsoft.com/technet/scriptcenter/resources/officetips/may05/tips0517.mspx
+
+ - This is how initialize works:
+
+ stored-routines: [...]
+ stored-api-funcs: [...]
+
+ stored-routines (all routine specs)
+ |
+ /only-these-routines routine-names <-- maybe rename back to /selected-routines
+ |
+ my-routines
+
+ stored-api-funcs (all api function specs)
+ |
+ /only-these-functions function-names <-- maybe rename back to /selected-functions
+ |
+ my-functions
+
+ Check dependencies of stored-api-funcs and extend the selected (routine or api) specs as necessary
+
+ routines: context my-routines
+ api: context my-functions
+
+ - Dependency information is in stored-routines and stored-api-funcs, eg, the release function needs the releaseObject routine:
+
+ "release" [
+ func [
+ 'object
+ ][
+ releaseObject get object
+ set object none
+ ]
+ ]["releaseObject"] ; <-- list of dependencies
+
+ - API and ROUTINES are separate contexts.
+ ROUTINES contains routines which interface to the DLL functions.
+ API contains rebol functions which comprise the Application Programmer Interface.
+ Many of the API functions wrap a routine with the same name, except the first letter is lowercase.
+ In the DLL the wrapped functions also lowercase the first letter.
+
+ So the functions are named like so:
+
+ comlib.r com2rebol.c disphelper.c
+
+ API
+ function! routine! function function
+
+ CreateObject -> createObject -> createObject -> dhCreateObject
+ PutValue -> putValue -> putValue -> dhPutValueV
+ CallMethod -> callMethod -> callMethod -> dhCallMethod
+ }
+]
+
+context [
+
+ library-file: clean-path %com2rebol.dll
+ library: none
+ load-library: func ["Load the external library."][library: load/library library-file]
+ free-library: func ["Free the external library."][free library library: none]
+
+ cleanup: func ["Release any unreleased objects and Free the COMLib DLL"
+ ][
+ ; release objects that the user has made using createObject and GetObject
+ foreach obj objects [routines/releaseObject obj]
+ clear objects
+
+ free-library
+
+ ; <- also try to free memory by unsetting words etc.
+ ]
+
+ objects: none
+
+ api: none
+ routines: none
+
+ error: none
+ ;exception: none ; struct! to store a DispHelper exception (DH_EXCEPTION, * PDH_EXCEPTION)
+
+ ; define CASE mezzanine function if not present (backwards compatibility)
+ case: either value? in system/words 'case [
+ get in system/words 'case ; use the native function built-in since View 1.2.54
+ ][
+ case: func [
+ "Find a condition and evaluates what follows it."
+ [throw]
+ cases [block!] "Block of cases to evaluate."
+ /default
+ case "Default case if no others are found."
+ /local condition body
+ ][
+ while [not empty? cases][
+ set [condition cases] do/next cases
+ if condition [
+ body: first cases
+ break
+ ]
+ cases: next cases
+ ]
+ do any [
+ body
+ case
+ ]
+ ]
+ ]
+
+ initialize: func ["Loads the COMLib DLL (external library) and creates the API ready for use. (Returns the api object.)"
+ [catch]
+ /only-these-routines routine-names {Make only a limited set of the routines named in routine-names (to save memory). eg. ["createObject"]}
+ /only-these-functions function-names {Make only a limited set of the api functions (or values) named in function-names}
+ /local my-routines my-functions all-routine-names all-function-names unknowns make-array
+ ][
+ if error? set/any 'error try [load-library][throw error]
+
+ my-routines: all-routine-names: extract stored-routines 3 ; default to all routines
+ if only-these-routines [
+ if not empty? unknowns: exclude routine-names my-routines [
+ throw make error! reform ["Selected routines not available:" mold unknowns]
+ ]
+ my-routines: intersect my-routines routine-names
+ ]
+ if not find my-routines "releaseObject" [append my-routines "releaseObject"] ; <- needed by cleanup
+ ;?? my-routines
+
+ my-functions: all-function-names: extract stored-api-funcs 3 ; default to all api functions
+ if only-these-functions [
+ if not empty? unknowns: exclude function-names my-functions [
+ throw make error! reform ["Selected api functions not found:" mold unknowns]
+ ]
+ my-functions: intersect my-functions function-names
+ ]
+ ;?? my-functions
+
+ foreach [name spec routine] stored-routines [ ; step through all the routines
+ ; check types of name, spec, routine
+ if not all [string? name block? spec string? routine][
+ throw make error! reform ["COMLib syntax error: storage format spec incorrect for routine:" mold name]
+ ]
+ ]
+
+ ; Check dependencies and extend routines or the api as necessary. (extend my-routines and my-functions)
+
+ foreach [name spec dependencies] stored-api-funcs [ ; step through all the functions
+ ; check types of name spec dependencies
+ if not all [string? name block? spec any [dependencies = 'none block? dependencies]][
+ throw make error! reform ["COMLib syntax error: storage format spec incorrect for:" mold name]
+ ]
+ ; (careful, dependencies can be the word 'none)
+ if all [find my-functions name block? dependencies][ ; is it one of the functions to go into the api, and does it have dependencies ?
+ foreach dependency dependencies [
+ case [
+ find all-routine-names dependency [if not find my-routines dependency [append my-routines dependency]]
+ find all-function-names dependency [if not find my-functions dependency [append my-functions dependency]]
+ "default" [
+ throw make error! reform ["COMLib: The function" name "depends on" dependency "but" dependency "is not available."]
+ ]
+ ]
+ ]
+ ]
+ ]
+
+ ;?? my-routines
+ ;?? my-functions
+
+ ; create the routines context
+ ; populate a context spec block with set-words from my-routines
+ routines: copy [none] foreach word my-routines [insert back tail routines to-set-word word]
+ routines: context routines
+
+ ; create the api context
+ ; populate a context spec block with set-words from my-functions
+ api: copy [none] foreach word my-functions [insert back tail api to-set-word word]
+ api: context api
+
+ ; make routines and functions and set them into the words in the context
+ foreach [name spec mangled] stored-routines [
+ if find my-routines name [
+ make-routine name spec mangled
+ ]
+ ]
+ foreach [name spec dependencies] stored-api-funcs [
+ if find my-functions name [
+ set in api to-word name do bind bind spec api routines
+ ; BINDed last to routines context so routines with the same name as api functions take precedence.
+ ; This is because most api functions wrap a routine with the same name (with only case of first letter different).
+ ]
+ ]
+
+
+ make-array: func [length [integer!] spec [block!] "eg: [ch [char!]]" /local result][
+ result: copy []
+ repeat n length [foreach [name type] spec [repend result [to-word join name n type]]]
+ result
+ ]
+
+ {; struct! to store a DispHelper exception (DH_EXCEPTION, * PDH_EXCEPTION)
+ exception: make struct! compose/deep [
+ [save]
+ InitialFunction [string!] ; LPCWSTR szInitialFunction;
+ ErrorFunction [string!] ; LPCWSTR szErrorFunction;
+
+ hr [int] ; HRESULT hr;
+
+ (make-array 64 [m0_ [char] m1_ [char]]) ; WCHAR szMember[64] (WCHAR is unsigned short, typedef'd in winnt.h)
+ (make-array 256 [c0_ [char] c1_ [char]]) ; WCHAR szCompleteMember[256]
+
+ Code [int] ; UINT swCode;
+ Description [string!] ; LPWSTR szDescription;
+ Source [string!] ; LPWSTR szSource;
+ HelpFile [string!] ; LPWSTR szHelpFile;
+ HelpContext [int] ; DWORD dwHelpContext (unsigned long, typedef'd in windef.h)
+
+ ArgError [int] ; UINT iArgError;
+
+ DispatchError [int] ; BOOL bDispatchError;
+
+ ;#ifdef DISPHELPER_INTERNAL_BUILD
+ Old [int] ; BOOL bOld;
+ ;#endif
+ ] none
+
+ ;print ["sizeof exception:" length? third exception] ; == 684 (correct)
+
+ ;api/setException third exception ; <-
+ }
+
+ objects: copy []
+
+ api
+ ]
+
+ make-routine: func [
+ name [string!]
+ spec [block!]
+ mangled [string!]
+ ] [
+ if error? set/any 'error try [
+ set in routines to-word rebolify name make routine! rebolify-spec spec library mangled
+ ] [
+ make error! reform ["COMLib: Problem creating routine for symbol:" mold name mold disarm error]
+ ]
+ ]
+
+ rebolify: func [{create the more rebolish version of the c symbol name}
+ name [string!] "c symbol name"
+ ][
+ name
+ ]
+ rebolify-spec: func [{convert block of c-style arguments closer to rebol routine! spec style}
+ spec [block!]
+ ][
+ spec: copy spec
+ ;?? spec
+ forskip spec 3 [
+ either spec/1 = 'return [spec/1: to-set-word 'return] [spec/1: to-word rebolify spec/1]
+ ]
+ head spec
+ ]
+
+ check-types: func [
+ [catch]
+ name [string!] args [block!] types [block!]
+ ][
+ repeat n length? types [
+ if types/:n <> type?/word args/:n [
+ throw make error! compose [script expect-arg (name) (join "args/" n) (types/:n)]
+ ]
+ ]
+ ]
+
+ ; generate a routine on the fly, to handle variadic functions (functions with a variable number of arguments)
+ do-variadic-routine: func [
+ [catch]
+ return-type [datatype!] ; eg. integer! or string!
+ dll-func-name [string!] ; eg. "getInteger", "getString", "getObj" "putValue" or "enumBegin"
+ args [block!] ; [integer! string!] "types other than integer or string are passed as integer"
+ types [block!] ; block of types that args must contain
+ /local err routine-spec count routine
+ ][
+ args: reduce args
+
+ ; convert logic!s to integer!
+ forall args [if logic? args/1 [args/1: to-integer args/1]] ; <-- most likely BOOL represented as int
+ args: head args ; backwards compatibility for FORALL, which used to leave series at tail
+
+ throw-on-error [check-types dll-func-name args types]
+
+ routine-spec: copy []
+
+ count: 0
+ foreach arg args [
+ append routine-spec compose/only [
+ (to-word join "arg_" count) (
+ case [
+ string? arg [[string!]]
+ binary? arg [[binary!]]
+ arg [[integer!]] ; integer or any other type is passed as integer
+ ]
+ )
+ ]
+ count: count + 1
+ ]
+
+ append routine-spec compose/deep [
+ return: [(to-word mold return-type)] ; <-- MOLD only used for backwards compatibility for View < 1.2.54
+ ]
+
+ routine: make routine! routine-spec library dll-func-name
+ do compose [routine (args)] ; call the routine with the specified args and return the result
+ ]
+
+ stored-routines: [
+ "showMessage" [
+ "message" [string!] "LPCSTR"
+ ] "showMessage"
+
+ "toggleExceptions" [
+ "option" [integer!] "int"
+ ] "toggleExceptions"
+
+ ;"setException" [
+ ; "exception" [binary!] "PDH_EXCEPTION exception"
+ ; ; return void
+ ;] "setException"
+
+ "formatLastException" [
+ return: [string!] "LPCSTR"
+ ] "formatLastException"
+
+ "showLastException" [] "showLastException"
+
+
+ "createObject" [
+ "objName" [string!] "LPCSTR ansiObjName"
+ "ppDisp" [binary!] "IDispatch **ppDisp"
+ return [integer!] "HRESULT"
+ ] "createObject"
+
+ "releaseObject" [
+ "obj" [integer!] ""
+ return [integer!] "HRESULT"
+ ] "releaseObject"
+
+
+ "getObject" [
+ "result" [binary!] "IDispatch **"
+ "parent" [integer!] ""
+ "szMember" [string!] ""
+ return [integer!] ""
+ ] "getObject"
+
+ ; These just test that the routines can be made from the variadic functions. They will actually be made on the fly later.
+
+ "callMethod" [
+ "obj" [integer!] "IDispatch *"
+ "szMember" [string!] "LPCSTR"
+ "test" [string!] ""
+ return [integer!] "HRESULT"
+ ] "callMethod"
+
+ "putValue" [
+ "obj" [integer!] "IDispatch *"
+ "szMember" [string!] ""
+ "test" [string!] ""
+ return [integer!] ""
+ ] "putValue"
+
+ ;"putValueInteger" [
+ ; "obj" [integer!] ""
+ ; "szMember" [string!] ""
+ ; "test" [integer!] ""
+ ; return [integer!] ""
+ ;] "putValue"
+
+ "getInteger" [
+ "result" [binary!] "UINT *"
+ "object" [integer!] ""
+ "szMember" [string!] ""
+ return [integer!] "HRESULT"
+ ] "getInteger"
+
+ "getString" [
+ "result" [binary!] "LPCSTR *"
+ "object" [integer!] ""
+ "szMember" [string!] ""
+ return [integer!] "HRESULT"
+ ] "getString"
+
+ "getStringCleanup" [] "getStringCleanup" ; <- this frees the string created by getString in the DLL memory
+
+ "putRef" [
+ "obj" [integer!] "IDispatch *"
+ "szMember" [string!] "LPCSTR"
+ return [integer!] "HRESULT"
+ ] "putRef"
+
+ ;enumBegin(IEnumVARIANT **ppEnum, IDispatch *pDisp, LPCSTR szMember, ...);
+ "enumBegin" [
+ "ppEnum" [binary!] "IEnumVARIANT **"
+ "obj" [integer!] "IDispatch *"
+ "szMember" [string!] "LPCSTR"
+ return [integer!] "HRESULT"
+ ] "enumBegin"
+
+ ;enumNextObject(IDispatch **ppDisp, IEnumVARIANT *pEnum);
+ "enumNextObject" [
+ "ppDisp" [binary!] "IDispatch **"
+ "enum" [integer!] "IEnumVARIANT *"
+ return [integer!] "HRESULT"
+ ] "enumNextObject"
+ ]
+
+ stored-api-funcs: [ ; storage format for the context spec
+
+ "failed?" [
+ func [
+ hr [integer!] "HRESULT"
+ ][
+ hr < 0 ; winerror.h : #define FAILED(Status) ((HRESULT)(Status)<0)
+ ]
+ ] none
+
+ "FormatLastException" [
+ func [][replace/all formatLastException crlf lf]
+ ] none
+
+ ; these functions wrap the equivalent routines so can handle exceptions and throw them as rebol errors
+
+ "CreateObject" [
+ func [
+ [catch]
+ objName [string!]
+ /local hr str
+ ][
+ ppDisp: make struct! [int [int]][0] ; IDispatch *
+
+ hr: createObject objName third ppDisp
+
+ if failed? hr [
+ ;print ["createObject caused an exception, hr:" hr to-hex hr]
+ ;print ["Exception:^/" api/formatLastException]
+ throw make error! api/FormatLastException
+ ]
+ insert objects ppDisp/int ; remember this object so we can release automatically on cleanup
+ ppDisp/int
+ ]
+ ] none
+
+ "release" [
+ func [
+ 'object
+ ][
+ ;print ["release" mold object]
+
+ ;if not none? get object [
+ releaseObject get object
+ if find objects get object [remove find objects get object]
+ ;]
+
+ ;set object none ; <---
+ set object 0
+ ]
+ ] ["releaseObject"]
+
+ "CallMethod" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...] Any extra args should be string! or integer!"
+ /local hr
+ ][
+ throw-on-error [ ; rethrow type-check errors thrown by do-variadic-routine
+ hr: do-variadic-routine integer! "callMethod" args [integer! string!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ hr
+ ]
+ ] ["failed?" "callMethod"]
+
+ "GetObject" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...]"
+ /local hr result
+ ][
+ result: make struct! [int [int]] none
+ insert args: copy args third result
+ throw-on-error [
+ hr: do-variadic-routine integer! "getObject" args [binary! integer! string!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ insert objects result/int ; remember this object so we can release automatically on cleanup
+ result/int
+ ]
+ ] ["getObject"]
+
+ "PutValue" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...]"
+ /local hr
+ ][
+ throw-on-error [
+ hr: do-variadic-routine integer! "putValue" args [integer! string!]
+ ]
+ ;print ["PutValue hr:" hr]
+ if failed? hr [throw make error! api/FormatLastException]
+ hr
+ ]
+ ] ["putValue"]
+
+ "PutRef" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...]"
+ /local hr
+ ][
+ throw-on-error [
+ hr: do-variadic-routine integer! "putRef" args [integer! string!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ hr
+ ]
+ ] ["putRef"]
+
+
+ "GetInteger" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...]"
+ /local hr result
+ ][
+ result: make struct! [int [int]] none
+ insert args: copy args third result
+ throw-on-error [
+ hr: do-variadic-routine integer! "getInteger" args [binary! integer! string!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ result/int
+ ]
+ ] ["getInteger"]
+
+ "GetString" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...]"
+ /local hr result
+ ][
+ result: make struct! [string [string!]] none
+ insert args: copy args third result
+ throw-on-error [
+ hr: do-variadic-routine integer! "getString" args [binary! integer! string!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ getStringCleanup ; let the DLL know we are finished with its string
+ result/string
+ ]
+ ] ["getString"]
+
+ "EnumBegin" [
+ func [
+ [catch]
+ args [block!] "[obj [integer!] szMember [string!] ...]" ; IDispatch *pDisp, LPCSTR szMember, ...
+ /local hr result
+ ][
+ result: make struct! [int [int]] none ; IEnumVARIANT **ppEnum
+ insert args: copy args third result
+ throw-on-error [
+ hr: do-variadic-routine integer! "enumBegin" args [binary! integer! string!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ result/int
+ ]
+ ] ["enumBegin"]
+
+ "EnumNextObject" [
+ func [
+ [catch]
+ args [block!] "[enum [integer!]]" ; IEnumVARIANT *pEnum
+ /local hr result
+ ][
+ ;print "EnumNextObject"
+ result: make struct! [int [int]] none ; IDispatch **ppDisp
+ insert args: copy args third result
+ throw-on-error [
+ hr: do-variadic-routine integer! "enumNextObject" args [binary! integer!]
+ ]
+ if failed? hr [throw make error! api/FormatLastException]
+ result/int
+ ]
+ ]["enumNextObject"]
+
+ ;#define FOR_EACH0(objName, pDisp, szMember) { \
+ ; IEnumVARIANT * xx_pEnum_xx = NULL; \
+ ; DISPATCH_OBJ(objName); \
+ ; if (SUCCEEDED(dhEnumBegin(&xx_pEnum_xx, pDisp, szMember))) { \
+ ; while (dhEnumNextObject(xx_pEnum_xx, &objName) == NOERROR) {
+
+ ;#define FOR_EACH1(objName, pDisp, szMember, arg1) { \
+ ; IEnumVARIANT * xx_pEnum_xx = NULL; \
+ ; DISPATCH_OBJ(objName); \
+ ; if (SUCCEEDED(dhEnumBegin(&xx_pEnum_xx, pDisp, szMember, arg1))) { \
+ ; while (dhEnumNextObject(xx_pEnum_xx, &objName) == NOERROR) {
+
+ ;#define NEXT(objName) SAFE_RELEASE(objName); }} SAFE_RELEASE(objName); SAFE_RELEASE(xx_pEnum_xx); }
+
+ "FOR_EACH" [
+ func [
+ [catch]
+ ;args [block!] "[objName [string!] obj [integer!] szMember [string!] ...]"
+ args [block!] "[word [word!] obj [integer!] szMember [string!] ...]"
+ code-body [block!]
+ /local word ctx enum
+ ][
+ ; <- check types
+ word: args/1
+
+ ctx: context compose [(to-set-word word) none]
+
+ enum: api/EnumBegin (copy next args) ; IEnumVARIANT ** ; <- trap error here too
+
+ while compose/deep [
+
+ throw-on-error [
+ (to-set-word in ctx word) api/EnumNextObject [enum]
+ ]
+ ;?? (in ctx word)
+
+ 0 <> (in ctx word)
+ ] bind code-body ctx
+
+ do compose [release (in ctx word)]
+ release enum
+ ]
+ ] none ; [api/EnumBegin api/EnumNextObject] <-- should be this
+
+ ]
+
+ ; If the user script passed a code block with DO/ARGS, then we
+ ; initialize, bind and do the user code, and finally cleanup.
+
+ if block? system/script/args [ ; <- user script passed a code block
+
+ set/any 'error try [ ; catch all errors so cleanup is always done
+
+ initialize
+ do bind system/script/args api ; <- use the COMLib API functions
+ ]
+ cleanup
+ get/any 'error ; let the last result return, or fire the error so the user can handle it
+ ]
+]
\ No newline at end of file
diff --git a/comlib/com2rebol.dll b/comlib/com2rebol.dll
new file mode 100644
index 0000000..3b627c6
Binary files /dev/null and b/comlib/com2rebol.dll differ
diff --git a/comlib/simple-start-comlib.r b/comlib/simple-start-comlib.r
new file mode 100644
index 0000000..03ad5ca
--- /dev/null
+++ b/comlib/simple-start-comlib.r
@@ -0,0 +1,39 @@
+rebol [
+ Title: "Simple start COMLib"
+ File: %simple-start-comlib.r
+ Date: 29-Jun-2006
+ Version: 1.0.0
+ Progress: 0.99
+ Status: "working"
+ Needs: []
+ Author: "Anton Rolls"
+ Language: "English"
+ Purpose: {The simplest, open/close COMLib script}
+ Usage: {}
+ History: [
+ 1.0.0 [29-Jun-2006 {First version} "Anton"]
+ ]
+ ToDo: {
+ -
+ }
+ Notes: {
+ The error handling is recommended, but may not be necessary.
+
+ See also test-comlib.r for a more complex, alternative way of using COMLib.
+ }
+]
+
+
+if error? set/any 'error try [
+
+
+ do/args %COMLib.r [
+
+ ; Use the COMLib API functions here.
+
+ ]
+
+
+][
+ print mold disarm error
+]
diff --git a/comlib/test-comlib.r b/comlib/test-comlib.r
new file mode 100644
index 0000000..868569f
--- /dev/null
+++ b/comlib/test-comlib.r
@@ -0,0 +1,99 @@
+rebol [
+ Title: "test COMLib"
+ File: %test-comlib.r
+ Date: 26-Jun-2006
+ Version: 1.0.1
+ Progress: 0.5
+ Status: "working"
+ Needs: []
+ Author: "Anton Rolls"
+ Language: "English"
+ Purpose: {Check that COMLib.r is working ok. Testing-ground for new features.}
+ Usage: {}
+ History: [
+ 1.0.0 [18-Dec-2005 {First version, tested on View 1.3.2} "Anton"]
+ 1.0.1 [26-Jun-2006 {working with comlib.r 1.1.3} "Anton"]
+ ]
+ ToDo: {
+ -
+ }
+ Notes: {See also simple-start-comlib.r}
+]
+
+;query/clear system/words
+COMLib: do %COMLib.r
+;probe query/clear system/words
+
+
+if error? set/any 'error try [ ; catch all errors so comlib/cleanup is always done
+
+ COMLib/initialize
+ ;COMLib/initialize/only-these-routines/only-these-functions [][]
+ ;COMLib/initialize/only-these-routines/only-these-functions []["CreateObject" "release"] ; <- check dependencies
+ ;COMLib/initialize/only-these-routines ["createObject"]
+ ;COMLib/initialize/only-these-functions ["CreateObject"]
+ ;COMLib/initialize/only-these-routines/only-these-functions ["createObject"]["getText"]
+ ;COMLib/initialize/only-these-routines/only-these-functions ["getText"]["createObject"] ; test arguments reversed
+
+ do bind [
+
+ ; <- use the COMLib API functions and routines here
+
+ szHeadings: ["Mammals" "Birds" "Reptiles" "Fishes" "Plants"]
+
+ xlApp: CreateObject "Excel.Application"
+
+ ;xlApp: createObject "Excel.ApplicationMISSPELLED"
+ ;release xlApp
+
+ ;PutValue [xlApp ".DisplayFullScreen = %b" "TRUE"] ; <- It actually wants a (BOOL)TRUE, but passing a string works too.
+ PutValue [xlApp ".Visible = %b" "TRUE"]
+
+ CallMethod [xlApp ".Workbooks.Add"]
+
+ PutValue [xlApp ".ActiveSheet.Name = %s" "Critically Endangered"]
+
+ {; test PutValue and GetString at high speed, alternating the value, to see if there are any latency problems.
+ loop 5000 [
+ PutValue [xlApp ".ActiveSheet.Name = %s" s1: "Hello"]
+ s2: GetString [xlApp ".ActiveSheet.Name"]
+ if s1 <> s2 [print ["s1 <> s2 s1:" s1 "s2:" s2] break]
+ PutValue [xlApp ".ActiveSheet.Name = %s" s1: "Goodbye"]
+ s2: GetString [xlApp ".ActiveSheet.Name"]
+ if s1 <> s2 [print ["s1 <> s2 s1:" s1 "s2:" s2] break]
+ ]}
+
+ repeat n 5 [
+ PutValue compose [xlApp ".ActiveSheet.Cells(%d,%d) = %s" 1 n szHeadings/:n]
+ ]
+
+ ; This causes real havoc with Excel, tries to fill every cell with the string, runs out of memory.
+ ;PutValue [xlApp ".ActiveSheet.Cells(1,10) = %s" "abc123"]
+
+ ; This sent my system to hell, used all my memory, which was not freed when I terminated EXCEL.EXE
+ ; The format string parameters must be specified separately, not inline as above.
+ ;GetString [xlApp ".ActiveSheet.Cells(1,10)"]
+
+ ; test memory stability of GetString (seems to be good)
+ {large-string: copy "abc"
+ repeat n 5000 [append large-string form n]
+ PutValue [xlApp ".ActiveSheet.Cells(%d,%d) = %s" 5 1 large-string]
+ repeat n 1000 [
+ string: GetString [xlApp ".ActiveSheet.Cells(%d,%d)" 5 1]
+ ]}
+
+ release xlApp
+
+ ] COMLib/api
+
+][
+ ;COMLib/routines/showLastException
+ ;wait 0.125
+ ;print ["COMLib Exception:^/" COMLib/routines/formatLastException]
+ ;wait 0.125
+ print mold disarm error
+]
+;probe query/clear system/words
+
+COMLib/cleanup
+;probe query/clear system/words
|