REBOL [ Title: "Various utility functions" Purpose: { Defines various useful functions. } Author: "Gabriele Santilli" EMail: giesse@rebol.it File: %utility.r Date: 4-Feb-2005 Version: 1.22.1 ; majorv.minorv.status ; status: 0: unfinished; 1: testing; 2: stable License: { Copyright (c) 2003, Gabriele Santilli All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The name of Gabriele Santilli may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. } History: [ 27-Nov-2003 1.1.0 "History start" 27-Nov-2003 1.2.0 "fortype, export, import; configuration functions" 28-Nov-2003 1.3.0 "zero-padded, vid-context" 28-Nov-2003 1.4.0 "if-error, invalid-argument, get-all, localize" 28-Nov-2003 1.5.0 "form-error" 28-Nov-2003 1.6.0 "nforeach" 23-Dec-2003 1.7.0 "get-current-platform" 2-Jan-2004 1.8.0 "substitute" 2-Mar-2004 1.9.1 "Started adding documentation" 3-Mar-2004 1.10.1 "Finished documentation" 27-Mar-2004 1.11.1 "Added logging function (set-log, append-log)" 6-Apr-2004 1.12.1 "Added CLOSURE and fixed LOCALIZE" 13-May-2004 1.13.1 "Added MERGE-CONFIG" 19-May-2004 1.14.1 "Fixed a bug in FORM-ERROR" 21-Jun-2004 1.15.1 "MERGE-CONFIG now accepts a block too" 21-Oct-2004 1.16.1 "Added RSA encryption functions" 21-Oct-2004 1.17.1 "Switched to Rijndael for RSA keys encryption; also now uses checksum on the passphrase" 20-Jan-2005 1.18.1 "Added EFUNC and EXTEND" 31-Jan-2005 1.19.1 "Added debugging functions" 31-Jan-2005 1.20.1 "Fixed a bug in the debug FUNC" 31-Jan-2005 1.21.1 "Removed the fix as it was worse than the bug. Recursion debugging has some quirks." 4-Feb-2005 1.22.1 "Added /CATCH to SET-CONFIG" ] ] ; comment the following line if you are using autodoc.r ;#do [document: func [text] [none]] #do [document { ===Various utility functions (utility.r) This script provides a number of general purpose useful functions. ---Context functions EXPORT takes a word or a block of words, and "exports" their value to SYSTEM/WORDS or to the object given with the /TO refinement. Basically, export 'word is equivalent to: set/any in system/words 'word get/any 'word while export/to 'word object is equivalent to: set/any in object 'word get/any 'word Note that if you pass a block, non-words values are just ignored. }] export: func [ "Export local words in the global context" words [word! block!] /to dest [object!] "Export to this object instead of SYSTEM/WORDS" /local word ] [ dest: any [dest system/words] fortype word! to-block words func [word] [ set/any in dest word get/any word ] ] #do [document { IMPORT is the reverse of EXPORT. Basically, import 'word object is equivalent to: set/any 'word get/any in object 'word Note that if you pass a block, non-word values ar just ignored. }] import: func [ "Import words from an object" words [word! block!] source [object!] ] [ fortype word! to-block words func [word] [ set/any word get/any in source word ] ] #do [document { VID-CONTEXT is similar to the CONTEXT function, except that is intended for VID layout blocks. It scans the block for SET-WORD!s, and creates an object with all of them; then binds the block to this object's context and returns it (the block). An example usage is: ... layout vid-context [ ; 'F and 'B are made automatically local f: Field b: Button ] The /TO refinement can be used to set a word to the created object. }] vid-context: func [ "Localize the words in the VID code" vid-block [block!] /to word [word!] "Set this word to the context created" /local ctx ] [ ctx: clear [] word: any [word 'ctx] fortype set-word! vid-block func [word] [ insert tail ctx :word ] insert tail ctx none bind vid-block in set word context ctx 'self ] #do [document { GET-ALL takes a block of words (only WORD!s) and returns a block with the respective values. For example: a: 1 b: 2 get-all [a b] ; == [1 2] The difference with REDUCE is that GET-ALL does not evaluate (just uses GET/ANY). }] get-all: func [ "Get (without evaluating) all words in a block" [catch] words [block!] ] [ words: copy words if not parse words [any [words: word! (change/only words get/any words/1)] end] [ invalid-argument pick words 1 ] head words ] #do [document { LOCALIZE (which probably needs a new name) is just like USE, except that keeps the values of the words it makes local. Example: a: 1 b: 2 localize [a b] [ ; here a = 1 and b = 2 b: 3 ] ; b is still 2 here }] localize: func [ "Defines words local to a block, but keeps their value" [catch] words [block!] body [block!] ] [ use words reduce [ 'set copy words throw-on-error [get-all words] 'do body ] ] #do [document { ---Function makers CLOSURE creates functions with a dynamic context. It can be used just like FUNC, except that it creates a new context at each invocation of the function. }] closure: func [ "Defines a closure with given spec and body." [catch] spec [block!] "Help string (opt) followed by arg words (and opt type and string)" body [block!] "The body block of the closure" /local word words ] [ words: make block! 2 + length? spec parse spec [ any [ set word [word! | refinement!] (insert tail words to word! word) | skip ] ] throw-on-error [ make function! spec reduce [ 'localize words 'copy/deep body ] ] ] #do [document { EFUNC creates extensible functions. EFUNC can be used just like FUNC, except that the created function can be "extended" using the EXTEND function (see below), like classes in OO languages can be extended creating subclasses. "Subfunctions" can call the "parent" function using the SUPER word. }] efunc: func [ "Defines an extensible function with given spec and body." [catch] spec [block!] "Help string (opt) followed by arg words (and opt type and string)" body [block!] "The body block of the function" ] [ spec: copy spec either find spec /local [append spec '_bodies] [append spec [/local _bodies]] use [super] [ super: does [ if head? _bodies [throw make error! "There is no super!"] _bodies: back _bodies do _bodies/1 ] bind body 'super body: make function! spec compose/only/deep [_bodies: tail [(body)] super] bind second :super first second :body :body ] ] #do [document { EXTEND extends an efunc by adding a new body block for it. The new body block can call the previous body block using the SUPER word. }] extend: func [ "Extend an extensible function (see EFUNC)" super [function! word!] "The extensible function to extend" body [block!] "New body block" ] [ if word? :super [super: get super] bind body first second :super bind body last second :super insert/only tail third second :super body :super ] #do [document { ---Control and loop functions FORTYPE evaluates a function for each value in a block of a given type (any other value is skipped). For example, fortype word! [1 a 2 b] func [word] [probe word] only prints 'A and 'B. }] fortype: func [ "Evaluate a function for each value of a given datatype in a block" datatype [datatype!] block [block!] f [any-function!] /local value ] [ parse block [ some [ to datatype set value datatype (f :value) ] ] ] #do [document { NFOREACH is a generalization of the FOREACH function; it can loop over multiple series at the same time. The first argument is a block of words and series, in pairs. The first element can be a word, a get-word evaluating to a word or a block, or a block. The meaning is the same as the first argument of the FOREACH function. The second element is evaluated and must evaluate to a series value. Examples: nforeach [a [1 2 3] b [4 5 6]] [ print [a b] ] ; will print: ; 1 4 : 2 5 ; 3 6 ; block1: [1 2 3] block2: [4 5 6] nforeach [a block1 b block2] [ print [a b] ] ; will print same as above ; nforeach [[a b] [1 2 3 4 5 6] c [7 8 9]] [ print [a b c] ] ; will print: ; 1 2 7 ; 3 4 8 ; 5 6 9 ; nforeach [[a b] join block1 block2 c [7 8 9]] [ print [a b c] ] ; will print same as above ; word: 'a nforeach [:word [1 2 3]] [ print a ] ; will print: ; 1 ; 2 ; 3 }] context [ ceil: func [num [number!]] [either num > num: to integer! num [num + 1] [num]] nforeach: func [ "Evaluates a block for each value(s) in one or more series" [catch] args [block!] "Words and series" body [block!] "Block to evaluate each time" /local bargs words end word ] [ bargs: copy [body] words: make block! 16 end: 0 while [not tail? args] [ word: pick args 1 if not any [ word? :word block? :word all [get-word? :word any [word? word: get :word block? :word]] ] [ invalid-argument :word ] use [series] [ set [series args] do/next next args if not series? :series [ invalid-argument :series ] insert tail words word either block? word [ repeat j length? word [ insert insert insert insert tail bargs [pick :series i - 1 *] length? word '+ j ] end: max end ceil divide length? :series length? word ] [ insert tail bargs [pick :series i] end: max end length? :series ] ] ] if any [empty? words empty? bargs] [return none] body: func words body repeat i end bargs ] export 'nforeach ] #do [document { ---Configuration LOAD-CONFIG loads configuration values from a file (can be a molded object or a block of set-word/value pairs). SAVE-CONFIG saves the current configuration values to a file. GET-CONFIG gets a configuration value. If the given word is not present in the configuration object, NONE is returned. It is possible to use the /DEFAULT refinement to choose a different value to be returned in this case instead of NONE. The /ACCEPT refinement, instead, allows to define the datatype(s) that are acceptable as result: if the word has, in the configuration object, a value of a type that does not match one of those given with /ACCEPT, NONE (or the value provided with the /DEFAULT refinement) is returned. The combination of /ACCEPT and /DEFAULT allows to write secure applications; even if the user tampers with the configuration file, for example placing a molded function as the value of a word, it won't be returned by GET-CONFIG (unless the programmer asks for it). SET-CONFIG sets the value of a word in the configuration object. (If the word is not already present in the object, it is added.) If the /SAVE refinement is used, the configuration is saved to a file after setting the value. If the /CATCH refinement is used, a function must be passed as the VALUE argument; this function is then called each time the specified config value is changed using SET-CONFIG, with the new value as argument; its return value is then set in the configuration object. This allows to catch changes to the configuration, but also to validate or modify the values before they get set in the configuration object. MERGE-CONFIG merges a configuration object into the current configuraion. It is used as a quick way to change a lot of configuration values at once. }] context [ config: context [] setconf: func [conf [block! object!]] [config: :conf] load-config: func [ "Load configuration values from a file" file [file! url! block!] ] [ attempt [setconf load file] if block? config [ config: construct config ] config ] save-config: func [ "Save configuration values to a file" file [file! url!] ; SAVE does cannot get a port spec as argument ?!? ] [ save/all file config ] get-config: func [ "Get a configuration value" word [word!] "The name of the configuration value" /default default' "Use this default value instead of NONE" /accept types [datatype! block!] "Only accept the value if it is of one of the given types" ] [ either all [ word: in config word any [not types find reduce to block! types type? get/any word] ] [ get/any word ] [ :default' ] ] set-config: func [ "Set a configuration value" [catch] word [word!] "The name of the configuration value" value /save file [file! url!] "Save the configuration after setting the value" /catch "Set a function to catch changes to this configuration values" ] [ if catch [ if not any-function? :value [invalid-argument :value] if not in handlers word [ handlers: make handlers reduce [ to set-word! word none ] ] return set in handlers word :value ] if not in config word [ config: make config reduce [ to set-word! word none ] ] set/any in config word catch-config word :value if save [save-config file] :value ] catch-config: func [ word [word!] value ] [ either word: in handlers word [ do get word :value ] [ :value ] ] handlers: context [ ] merge-config: func [ "Merge a configuration object into the current configuraion" values [object! block!] ] [ if block? values [values: construct values] foreach word next first values [ set-config word get in values word ] ] export [ load-config "Load configuration values from a file" save-config "Save configuration values to a file" get-config "Get a configuration value" set-config "Set a configuration value" merge-config "Merge new configuration values" ] ] #do [document { GET-CURRENT-PLATFORM (maybe should be called GET-OS?) returns the name of the platform the script is running on (i.e. one of Amiga, Mac, Windows, Linux, BeOS, BSDi, FreeBSD, NetBSD, OpenBSD, Solaris, Irix, HP-UX) as a REBOL word. }] get-current-platform: func [ "Return name of current platform as a word" ] [ pick [ Amiga Mac Windows Linux BeOS BSDi FreeBSD NetBSD OpenBSD Solaris Irix HP-UX ] pick system/version 4 ] #do [document { ---String manipulation ZERO-PADDED pads a number or string with zeroes up to the desired length. The string is truncated if it is longer that the desired length. }] zero-padded: func [ "Left pad a number or string with zeros." n [number! string!] "Number to pad" len [integer!] "Desired length (the number will be truncated if it is longer!)" ] [ copy skip insert insert/dup clear "" #"0" len n negate len ] #do [document { SUBSTITUTE comes very handy if you are using locale.r. Each occurrence of "" inside the string is replaced with the value of 'word in the given object. (Note that it creates a new string.) Example: substitute "Dear <name>," [ title: "Mr." name: "Smith" ] ; == "Dear Mr. Smith," }] substitute: func [ "Do variable substitution inside a string" string [any-string!] vars [object! block!] /local rule out start end emit ] [ out: make string 2 + length? string emit: func [str] [insert tail out :str] rule: make block! 256 if block? vars [vars: context vars] foreach word next first vars [ insert tail rule compose/deep [ (either empty? rule [ ] [ '| ]) (form word) ">" (to paren! bind compose [emit (word)] in vars 'self) ] ] parse/all string [ any [ start: to "<" end: (insert/part tail out start end) ["<" rule | skip (emit "<")] ] (insert tail out start) ] out ] #do [document { ---Error handling IF-ERROR TRYes a block, and in case of error DOes the on-error block, with the (local) word 'ERROR set to the error. if-error [page: read http://www.rebol.com] [ print "Cannot read REBOL home page." ] }] if-error: func [ "Tries to DO code, then DOes on-error if it fails" [throw] code [block!] on-error [block!] "The word 'error will refer to the error" /local result ] [ on-error: func [[throw] error [error!]] on-error either error? set/any 'result try code [on-error :result] [get/any 'result] ] invalid-argument: func [ {Throw an "Invalid argument" error} arg ] [ throw make error! join [script invalid-arg] :arg ] #do [document { FORM-ERROR takes a disarmed error object and creates an error message. With the /ALL refinement, the result is the same as would be produced by the REBOL console. }] form-error: func [ "Forms an error message" errobj [object!] "Disarmed error" /all "Use the same format as the REBOL console" /local errtype text ] [ errtype: get in system/error get in errobj 'type text: get in errtype get in errobj 'id if block? text [text: reform bind/copy text in errobj 'self] either all [ rejoin [ "** " get in errtype 'type ": " text newline either get in errobj 'where [join "** Where: " [mold get in errobj 'where newline]] [""] either get in errobj 'near [join "** Near: " [mold/only get in errobj 'near newline]] [""] ] ] [ text ] ] #do [document { ---Logging APPEND-LOG is a function to append a line of text to a log file. This line, or "log message", is appended to the file if its "level" if lesser or equal to the log file level. The line is tagged with the current date and time. The SET-LOG function is used to set the log file name and the log file level. }] context [ log-level: 0 log-file: %default.log set-log: func [ "Set logging options" file [file!] "Log file name" level [integer!] "Log file level" ] [ log-level: level log-file: file ] append-log: func [ "Append a line to the log file" level [integer!] "Line level" line [string! block!] ] [ if level <= log-level [ write/append/lines log-file append rejoin ["[" now "] "] reduce line ] ] export [ set-log "Function to set logging options" append-log "Function to append a line to the log file" ] ] #do [document { ---Debugging To Be Documented. }] either all [value? 'debug? debug?] [ debug: func [ condition output ] [ if condition [print output] ] if-debug: func [ [throw] code ] [ do code ] if not value? 'recursion-level-alert [recursion-level-alert: 6] func: make function! [ "Defines a user function with given spec and body." spec [block!] {Help string (opt) followed by arg words (and opt type and string)} body [block!] "The body block of the function" ] [ use [recursion-count __result __self __error] [ recursion-count: 0 __self: make function! spec compose/only [ recursion-count: recursion-count + 1 if recursion-count > recursion-level-alert [ print "*** Recursion level alert!" print mold :__self ask "?? " ] set/any '__result do make function! [ ] (body) recursion-count: recursion-count - 1 get/any '__result ] ] ] does: make function! [ {A shortcut to define a function that has no arguments or locals.} body [block!] "The body block of the function" ] [ func [] body ] has: make function! [ {A shortcut to define a function that has local variables but no arguments.} locals [block!] body [block!] ] [ func head insert copy locals /local body ] closure: func [ "Defines a closure with given spec and body." spec [block!] "Help string (opt) followed by arg words (and opt type and string)" body [block!] "The body block of the closure" /local word words ] [ words: make block! 2 + length? spec parse spec [ any [ set word [word! | refinement!] (insert tail words to word! word) | skip ] ] func spec reduce [ 'localize words 'copy/deep body ] ] ] [ debug: func [conditions output] [ ] if-debug: func [code] [ ] ] #do [document { ---RSA encryption RSA-NEW-KEYPAIR is a shortcut function to generate a new 1024 bit RSA key pair. It returns a new RSA key object. }] rsa-new-keypair: has [k] [ k: rsa-make-key rsa-generate-key k 1024 3 k ] #do [document { RSA-SAVE-KEY encrypts a key with a passphrase and saves it. The passphrase has to be at least 16 characters long. The key can be loaded back with the RSA-LOAD-KEY function. }] rsa-save-key: func [ "Encrypts and saves a RSA key object" file [file! url! object! block! port!] "File to save to" k [object!] "RSA key" passphrase [any-string!] "Pass phrase to use to encrypt the key (at least 16 characters long)" /local crypt-port ] [ crypt-port: make port! [ scheme: 'crypt algorithm: 'rijndael direction: 'encrypt strength: 128 key: copy/part checksum/secure passphrase 16 padding: true ] open crypt-port insert crypt-port mold/all k update crypt-port write/binary file copy crypt-port close crypt-port ] #do [document { RSA-LOAD-KEY decrypts a key using the given passphrase and loads it. Returns NONE if the passphrase is not valid. }] rsa-load-key: func [ "Decrypts and loads a RSA key object" file [file! url! object! block! port!] "File to load from" passphrase [any-string!] "Pass phrase used to encrypt the key" /local crypt-port k ] [ crypt-port: make port! [ scheme: 'crypt algorithm: 'rijndael direction: 'decrypt strength: 128 key: copy/part checksum/secure passphrase 16 padding: true ] open crypt-port insert crypt-port read/binary file update crypt-port k: attempt [load to string! copy crypt-port] close crypt-port k ] #do [document { RSA-LOAD-PUBLIC-KEY creates a RSA key object from a public key, passed as binary data. }] rsa-load-public-key: func [ "Creates a RSA key object from a public key binary data" public-key [binary!] /local k ] [ k: rsa-make-key k/e: 3 k/n: public-key k ] #do [document { RSA-CHECK-SIGNATURE checks if a signature is valid for the given data, using the given public key as a RSA key object. Returns TRUE if the signature is valid. }] rsa-check-signature: func [ "Checks some data against a RSA signature, returns TRUE if it's valid" k [object!] "Public key" data [any-string!] signature [binary!] ] [ all [ signature: attempt [rsa-encrypt/decrypt k signature] signature = checksum/secure data ] ] #do [document { RSA-MAKE-SIGNATURE generates a RSA signature for the given data using the provided private key. }] rsa-make-signature: func [ "Generates a RSA signature for the given data" k [object!] "Private key" data [any-string!] ] [ rsa-encrypt/private k checksum/secure data ]