├── .editorconfig
├── LICENSE
├── README.md
├── experimental
    ├── altxml.r3
    ├── altxml.reb
    ├── altxml.red
    ├── curl.reb
    ├── markup.reb
    ├── rest.reb
    └── send.reb
├── makedoc
    ├── asciidoc.r
    ├── document.r
    ├── html.r
    ├── paragraph.r
    ├── s5.r
    └── s5.rsp
├── r3-alpha
    ├── altjson.r3
    ├── altwebform.r3
    ├── altxml.r3
    ├── as.r3
    ├── color-code.r3
    ├── combine.r3
    ├── form-date.r3
    ├── httpd.r3
    ├── jqm.r3
    ├── make-feed.r3
    ├── makedoc.r3
    ├── match.r3
    ├── rest.r3
    ├── rsp.r3
    ├── styletalk.r3
    └── uuid.r3
├── rebol-2
    ├── bincode.r
    ├── clean-script.r
    ├── curl.r
    ├── deflate.r
    ├── do-with.r
    ├── match.r
    ├── metadb.r
    ├── msgpack.r
    ├── rest.r
    ├── s3.r
    └── zip.r
├── red
    ├── altjson.red
    ├── clean-script.red
    ├── clean.red
    ├── color-code.red
    ├── form-date.red
    ├── rsp.red
    ├── simplediff.red
    └── svg.red
└── ren-c
    ├── altjson.reb
    ├── altwebform.reb
    ├── altxml.reb
    ├── clean.reb
    ├── curl.reb
    ├── form-date.reb
    ├── httpd.reb
    ├── readme.md
    ├── rsp.reb
    ├── twitter.reb
    └── wordify.reb


/.editorconfig:
--------------------------------------------------------------------------------
1 | root = true
2 | 
3 | [*]
4 | end_of_line = lf
5 | charset = utf-8
6 | indent_style = tab
7 | indent_size = 4
8 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
  1 | Apache License
  2 | Version 2.0, January 2004
  3 | http://www.apache.org/licenses/
  4 | 
  5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
  6 | 
  7 | 1. Definitions.
  8 | 
  9 | "License" shall mean the terms and conditions for use, reproduction, and
 10 | distribution as defined by Sections 1 through 9 of this document.
 11 | 
 12 | "Licensor" shall mean the copyright owner or entity authorized by the copyright
 13 | owner that is granting the License.
 14 | 
 15 | "Legal Entity" shall mean the union of the acting entity and all other entities
 16 | that control, are controlled by, or are under common control with that entity.
 17 | For the purposes of this definition, "control" means (i) the power, direct or
 18 | indirect, to cause the direction or management of such entity, whether by
 19 | contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the
 20 | outstanding shares, or (iii) beneficial ownership of such entity.
 21 | 
 22 | "You" (or "Your") shall mean an individual or Legal Entity exercising
 23 | permissions granted by this License.
 24 | 
 25 | "Source" form shall mean the preferred form for making modifications, including
 26 | but not limited to software source code, documentation source, and configuration
 27 | files.
 28 | 
 29 | "Object" form shall mean any form resulting from mechanical transformation or
 30 | translation of a Source form, including but not limited to compiled object code,
 31 | generated documentation, and conversions to other media types.
 32 | 
 33 | "Work" shall mean the work of authorship, whether in Source or Object form, made
 34 | available under the License, as indicated by a copyright notice that is included
 35 | in or attached to the work (an example is provided in the Appendix below).
 36 | 
 37 | "Derivative Works" shall mean any work, whether in Source or Object form, that
 38 | is based on (or derived from) the Work and for which the editorial revisions,
 39 | annotations, elaborations, or other modifications represent, as a whole, an
 40 | original work of authorship. For the purposes of this License, Derivative Works
 41 | shall not include works that remain separable from, or merely link (or bind by
 42 | name) to the interfaces of, the Work and Derivative Works thereof.
 43 | 
 44 | "Contribution" shall mean any work of authorship, including the original version
 45 | of the Work and any modifications or additions to that Work or Derivative Works
 46 | thereof, that is intentionally submitted to Licensor for inclusion in the Work
 47 | by the copyright owner or by an individual or Legal Entity authorized to submit
 48 | on behalf of the copyright owner. For the purposes of this definition,
 49 | "submitted" means any form of electronic, verbal, or written communication sent
 50 | to the Licensor or its representatives, including but not limited to
 51 | communication on electronic mailing lists, source code control systems, and
 52 | issue tracking systems that are managed by, or on behalf of, the Licensor for
 53 | the purpose of discussing and improving the Work, but excluding communication
 54 | that is conspicuously marked or otherwise designated in writing by the copyright
 55 | owner as "Not a Contribution."
 56 | 
 57 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf
 58 | of whom a Contribution has been received by Licensor and subsequently
 59 | incorporated within the Work.
 60 | 
 61 | 2. Grant of Copyright License.
 62 | 
 63 | Subject to the terms and conditions of this License, each Contributor hereby
 64 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
 65 | irrevocable copyright license to reproduce, prepare Derivative Works of,
 66 | publicly display, publicly perform, sublicense, and distribute the Work and such
 67 | Derivative Works in Source or Object form.
 68 | 
 69 | 3. Grant of Patent License.
 70 | 
 71 | Subject to the terms and conditions of this License, each Contributor hereby
 72 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
 73 | irrevocable (except as stated in this section) patent license to make, have
 74 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where
 75 | such license applies only to those patent claims licensable by such Contributor
 76 | that are necessarily infringed by their Contribution(s) alone or by combination
 77 | of their Contribution(s) with the Work to which such Contribution(s) was
 78 | submitted. If You institute patent litigation against any entity (including a
 79 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a
 80 | Contribution incorporated within the Work constitutes direct or contributory
 81 | patent infringement, then any patent licenses granted to You under this License
 82 | for that Work shall terminate as of the date such litigation is filed.
 83 | 
 84 | 4. Redistribution.
 85 | 
 86 | You may reproduce and distribute copies of the Work or Derivative Works thereof
 87 | in any medium, with or without modifications, and in Source or Object form,
 88 | provided that You meet the following conditions:
 89 | 
 90 | You must give any other recipients of the Work or Derivative Works a copy of
 91 | this License; and
 92 | You must cause any modified files to carry prominent notices stating that You
 93 | changed the files; and
 94 | You must retain, in the Source form of any Derivative Works that You distribute,
 95 | all copyright, patent, trademark, and attribution notices from the Source form
 96 | of the Work, excluding those notices that do not pertain to any part of the
 97 | Derivative Works; and
 98 | If the Work includes a "NOTICE" text file as part of its distribution, then any
 99 | Derivative Works that You distribute must include a readable copy of the
100 | attribution notices contained within such NOTICE file, excluding those notices
101 | that do not pertain to any part of the Derivative Works, in at least one of the
102 | following places: within a NOTICE text file distributed as part of the
103 | Derivative Works; within the Source form or documentation, if provided along
104 | with the Derivative Works; or, within a display generated by the Derivative
105 | Works, if and wherever such third-party notices normally appear. The contents of
106 | the NOTICE file are for informational purposes only and do not modify the
107 | License. You may add Your own attribution notices within Derivative Works that
108 | You distribute, alongside or as an addendum to the NOTICE text from the Work,
109 | provided that such additional attribution notices cannot be construed as
110 | modifying the License.
111 | You may add Your own copyright statement to Your modifications and may provide
112 | additional or different license terms and conditions for use, reproduction, or
113 | distribution of Your modifications, or for any such Derivative Works as a whole,
114 | provided Your use, reproduction, and distribution of the Work otherwise complies
115 | with the conditions stated in this License.
116 | 
117 | 5. Submission of Contributions.
118 | 
119 | Unless You explicitly state otherwise, any Contribution intentionally submitted
120 | for inclusion in the Work by You to the Licensor shall be under the terms and
121 | conditions of this License, without any additional terms or conditions.
122 | Notwithstanding the above, nothing herein shall supersede or modify the terms of
123 | any separate license agreement you may have executed with Licensor regarding
124 | such Contributions.
125 | 
126 | 6. Trademarks.
127 | 
128 | This License does not grant permission to use the trade names, trademarks,
129 | service marks, or product names of the Licensor, except as required for
130 | reasonable and customary use in describing the origin of the Work and
131 | reproducing the content of the NOTICE file.
132 | 
133 | 7. Disclaimer of Warranty.
134 | 
135 | Unless required by applicable law or agreed to in writing, Licensor provides the
136 | Work (and each Contributor provides its Contributions) on an "AS IS" BASIS,
137 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied,
138 | including, without limitation, any warranties or conditions of TITLE,
139 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are
140 | solely responsible for determining the appropriateness of using or
141 | redistributing the Work and assume any risks associated with Your exercise of
142 | permissions under this License.
143 | 
144 | 8. Limitation of Liability.
145 | 
146 | In no event and under no legal theory, whether in tort (including negligence),
147 | contract, or otherwise, unless required by applicable law (such as deliberate
148 | and grossly negligent acts) or agreed to in writing, shall any Contributor be
149 | liable to You for damages, including any direct, indirect, special, incidental,
150 | or consequential damages of any character arising as a result of this License or
151 | out of the use or inability to use the Work (including but not limited to
152 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or
153 | any and all other commercial damages or losses), even if such Contributor has
154 | been advised of the possibility of such damages.
155 | 
156 | 9. Accepting Warranty or Additional Liability.
157 | 
158 | While redistributing the Work or Derivative Works thereof, You may choose to
159 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or
160 | other liability obligations and/or rights consistent with this License. However,
161 | in accepting such obligations, You may act only on Your own behalf and on Your
162 | sole responsibility, not on behalf of any other Contributor, and only if You
163 | agree to indemnify, defend, and hold each Contributor harmless for any liability
164 | incurred by, or claims asserted against, such Contributor by reason of your
165 | accepting any such warranty or additional liability.
166 | 
167 | END OF TERMS AND CONDITIONS
168 | 
169 | APPENDIX: How to apply the Apache License to your work
170 | 
171 | To apply the Apache License to your work, attach the following boilerplate
172 | notice, with the fields enclosed by brackets "[]" replaced with your own
173 | identifying information. (Don't include the brackets!) The text should be
174 | enclosed in the appropriate comment syntax for the file format. We also
175 | recommend that a file or class name and description of purpose be included on
176 | the same "printed page" as the copyright notice for easier identification within
177 | third-party archives.
178 | 
179 |    Copyright 2022 Christopher Ross-Gill
180 | 
181 |    Licensed under the Apache License, Version 2.0 (the "License");
182 |    you may not use this file except in compliance with the License.
183 |    You may obtain a copy of the License at
184 | 
185 |      http://www.apache.org/licenses/LICENSE-2.0
186 | 
187 |    Unless required by applicable law or agreed to in writing, software
188 |    distributed under the License is distributed on an "AS IS" BASIS,
189 |    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
190 |    See the License for the specific language governing permissions and
191 |    limitations under the License.
192 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | Scripts
 2 | =======
 3 | 
 4 | Library scripts for various flavours of [Rebol](http://rebol.info). Scripts target the following variants:
 5 | 
 6 | * [R3C](https://github.com/metaeducation/ren-c/tree/r3c) (upcoming)
 7 | * [Rebol 2](http://www.rebol.com/download-core.html)
 8 | * [Ren-C](https://github.com/metaeducation/ren-c/) (moving target)
 9 | * [Red](https://www.red-lang.org/)
10 | * [Rebol 3 (Alpha)](https://rebolsource.net/) (with a degree of compatibility with [Rebol 3 (Oldes)](https://github.com/Oldes/Rebol3))
11 | 
12 | Some effort is made to ensure a degree of consistency where a script exists for multiple variants.
13 | 
14 | Maintenance of this collection is a personal undertaking and while I strive to meet certain organizational standards, it is subject to other demands on time and attention. Be kind, patient and I hope this is of use to you.
15 | 
16 | Me on [Twitter](https://twitter.com/rgrebol).
17 | 
18 | ![RebIT!](http://rebol.info/assets/icons/reb-it@2x.jpg)
19 | 


--------------------------------------------------------------------------------
/experimental/curl.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "cURL"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 08-Feb-2019
  5 |     Home: http://ross-gill.com/page/REST_Protocol
  6 |     File: %curl.reb
  7 |     Version: 0.1.5
  8 |     Purpose: "Rebol wrapper for cURL command."
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: module
 11 |     Name: rgchris.curl
 12 |     Exports: [curl]
 13 |     History: [
 14 |         08-Feb-2019 0.1.5 "Ren-C compatibilities"
 15 |         04-Feb-2018 0.1.4 "Ren-C compatibilities"
 16 |         18-Jul-2017 0.1.3 "Initial Ren-C version"
 17 |         02-May-2013 0.1.2 "Use COLLECT; basic Auth support"
 18 |         21-Oct-2012 0.1.1 "Initial published version"
 19 |     ]
 20 |     Comment: ["cURL Home Page" http://curl.haxx.se/]
 21 | ]
 22 | 
 23 | curl: use [user-agent form-headers enquote][
 24 |     user-agent: unspaced ["Rebol/" uppercase/part form system/product 1 " " system/version]
 25 | 
 26 |     enquote: func [
 27 |         data [block! any-string!]
 28 |         /local mark
 29 |     ][
 30 |         mark: switch system/version/4 [3 [{"}] ("'")]
 31 |         unspaced compose [mark (data) mark]
 32 |     ]
 33 | 
 34 |     form-headers: func [headers [block! object!] /local out][
 35 |         collect [
 36 |             for-each [header value] switch type of headers [
 37 |                 block! [headers]
 38 |                 object! [body of headers]
 39 |             ][
 40 |                 if value [
 41 |                     keep unspaced [" -H " enquote [as text! header ": " value]]
 42 |                 ]
 43 |             ]
 44 |         ]
 45 |     ]
 46 | 
 47 |     curl: func [
 48 |         "Wrapper for the cURL shell function"
 49 |         url [url!] "URL to Retrieve"
 50 |         /method "Specify HTTP request method"
 51 |         verb [word! text! blank!] "HTTP request method"
 52 |         /send "Include request body"
 53 |         data [text! binary! file! blank!] "Request body"
 54 |         /header "Specify HTTP headers"
 55 |         headers [block! object! blank!] "HTTP headers"
 56 |         /as "Specify user agent"
 57 |         agent [text!] "User agent"
 58 |         /user "Provide User Credentials"
 59 |         name [text! blank!] "User Name"
 60 |         pass [text! blank!] "User Password"
 61 |         /full "Include HTTP headers in response"
 62 |         /binary "Receive response as binary"
 63 |         /follow "Follow HTTP redirects"
 64 |         /quiet "Return blank! on 4xx/5xx HTTP responses"
 65 |         /secure "Disallow 'insecure' SSL transactions"
 66 |         /into "Specify result string"
 67 |         out [text! binary! blank!] "String to contain result"
 68 |         /error "Specify error string"
 69 |         err [text! blank!] "String to contain error"
 70 |         /timeout "Specify a time limit"
 71 |         time [time! integer! blank!] "Time limit"
 72 |         /local command options code
 73 |     ][
 74 |         out: any [:out make binary! 0]
 75 |         err: any [:err make text! 0]
 76 | 
 77 |         options: unspaced collect [
 78 |             keep "-s"
 79 | 
 80 |             case/all [
 81 |                 full [keep "i"]
 82 |                 quiet [keep "f"]
 83 |                 not secure [keep "k"]
 84 |                 follow [keep "L"]
 85 | 
 86 |                 :verb [
 87 |                     keep " -X "
 88 |                     keep verb: uppercase form verb
 89 |                 ]
 90 | 
 91 |                 :time [
 92 |                     keep " -m "
 93 |                     keep to integer! time
 94 |                 ]
 95 | 
 96 |                 not send [data: _]
 97 | 
 98 |                 file? data [
 99 |                     keep reduce [" -d @" form data]
100 |                     data: _
101 |                 ]
102 | 
103 |                 data [
104 |                     either empty? data [
105 |                         data: _
106 |                     ][
107 |                         keep " -d @-"
108 |                         data: to binary! data
109 |                     ]
110 |                 ]
111 | 
112 |                 all [:name :pass][
113 |                     keep " -u "
114 |                     keep enquote [name ":" pass]
115 |                 ]
116 | 
117 |                 :headers [keep form-headers headers]
118 |             ]
119 | 
120 |             keep reduce [
121 |                 " -A " enquote any [:agent user-agent]
122 |             ]
123 |         ]
124 | 
125 |         command: spaced ["curl" options enquote url]
126 | 
127 |         code: call/shell/wait/input/output/error command data out err
128 | 
129 |         switch code [
130 |             0 18 [
131 |                 either binary [out][
132 |                     to text! out
133 |                 ]
134 |             ]
135 |             1 [
136 |                 if empty? trim/head/tail err [
137 |                     err: "Unsupported protocol. This build of curl has no support for this protocol."
138 |                 ]
139 |                 fail/where :err 'url
140 |             ]
141 |             2 [fail/where "Failed to initialize." 'url]
142 |             3 [fail/where "URL malformed. The syntax was not correct." 'url]
143 |             4 [fail/where "Feature not included in this cURL build." 'url]
144 |             6 [fail/where "Couldn't resolve host. The given remote host was not resolved." 'url]
145 |             7 [fail/where "Failed to connect to host." 'url]
146 |             22 [_]
147 |             28 [fail/where "Request timed out." 'url]
148 |             50 [fail/where "OS shell error." 'url]
149 |             52 [fail/where "The server didn't reply anything." 'url]
150 |             (
151 |                 code: spaced ["cURL Error Code" code trim/head/tail err]
152 |                 fail/where :code 'url
153 |             )
154 |         ]
155 |     ]
156 | ]
157 | 


--------------------------------------------------------------------------------
/experimental/rest.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 | 	Title: "Transaction-based HTTP(S) Protocol"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 5-Jun-2017
  5 | 	Home: http://ross-gill.com/page/REST_Protocol
  6 | 	File: %rest.reb
  7 | 	Version: 0.0.2
  8 | 	Purpose: {Minimal HTTP(S) scheme with elemental Request/Response model}
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	Type: module
 11 | 	Name: rgchris.rest
 12 | 	Needs: [
 13 | 		<webform> ; %../ren-c/altwebform.reb
 14 | 		<curl> ; %../experimental/curl.reb
 15 | 	]
 16 | 	Usage: [
 17 | 		read [
 18 | 			scheme: rest
 19 | 			url: http://www.ross-gill.com/
 20 | 		]
 21 | 
 22 | 		write [
 23 | 			scheme: rest
 24 | 			method: post
 25 | 			type: text/html
 26 | 			url: http://somewhere-to-write/target
 27 | 		][
 28 | 			some data
 29 | 		]
 30 | 	]
 31 | ]
 32 | 
 33 | use [prepare fetch transcribe][
 34 | 	prepare: use [
 35 | 		request-prototype header-prototype
 36 | 		oauth-credentials oauth-prototype
 37 | 		sign
 38 | 	][
 39 | 		request-prototype: make object! [
 40 | 			version: 1.1
 41 | 			action: headers: query: _
 42 | 			oauth: target: content: length: timeout: _
 43 | 			type: 'application/x-www-form-urlencoded
 44 | 		]
 45 | 
 46 | 		header-prototype: make object! [
 47 | 			Accept: "*/*"
 48 | 			Connection: "close"
 49 | 			User-Agent: rejoin ["Rebol/" system/product " " system/version]
 50 | 			Content-Length: Content-Type: Authorization: Range: _
 51 | 		]
 52 | 
 53 | 		oauth-credentials: make object! [
 54 | 			consumer-key: consumer-secret:
 55 | 			oauth-token: oauth-token-secret:
 56 | 			oauth-callback: _
 57 | 		]
 58 | 
 59 | 		oauth-prototype: make object! [
 60 | 			oauth_callback: _
 61 | 			oauth_consumer_key: _
 62 | 			oauth_token: oauth_nonce: _
 63 | 			oauth_signature_method: "HMAC-SHA1"
 64 | 			oauth_timestamp: _
 65 | 			oauth_version: 1.0
 66 | 			oauth_verifier: oauth_signature: _
 67 | 		]
 68 | 
 69 | 		sign: func [request [object!] /local header params timestamp out][
 70 | 			out: make string! 0
 71 | 			timestamp: now/precise
 72 | 
 73 | 			header: make oauth-prototype [
 74 | 				oauth_consumer_key: request/oauth/consumer-key
 75 | 				oauth_token: request/oauth/oauth-token
 76 | 				oauth_callback: request/oauth/oauth-callback
 77 | 				oauth_nonce: enbase/base checksum/secure to binary! unspaced [now/precise oauth_consumer_key] 64
 78 | 				oauth_timestamp: form any [
 79 | 					attempt [to integer! difference timestamp 1-Jan-1970/0:0:0]
 80 | 					timestamp - 1-Jan-1970/0:0:0 * 86400.0
 81 | 				]
 82 | 				clear find/last oauth_timestamp "."
 83 | 			]
 84 | 
 85 | 			params: make header any [request/content []]
 86 | 			params: sort/skip body-of params 2
 87 | 
 88 | 			header/oauth_signature: enbase/base checksum/secure/key to binary! unspaced [
 89 | 				uppercase form request/action "&" url-encode form request/url "&"
 90 | 				url-encode replace/all to-webform params "+" "%20"
 91 | 			] to binary! unspaced [
 92 | 				request/oauth/consumer-secret "&" any [request/oauth/oauth-token-secret ""]
 93 | 			] 64
 94 | 
 95 | 			foreach [name value] body-of header [
 96 | 				if value [
 97 | 					repend out [", " spelling-of name {="} url-encode form value {"}]
 98 | 				]
 99 | 			]
100 | 
101 | 			switch request/action [
102 | 				"GET" [
103 | 					if request/content [
104 | 						request/url: join-of request/url to-webform/prefix request/content
105 | 						request/content: _
106 | 					]
107 | 				]
108 | 
109 | 				"POST" "PUT" [
110 | 					request/content: to-webform any [request/content []]
111 | 					request/headers/Content-Type: "application/x-www-form-urlencoded"
112 | 				]
113 | 			]
114 | 
115 | 			request/headers/Authorization: join-of "OAuth" next out
116 | 		]
117 | 
118 | 		prepare: func [port [port!] /with content /local request url][
119 | 			port/locals/request: request: make request-prototype compose port/locals/request
120 | 			request/content: any [:content _]
121 | 
122 | 			request/action: uppercase form any [
123 | 				get in request 'action
124 | 				either request/content ["POST"]["GET"]
125 | 			]
126 | 
127 | 			request/headers: make header-prototype any [request/headers []]
128 | 
129 | 			either request/oauth [
130 | 				request/oauth: make oauth-credentials request/oauth
131 | 				sign request
132 | 			][
133 | 				request/headers/Authorization: any [
134 | 					request/headers/authorization
135 | 					if all [port/spec/user port/spec/pass][
136 | 						join-of "Basic " enbase join-of port/spec/user [#":" port/spec/pass]
137 | 					]
138 | 				]
139 | 			]
140 | 
141 | 			; if port/state/index > 0 [
142 | 			; 	request/version: 1.1
143 | 			; 	request/headers/Range: rejoin ["bytes=" port/state/index "-"]
144 | 			; ]
145 | 
146 | 			case/all [
147 | 				block? request/content [
148 | 					request/content: to-webform request/content
149 | 					request/headers/Content-Type: "application/x-www-form-urlencoded"
150 | 				]
151 | 
152 | 				string? request/content [
153 | 					request/length: length? request/content
154 | 					request/headers/Content-Length: length? request/content
155 | 					request/headers/Content-Type: request/type
156 | 				]
157 | 			]
158 | 
159 | 			port
160 | 		]
161 | 	]
162 | 
163 | 	fetch: func [port [port!]][
164 | 		port/locals/request
165 | 		curl/full/method/header/send/timeout/into ; url action headers content response
166 | 			port/locals/request/url
167 | 			port/locals/request/action
168 | 			port/locals/request/headers
169 | 			port/locals/request/content
170 | 			port/locals/request/timeout
171 | 			port/locals/response
172 | 	]
173 | 
174 | 	transcribe: use [
175 | 		response-code space header-feed header-name header-part
176 | 		response-prototype header-prototype
177 | 	][
178 | 		response-code: use [digit][
179 | 			digit: charset "0123456789"
180 | 			[3 digit]
181 | 		]
182 | 
183 | 		header-feed: [newline | crlf]
184 | 
185 | 		header-part: use [chars][
186 | 			chars: complement charset [#"^(00)" - #"^(1F)"]
187 | 			[some chars any [header-feed some " " some chars]]
188 | 		]
189 | 
190 | 		header-name: use [chars][
191 | 			chars: charset ["_-0123456789" #"a" - #"z" #"A" - #"Z"]
192 | 			[some chars]
193 | 		]
194 | 
195 | 		space: use [space][
196 | 			space: charset " ^-"
197 | 			[some space]
198 | 		]
199 | 
200 | 		response-prototype: context [
201 | 			status: message: http-headers: headers: content: binary: type: length: _
202 | 		]
203 | 
204 | 		header-prototype: context [
205 | 			Date: Server: Last-Modified: Accept-Ranges: Content-Encoding: Content-Type:
206 | 			Content-Length: Location: Expires: Referer: Connection: Authorization: _
207 | 		]
208 | 
209 | 		transcribe: func [port [port!] /local response name value pos][
210 | 			port/locals/response: response: make response-prototype [
211 | 				unless parse port/locals/response [
212 | 					"HTTP/" [
213 | 						"1." ["0" | "1"] space copy status response-code
214 | 						space copy message header-part
215 | 						|
216 | 						"2" space copy status response-code (message: _)
217 | 						opt [space opt [copy message header-part]]
218 | 					] header-feed
219 | 					(
220 | 						status: load status
221 | 						headers: make block! []
222 | 						message: either empty? any [message ""][_][
223 | 							to string! message
224 | 						]
225 | 					)
226 | 					some [
227 | 						copy name header-name #":" any #" "
228 | 						copy value header-part header-feed
229 | 						(repend headers [to set-word! to string! name to string! value])
230 | 					]
231 | 					header-feed content: to end (
232 | 						content: to string! binary: copy content
233 | 					)
234 | 					| pos: fail
235 | 				][
236 | 					do make error! "Could Not Parse Response"
237 | 				]
238 | 
239 | 				headers: make header-prototype http-headers: new-line/skip headers true 2
240 | 
241 | 				type: all [
242 | 					path? type: attempt [load headers/Content-Type]
243 | 					type
244 | 				]
245 | 
246 | 				length: any [attempt [headers/Content-Length: to integer! headers/Content-Length] 0]
247 | 			]
248 | 		]
249 | 	]
250 | 
251 | 	sys/make-scheme [
252 | 		Title: "Service-oriented HTTP Protocol"
253 | 		Name: 'rest
254 | 
255 | 		Spec: make object! [title: url: ref: user: pass: _]
256 | 
257 | 		Init: func [port [port!] /local url][
258 | 			port/locals: make object! [
259 | 				request: case/all [
260 | 					url? port/spec/ref [
261 | 						port/spec/ref: compose [
262 | 							url: (to url! replace form port/spec/ref rest:// https://)
263 | 						]
264 | 					]
265 | 
266 | 					block? port/spec/ref [
267 | 						unless url: case/all [
268 | 							get-word? url: pick find compose port/spec/ref quote url: 2 [
269 | 								url: get :url
270 | 							]
271 | 
272 | 							url? url [url]
273 | 						][
274 | 							return make error! "REST spec needs a URL"
275 | 						]
276 | 
277 | 						unless parse url ["http" opt "s" "://" to end] [
278 | 							return make error! "REST only supports HTTP(S) URLs"
279 | 						]
280 | 
281 | 						port/spec/ref
282 | 					]
283 | 				]
284 | 
285 | 				response: make binary! 0
286 | 			]
287 | 
288 | 			; do make error! "Not Finished Yet."
289 | 		]
290 | 
291 | 		Actor: [
292 | 			read: func [port [port!]][
293 | 				prepare port
294 | 				fetch port
295 | 				transcribe port
296 | 			]
297 | 
298 | 			write: func [port [port!] content [any-value!]][
299 | 				probe content
300 | 				prepare/with port :content
301 | 				fetch port
302 | 				transcribe port
303 | 			]
304 | 		]
305 | 	]
306 | ]
307 | 


--------------------------------------------------------------------------------
/experimental/send.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 | 	Title: "Send for Ren-C"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 18-Oct-2017
  5 | 	Home: https://github.com/rgchris/Scripts
  6 | 	File: %send.reb
  7 | 	Version: 0.2.0
  8 | 	Type: module
  9 | 	Name: rgchris.send
 10 | 	Rights: http://opensource.org/licenses/Apache-2.0
 11 | 	Purpose: "Build and send email messages via SMTP"
 12 | 	Exports: [send]
 13 | 	Needs: [<smtp>]
 14 | 	History: [
 15 | 		18-Oct-2017 0.2.0 "First Version for Ren-C"
 16 | 	]
 17 | 	Usage: [
 18 | 		; note: use SET-NET to establish the default SMTP credentials
 19 | 		send/header/attach luke@rebol.info "Message From Send!" "Message Body" [
 20 | 			BCC: han@rebol.info
 21 | 			Reply-To: replies@rebol.info
 22 | 		][
 23 | 			%attachment.bin #{DECAFBAD}
 24 | 		]
 25 | 	]
 26 | ]
 27 | 
 28 | extend system/standard 'email make object! [
 29 | 	To: CC: BCC: From: Reply-To: Date: Subject:
 30 | 	Return-Path: Organization: Message-Id: Comment: _
 31 | 	X-Rebol: rejoin [
 32 | 		"Rebol/" system/product " " system/version " http://rebol.info"
 33 | 	]
 34 | 	MIME-Version: Content-Type: Content: _
 35 | ]
 36 | 
 37 | send: use [default-mailbox to-idate to-iheader build-attach-body][
 38 | 	default-mailbox: [
 39 | 		scheme: 'smtp
 40 | 		host: system/user/identity/smtp
 41 | 		user: system/user/identity/esmtp-user
 42 | 		pass: system/user/identity/esmtp-pass
 43 | 		ehlo: system/user/identity/fqdn
 44 | 	]
 45 | 
 46 | 	to-idate: use [to-itime][
 47 | 		to-itime: func [
 48 | 			{Returns a standard internet time string (two digits for each segment)} 
 49 | 			time [time! number! block! blank!] 
 50 | 			/local pad
 51 | 		][
 52 | 			time: make time! time 
 53 | 			pad: func [n][head insert/dup n: form n #"0" 2 - length? n] 
 54 | 			unspaced [
 55 | 				pad time/hour ":" pad time/minute ":" 
 56 | 				pad round/down time/second
 57 | 			]
 58 | 		]
 59 | 
 60 | 		func [
 61 | 			"Returns a standard Internet date string." 
 62 | 			date [date!] 
 63 | 			/local str
 64 | 		][
 65 | 			str: form date/zone 
 66 | 			remove find str ":" 
 67 | 			if (first str) <> #"-" [insert str #"+"] 
 68 | 			if (length? str) <= 4 [insert next str #"0"] 
 69 | 			spaced [
 70 | 				pick ["Mon," "Tue," "Wed," "Thu," "Fri," "Sat," "Sun,"] date/weekday 
 71 | 				date/day 
 72 | 				pick ["Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] date/month 
 73 | 				date/year 
 74 | 				to-itime any [date/time 0:00] 
 75 | 				str
 76 | 			]
 77 | 		]
 78 | 	]
 79 | 
 80 | 	to-iheader: func [
 81 | 		{Export an object to something that looks like a header} 
 82 | 		object [object!] "Object to export"
 83 | 	][
 84 | 		unspaced collect [
 85 | 			foreach word words-of object [
 86 | 				unless any [
 87 | 					void? get word
 88 | 					blank? get word
 89 | 				][
 90 | 					keep reduce [
 91 | 						form word ": " get word newline
 92 | 					]
 93 | 				]
 94 | 			]
 95 | 		]
 96 | 	]
 97 | 
 98 | 	build-attach-body: use [make-mime-header break-lines make-boundary][
 99 | 		break-lines: func [data [string!] /at size [integer!]] [
100 | 			size: any [:size 72]
101 | 
102 | 			collect [
103 | 				while [not tail? data] [
104 | 					keep copy/part data size #"^/"
105 | 					data: skip data size
106 | 				]
107 | 			]
108 | 		]
109 | 
110 | 		make-mime-header: func [file][
111 | 			to-iheader context [
112 | 				Content-Type: join-of {application/octet-stream; name="} [file {"}]
113 | 				Content-Transfer-Encoding: "base64"
114 | 				Content-Disposition: join-of {attachment; filename="} [file {"^M^/}]
115 | 			]
116 | 		]
117 | 
118 | 		make-boundary: does [
119 | 			unspaced [
120 | 				"--__Rebol--" form system/product "--" system/version "--"
121 | 				enbase/base checksum/secure to binary! form now/precise 16 "__"
122 | 			]
123 | 		]
124 | 
125 | 		build-attach-body: func [
126 | 			"Return an email body with attached files."
127 | 			headers [object!] "The message header"
128 | 			body [string!] "The message body"
129 | 			files [block!] {List of files to send [%file1.r [%file2.r "data"]]}
130 | 			/local file content boundary value
131 | 		][
132 | 			boundary: make-boundary
133 | 
134 | 			insert body reduce [boundary "^/Content-Type: " headers/Content-Type "^M^/^/"]
135 | 
136 | 			headers/MIME-Version: "1.0"
137 | 			headers/Content-Type: join-of "multipart/mixed; boundary=" [{"} skip boundary 2 {"}]
138 | 
139 | 			head insert tail body unspaced collect [
140 | 				parse files [
141 | 					some [
142 | 						set file file! [
143 | 							set value [string! | binary!]
144 | 							| (value: read/binary file)
145 | 						] (
146 | 							keep "^/^/"
147 | 							keep boundary
148 | 							keep "^/"
149 | 							keep make-mime-header any [
150 | 								find/last/tail file #"/"
151 | 								file
152 | 							]
153 | 							keep break-lines enbase value
154 | 						)
155 | 					]
156 | 				]
157 | 
158 | 				keep "^/^/"
159 | 				keep boundary
160 | 				keep "--^/"
161 | 			]
162 | 		]
163 | 	]
164 | 
165 | 	send: func [
166 | 		{Send a message to an address/some addresses}
167 | 		address [email! block!] "An address or block of addresses"
168 | 		subject [string!] "Subject of message"
169 | 		message [string!] "Text of message"
170 | 		/header "Use a customized header"
171 | 		headers [block! object!] "Customized header"
172 | 		/attach "Append attachments"
173 | 		files [file! block!] "The filename(s)/content to attach to the message"
174 | 		/into "Use an alternate SMTP mailbox"
175 | 		mailbox [block! port!] "Mailbox or mailbox spec"
176 | 		/local from
177 | 	][
178 | 		; bases any custom object on SYSTEM/STANDARD/EMAIL
179 | 		headers: make system/standard/email any [:headers []]
180 | 
181 | 		; RECIPIENTS
182 | 		either blank? from: any [
183 | 			headers/from
184 | 			headers/from: system/user/identity/email
185 | 		][
186 | 			do make error! "SEND: Email header not set: no from address"
187 | 		][
188 | 			if all [
189 | 				string? system/user/name
190 | 				not empty? system/user/name
191 | 			][
192 | 				headers/from: rejoin [system/user/name " <" from ">"]
193 | 			]
194 | 		]
195 | 
196 | 		address: collect [
197 | 			foreach recipient compose [(address)][
198 | 				if email? recipient [keep recipient]
199 | 			]
200 | 		]
201 | 
202 | 		if find [email! block!] to word! type-of headers/To [
203 | 			remove-each recipient headers/To: unique compose [(headers/To)][
204 | 				either email? recipient [
205 | 					append address recipient
206 | 					false ; don't remove
207 | 				][
208 | 					true ; remove
209 | 				]
210 | 			]
211 | 		]
212 | 
213 | 		headers/To: either empty? address [_][
214 | 			delimit address: unique address ", "
215 | 		]
216 | 
217 | 		headers/CC: if find [email! block!] to word! type-of headers/CC [
218 | 			remove-each recipient headers/CC: unique compose [(headers/CC)][
219 | 				either email? recipient [
220 | 					append address recipient
221 | 					false ; don't remove
222 | 				][
223 | 					true ; remove
224 | 				]
225 | 			]
226 | 
227 | 			unless empty? headers/CC [delimit headers/CC ", "]
228 | 		]
229 | 
230 | 		; notes on BCC here: http://stackoverflow.com/a/26611044/292969
231 | 		if find [email! block!] to word! type-of headers/BCC [
232 | 			remove-each recipient headers/BCC: unique compose [(headers/BCC)][
233 | 				either email? recipient [
234 | 					append address recipient
235 | 					false ; don't remove
236 | 				][
237 | 					true ; remove
238 | 				]
239 | 			]
240 | 		]
241 | 
242 | 		headers/BCC: _ ; BCC header is not sent to the server.
243 | 
244 | 		if empty? address: unique address [
245 | 			do make error! "SEND: No recipients specified."
246 | 		]
247 | 
248 | 		; HEADERS
249 | 		headers/Subject: subject
250 | 
251 | 		if blank? headers/Date [
252 | 			headers/Date: to-idate now
253 | 		]
254 | 
255 | 		case [
256 | 			blank? headers/Content-Type [
257 | 				headers/Content-Type: "text/plain; charset=utf-8"
258 | 			]
259 | 
260 | 			parse headers/Content-Type ["text/" ["plain" | "html"]][
261 | 				headers/Content-Type: join-of headers/Content-Type "; charset=UTF-8"
262 | 			]
263 | 		]
264 | 
265 | 		; CONTENT
266 | 		message: copy message
267 | 
268 | 		if attach [
269 | 			remove-each part files: flatten compose [(files)][
270 | 				not find [file! string! binary!] to word! type-of part
271 | 			]
272 | 
273 | 			either parse files [
274 | 				any [file! opt [string! | binary!]]
275 | 			][
276 | 				message: build-attach-body headers message files
277 | 			][
278 | 				do make error! "SEND: Invalid Attachment Spec"
279 | 			]
280 | 		]
281 | 
282 | 		message: reduce [
283 | 			quote from: from
284 | 			quote to: address
285 | 			quote message: head insert insert tail to-iheader headers newline message
286 | 		]
287 | 
288 | 		; SMTP expects insert of [email! into [some email!] string!] where STRING! is a fully
289 | 		; formed email message with headers.
290 | 		write either void? :mailbox [default-mailbox][mailbox] message
291 | 	]
292 | ]
293 | 


--------------------------------------------------------------------------------
/makedoc/asciidoc.r:
--------------------------------------------------------------------------------
  1 | REBOL [
  2 | 	Title: "AsciiDoc Emitter"
  3 | 	Type: 'emitter
  4 | 	License: %license.r
  5 | ]
  6 | 
  7 | with: func [
  8 | 	"Binds and evaluates a block to a specified context."
  9 | 	object [any-word! object! port!] "Target context."
 10 | 	block [any-block!] "Block to be bound."
 11 | 	/only "Returns the block unevaluated."
 12 | ][
 13 | 	block: bind block object
 14 | 	either only [block] :block
 15 | ]
 16 | 
 17 | else: :true
 18 | press: :rejoin
 19 | envelop: func [
 20 | 	"Returns a block, encloses any value not already of any-block type."
 21 | 	values [any-type!]
 22 | ][
 23 | 	case [
 24 | 		any-block? values [values]
 25 | 		none? values [make block! 0]
 26 | 		else [reduce [values]]
 27 | 	]
 28 | ]
 29 | 
 30 | 
 31 | ;-- Helpers
 32 | last-feed: none
 33 | feed: does [last-feed: emit newline]
 34 | 
 35 | emit-boilerplate: func [boilerplate [string!] /local lines name value][
 36 | 	lines: parse/all boilerplate "^/"
 37 | 	foreach line lines [
 38 | 		emit-inline reduce either parse/all line [copy name to ": " 2 skip copy value to end][
 39 | 			[":" name ": " value]
 40 | 		][
 41 | 			[line]
 42 | 		] feed
 43 | 	]
 44 | ]
 45 | 
 46 | open-table: func [position /local count][
 47 | 	count: 0
 48 | 	parse position [
 49 | 		'table-in skip
 50 | 		some [
 51 | 			  'column skip
 52 | 			| 'table-row to end
 53 | 			| skip skip (count: count + 1)
 54 | 		]
 55 | 	]
 56 | 	rejoin [{[grid="rows",options="header",cols=} count "]"]
 57 | ]
 58 | 
 59 | indentation: 1
 60 | indent: func [para /local tab][
 61 | 	tab: head insert/dup next copy "^/" " " indentation * 4
 62 | 	replace/all compose [(next tab) (para)] <br /> tab 
 63 | ]
 64 | 
 65 | emit-smarttag: func [spec [block!] /local tag errs rel][
 66 | 	errs: []
 67 | 	unless switch take tag: copy spec [
 68 | 		link [
 69 | 			if tag: match tag [
 70 | 				href: file! | url! | email!
 71 | 				anchor: opt string!
 72 | 				rel: opt get-word! is within [:flow :nofollow]
 73 | 			][
 74 | 				with tag [
 75 | 					anchor: any [anchor form href]
 76 | 					if email? href [href: join #[url! "mailto:"] href]
 77 | 					emit ["<a" to-attr href to-attr rel ">" sanitize anchor </a>]
 78 | 				]
 79 | 			]
 80 | 		]
 81 | 		wiki [
 82 | 			if tag: match tag [
 83 | 				href: string!
 84 | 				anchor: opt string!
 85 | 			][
 86 | 				with tag [
 87 | 					anchor: any [anchor href]
 88 | 					href: url-encode/wiki href
 89 | 					emit ["<a" to-attr href ">" sanitize anchor </a>]
 90 | 				]
 91 | 			]
 92 | 		]
 93 | 		img image icon [
 94 | 			either tag: match/report-to tag [
 95 | 				src: file! | url! else "Image Tag Needs Valid Source"
 96 | 				alt: string! else "Image tag requires ALT text"
 97 | 				size: opt pair!
 98 | 			] errs [
 99 | 				use [width height] with/only tag [
100 | 					width: all [size/x > -1 size/x]
101 | 					height: all [size/y > -1 size/y]
102 | 					emit ["<img" to-attr src to-attr width to-attr height to-attr alt { class="icon" />}]
103 | 				]
104 | 			][
105 | 				foreach [key reasons] errs [
106 | 					foreach reason reasons [
107 | 						emit ["[" sanitize reason "]"]
108 | 					]
109 | 				]
110 | 			]
111 | 		]
112 | 	][
113 | 		emit {<span class="attention">!Unable to parse tag!</span>}
114 | 	]
115 | ]
116 | 
117 | emit-image: func [spec [block!] /local out image][
118 | 	either image: match spec [
119 | 		src: file! | url!
120 | 		size: opt pair!
121 | 		alt: string!
122 | 		title: opt string!
123 | 		href: opt file! | url!
124 | 	][
125 | 		out: copy []
126 | 		with image [
127 | 			src: to-attr src
128 | 			alt: to-attr alt
129 | 			title: to-attr title
130 | 			size: any [size -1x-1]
131 | 			width: either 0 > width: size/x [""][to-attr width]
132 | 			height: either 0 > height: size/y [""][to-attr height]
133 | 			repend out ["<img" width height src alt title " />"]
134 | 			if href [
135 | 				insert append out </a> reduce ["<a" to-attr href ">"]
136 | 			]
137 | 		]
138 | 
139 | 		emit [{<div class="img">^/} press out {^/</div>}]
140 | 	][
141 | 		raise ["Invalid Image Spec #" sanitize mold spec]
142 | 	]
143 | ]
144 | 
145 | emit-video: func [spec [block!] /youtube /vimeo /local video][
146 | 	unless any [youtube vimeo][raise "Invalid Video Request" exit]
147 | 
148 | 	either video: match spec [
149 | 		id: issue!
150 | 		ratio: opt pair! is within [16x9 4x3]
151 | 	][
152 | 		video/id: join case [
153 | 			youtube [https://youtube.com/embed/]
154 | 			vimeo [http://player.vimeo.com/video/]
155 | 		] sanitize video/id
156 | 		emit [{<div class="tube">^/<iframe type="text/html" src="} video/id {"></iframe>^/</div>}]
157 | 	][
158 | 		raise ["Invalid Video Spec #" sanitize mold spec]
159 | 	]
160 | ]
161 | 
162 | ;-- Paragraph States
163 | initial: [
164 | 	options: ()
165 | 	para: (
166 | 		emit-inline data
167 | 		emit head insert/dup next copy "^/^/" "=" length? out
168 | 	) boilerplate (feed emit "////^/; done")
169 | 	default: continue boilerplate
170 | ]
171 | 
172 | boilerplate: [
173 | 	code: (emit-boilerplate data) normal
174 | 	default: continue normal
175 | ]
176 | 
177 | in-block: normal: [
178 | 	para: (feed emit-inline data feed)
179 | 	sect1: (feed emit "== " emit-inline data feed)
180 | 	sect2: (feed emit "=== " emit-inline data feed)
181 | 	sect3: (feed emit "==== " emit-inline data feed)
182 | 	sect4: (feed emit "===== " emit-inline data feed)
183 | 	bullet: (feed emit "* " emit-inline data feed)
184 | 	bullet2: (feed emit "** " emit-inline data feed)
185 | 	bullet3: (feed emit "*** " emit-inline data feed)
186 | 	enum: (feed emit ". " emit-inline data feed)
187 | 	enum2: (feed emit ".. " emit-inline data feed)
188 | 	enum3: (feed emit "... " emit-inline data feed)
189 | 	code: (feed emit "----" feed emit-inline envelop detab data feed emit "----" feed)
190 | 	define-term: (feed emit-inline data emit "::") in-definition
191 | 	table-in: (feed emit open-table position feed emit "|===") in-table (feed emit "|===" feed)
192 | 	note-in: (if data [feed emit "." emit-inline data] feed emit "[NOTE]" feed emit "========") in-note (emit "========" feed)
193 | 	default: (emit form word)
194 | ]
195 | 
196 | in-definition: [
197 | 	; define-term: (feed emit <dt> emit-inline data emit </dt>)
198 | 	define-desc: (feed emit-inline indent data feed)
199 | 	default: continue return
200 | ]
201 | 
202 | in-table: [
203 | 	table-row: (feed) column: ()
204 | 	para: (feed emit "| " emit-inline data)
205 | 	default: (feed emit ["| `" uppercase form word "` WHAT SHOULD I DO HERE???"])
206 | 	table-out: return
207 | ]
208 | 
209 | media: [
210 | 	youtube: (feed emit-video/youtube data) return
211 | 	vimeo: (feed emit-video/vimeo data) return
212 | 	image: (feed emit-image data) return
213 | ]
214 | 
215 | in-note: inherit normal [
216 | 	note-out: return
217 | ]
218 | 
219 | 
220 | ;-- Inline States
221 | inline: [
222 | 	<p> ()
223 | 	default: continue paragraph
224 | ]
225 | 
226 | paragraph: [
227 | 	:string! (emit value)
228 | 	<b> (emit "*") in-bold (emit "*")
229 | 	<i> (emit "_") in-italic (emit "_")
230 | 	<q> (emit "``") in-qte (emit "''")
231 | 	<code> <var> (emit "`") in-code (emit "`")
232 | 	<br/> <br /> (feed)
233 | 	:integer! :char! (emit ["&#" to-integer value ";"])
234 | 	</> ()
235 | 	; :block! (emit-smarttag value)
236 | 	default: "[???]"
237 | ]
238 | 
239 | in-bold: inherit paragraph [</b> return </> continue return]
240 | 
241 | in-italic: inherit paragraph [</i> return </> continue return]
242 | 
243 | in-qte: inherit paragraph [</q> return </> continue return]
244 | 
245 | in-code: inherit paragraph [</var> </code> return </> continue return]
246 | 


--------------------------------------------------------------------------------
/makedoc/document.r:
--------------------------------------------------------------------------------
 1 | REBOL [
 2 | 	Title: "Make-Doc Text Dialect Parser"
 3 | 	Author: ["Carl Sassenrath" "Christopher Ross-Gill"]
 4 | 	Type: 'document
 5 | ]
 6 | 
 7 | some [ ;here: (print here)
 8 | 	newline
 9 | 
10 | 	;-- Headers / End of file
11 | 	| "===" line (emit sect1 text)
12 | 	| "---" line (emit sect2 text)
13 | 	| ["+++" | "-3-"] line (emit sect3 text)
14 | 	| ["..." | "-4-"] line (emit sect4 text)
15 | 	| "###" to end (emit end none)
16 | 
17 | 	;-- Special common notations:
18 | 	| "*" [
19 | 		  ">>" lines (emit bullet3 para)
20 | 		| ">" lines (emit bullet2 para)
21 | 		| lines (emit bullet para)
22 | 	]
23 | 	| "#" [
24 | 		  ">>" lines (emit enum3 para)
25 | 		| ">" lines (emit enum2 para)
26 | 		| lines (emit enum para)
27 | 	]
28 | 	| #":" define (
29 | 		emit define-term text
30 | 		emit define-desc para
31 | 	)
32 | 
33 | 	;-- Special sections:
34 | 	| #"\" [
35 | 		  "in" term (emit indent-in text)
36 | 		| "note" line (emit note-in text)
37 | 		| "define" line (emit define-in text)
38 | 		| "quote" block (emit quote-in values)
39 | 		| ["box" | "section" | "column"] block (emit box-in values)
40 | 		| "aside" term (emit boxout-in none)
41 | 		| "table" line (emit table-in text)
42 | 		| "group" term (emit group-in none)
43 | 		| "pullquote" term (emit pullquote-in none)
44 | 		| "list" block (emit list-in values)
45 | 		| "figure" term (emit figure-in none)
46 | 		| "sidebar" term (emit sidebar-in none)
47 | 	]
48 | 
49 | 	| #"/" [
50 | 		  "in" term (emit indent-out none)
51 | 		| "note" term (emit note-out none)
52 | 		| "define" term (emit define-out none)
53 | 		| "quote" [line (emit quote-out text) | term (emit quote-out none)]
54 | 		| ["box" | "section" | "column"] term (emit box-out none)
55 | 		| "aside" term (emit boxout-out none)
56 | 		| "table" term (emit table-out none)
57 | 		| "group" term (emit group-out none)
58 | 		| "pullquote" term (emit pullquote-out none)
59 | 		| "list" term (emit list-out none)
60 | 		| "figure" term (emit figure-out none)
61 | 		| "sidebar" term (emit sidebar-out none)
62 | 	]
63 | 
64 | 	;-- Commands:
65 | 	| #"=" [
66 | 		  "caption" lines (emit caption para)
67 | 		| "row" term (emit table-row none)
68 | 		| "image" block (emit image values)
69 | 		| "youtube" block (emit youtube values)
70 | 		| "vimeo" block (emit vimeo values)
71 | 		| "icon" block (emit icon values)
72 | 		| "url" block (emit url values)
73 | 		| "options" block (append options values)
74 | 		| ">" line (emit brief text)
75 | 		| ["item" | "next"] term (emit list-item none)
76 | 		| "place" opt "s" commas (emit place values)
77 | 		| "topic" opt "s" commas (emit topics values)
78 | 		| ["break" | "hr"] term (emit break none)
79 | 	]
80 | 
81 | 	;-- URLs:
82 | 	| url-start [
83 | 		  "instagram.com" url-block (emit instagram values)
84 | 		| ["youtube.com" | "youtu.be"] url-block (emit youtube values)
85 | 		| "vimeo.com" url-block (emit vimeo values)
86 | 		| "flickr.com" url-block (emit flickr values)
87 | 	]
88 | 
89 | 	;--Defaults:
90 | 	| ";" lines  ; comment
91 | 	| example (emit/verbatim code para)
92 | 	| paragraph (emit para para)
93 | 	| skip
94 | ]


--------------------------------------------------------------------------------
/makedoc/paragraph.r:
--------------------------------------------------------------------------------
 1 | REBOL [
 2 | 	Title: "Scan Para"
 3 | 	Date: 16-Feb-2009
 4 | 	Author: "Christopher Ross-Gill"
 5 | 	Type: 'paragraph
 6 | ]
 7 | 
 8 | not-in-word any [
 9 | 	  some space (emit copy " ") not-in-word
10 | 	| copy text some alphanum (emit text) in-word
11 | 	| newline (emit <br />) not-in-word
12 | 	| #"=" [
13 | 		  block (emit values) in-word
14 | 		; | string (emit values) in-word
15 | 		| copy char number "." (
16 | 			char: load char all [char > 31 char < 65536 emit char]
17 | 		) in-word
18 | 		| "b " (emit <b>)
19 | 		| "b." (emit </b>)
20 | 		| "i " (emit <i>)
21 | 		| "i." (emit </i>)
22 | 		; | "d " (emit <dfn>)
23 | 		; | "d." (emit </dfn>)
24 | 		| "q " (emit <q>)
25 | 		| "q." (emit </q>)
26 | 		| "x " (emit <del>)
27 | 		| "x." (emit </del>)
28 | 		| "w " (emit <var>)
29 | 		| "w." (emit </var>)
30 | 		| "n " (emit <ins>)
31 | 		| "n." (emit </ins>)
32 | 		| "h " (emit <ins>)
33 | 		| "h." (emit </ins>)
34 | 		| "c " (emit <cite>)
35 | 		| "c." (emit </cite>)
36 | 		| "." (emit </>)
37 | 	]
38 | 	| #"(" [
39 | 		  "c)" (emit 169)
40 | 		| "r)" (emit 174)
41 | 		| "o)" (emit 176)
42 | 		| "tm)" (emit 8482)
43 | 		| "e)" (emit 8364)
44 | 	] in-word
45 | 	| #"[" copy char number "]" (emit reduce ['link to-issue char])
46 | 	| #"[" (emit <sb>)
47 | 	| "]" opt [paren (emit values) | (emit </sb>)] in-word
48 | 	; | #"<" ["i>" (emit <i>) | "/i>" (emit </i>) | "b>" (emit <b>) | "/b>" (emit </b>)]
49 | 	| #"<" (emit #"<") | #">" (emit #">") | #"&" (emit #"&")
50 | 	; | #"~" (emit/after <code> </code>)
51 | 	; | #"*" (emit/after <b> </b>)
52 | 	| #"`" (emit/after <code> </code>) in-word
53 | 	| #"'" (emit/after <apos> </apos>) in-word
54 | 	| #"^"" (emit/after <quot> </quot>) in-word
55 | 	| #"." ".." (emit 8230) in-word
56 | 	| #"-" ["--" (emit 8212) | "-" (emit 8211)] in-word
57 | 	| "\" copy char ["\" | "(" | "=" | "[" | "^"" | "'" | "." | "-"] (emit to-char char)
58 | 	| copy char ascii (emit char) in-word
59 | 	| copy char ucs (emit to integer! char/1) in-word
60 | 	| copy char utf-8 (emit get-ucs-code char) in-word
61 | 	| extended (emit "[???]")
62 | 	| skip
63 | ]


--------------------------------------------------------------------------------
/makedoc/s5.rsp:
--------------------------------------------------------------------------------
 1 | <!DOCTYPE html>
 2 | <html>
 3 | <head>
 4 | <title><%== document/title %></title>
 5 | <meta charset="utf-8"/>
 6 | <!-- metadata -->
 7 | <!-- configuration parameters -->
 8 | <meta name="defaultView" content="slideshow" />
 9 | <meta name="controlVis" content="hidden" />
10 | <!-- style sheet links -->
11 | <link rel="stylesheet" href="http://reb4.me/s/s5md.css" media="projection" id="slideProj" />
12 | <link rel="stylesheet" href="http://reb4.me/s/s5/outline.css" media="screen" id="outlineStyle" />
13 | <link rel="stylesheet" href="http://reb4.me/s/s5/print.css" media="print" id="slidePrint" />
14 | <link rel="stylesheet" href="http://reb4.me/s/s5/opera.css" media="projection" id="operaFix" />
15 | <!-- S5 JS -->
16 | <script src="http://reb4.me/s/s5/slides.js" type="text/javascript"></script>
17 | </head>
18 | <body>
19 | 
20 | <div class="layout">
21 | 	<div id="logo"><img src="http://reb4.me/x/forklogo-20130615-174319.png" alt="Rebol" width="120" height="100" title="Rebol" /></div>
22 | 	<div id="controls"><!-- DO NOT EDIT --></div>
23 | 	<div id="currentSlide"><!-- DO NOT EDIT --></div>
24 | 	<div id="header"></div>
25 | 	<div id="footer">
26 | 		<h1><span>S5 Slides by Make Doc</span></h1>
27 | 	</div>
28 | </div>
29 | 
30 | <%= document/render %>
31 | 
32 | </body>
33 | </html>
34 | 


--------------------------------------------------------------------------------
/r3-alpha/altjson.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "JSON Parser for Rebol 3"
  3 |     Date: 18-Sep-2015
  4 |     Author: "Christopher Ross-Gill"
  5 |     Home: http://www.ross-gill.com/page/JSON_and_Rebol
  6 |     File: %altjson.r3
  7 |     Version: 0.3.6
  8 |     Purpose: "Convert a Rebol block to a JSON string"
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 | 
 11 |     Type: module
 12 |     Name: rgchris.altjson
 13 |     Exports: [
 14 |         load-json to-json
 15 |     ]
 16 | 
 17 |     History: [
 18 |         18-Sep-2015 0.3.6 "Non-Word keys loaded as strings"
 19 |         17-Sep-2015 0.3.5 "Added GET-PATH! lookup"
 20 |         16-Sep-2015 0.3.4 "Reinstate /FLAT refinement"
 21 |         21-Apr-2015 0.3.3 {
 22 |             - Merge from Reb4.me version
 23 |             - Recognise set-word pairs as objects
 24 |             - Use map! as the default object type
 25 |             - Serialize dates in RFC 3339 form
 26 |         }
 27 |         14-Mar-2015 0.3.2 "Converts Json input to string before parsing"
 28 |         07-Jul-2014 0.3.0 "Initial support for JSONP"
 29 |         15-Jul-2011 0.2.6 "Flattens Flickr '_content' objects"
 30 |         02-Dec-2010 0.2.5 "Support for time! added"
 31 |         28-Aug-2010 0.2.4 "Encodes tag! any-type! paired blocks as an object"
 32 |         06-Aug-2010 0.2.2 "Issue! composed of digits encoded as integers"
 33 |         22-May-2005 0.1.0 "Original Version"
 34 |     ]
 35 | 
 36 |     Notes: {
 37 |         - Converts date! to RFC 3339 Date String
 38 |     }
 39 | ]
 40 | 
 41 | load-json: use [
 42 |     tree branch here val is-flat emit new-child to-parent neaten word to-word
 43 |     space comma number string block object _content value ident
 44 | ][
 45 |     branch: make block! 10
 46 | 
 47 |     emit: func [val] [here: insert/only here val]
 48 |     new-child: [(insert/only branch insert/only here here: make block! 10)]
 49 |     to-parent: [(here: take branch)]
 50 |     neaten: [
 51 |         (new-line/all head here true)
 52 |         (new-line/all/skip head here true 2)
 53 |     ]
 54 | 
 55 |     to-word: use [word1 word+] [
 56 |         ; upper ranges borrowed from AltXML
 57 |         word1: charset [
 58 |             "!&*=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
 59 |             #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
 60 |             #"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
 61 |             #"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
 62 |             #"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
 63 |         ]
 64 | 
 65 |         word+: charset [
 66 |             "!&'*+-.0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
 67 |             #"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
 68 |             #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
 69 |             #"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
 70 |             #"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
 71 |         ]
 72 | 
 73 |         func [val [string!]] [
 74 |             all [
 75 |                 parse val [word1 any word+]
 76 |                 to word! val
 77 |             ]
 78 |         ]
 79 |     ]
 80 | 
 81 |     space: use [space] [
 82 |         space: charset " ^-^/^M"
 83 |         [any space]
 84 |     ]
 85 | 
 86 |     comma: [space #"," space]
 87 | 
 88 |     number: use [dg ex nm as-num] [
 89 |         dg: charset "0123456789"
 90 |         ex: [[#"e" | #"E"] opt [#"+" | #"-"] some dg]
 91 |         nm: [opt #"-" some dg opt [#"." some dg] opt ex]
 92 | 
 93 |         as-num: func [val [string!]] [
 94 |             case [
 95 |                 not parse val [opt "-" some dg] [to decimal! val]
 96 |                 not integer? try [val: to integer! val] [to issue! val]
 97 |                 val [val]
 98 |             ]
 99 |         ]
100 | 
101 |         [copy val nm (val: as-num val)]
102 |     ]
103 | 
104 |     string: use [ch es hx mp decode] [
105 |         ch: complement charset {\"}
106 |         es: charset {"\/bfnrt}
107 |         hx: charset "0123456789ABCDEFabcdef"
108 |         mp: [#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-"]
109 | 
110 |         decode: use [ch mk escape] [
111 |             escape: [
112 |                 ; should be possible to use CHANGE keyword to replace escaped characters.
113 |                 mk: #"\" [
114 |                     es (mk: change/part mk select mp mk/2 2)
115 |                     |
116 |                     #"u" copy ch 4 hx (
117 |                         mk: change/part mk to char! to integer! debase/base ch 16 6
118 |                     )
119 |                 ] :mk
120 |             ]
121 | 
122 |             func [text [string! none!]] [
123 |                 either none? text [make string! 0] [
124 |                     all [parse text [any [to "\" escape] to end] text]
125 |                 ]
126 |             ]
127 |         ]
128 | 
129 |         [#"^"" copy val [any [some ch | #"\" [#"u" 4 hx | es]]] #"^"" (val: decode val)]
130 |     ]
131 | 
132 |     block: use [list] [
133 |         list: [space opt [value any [comma value]] space]
134 | 
135 |         [#"[" new-child list #"]" neaten/1 to-parent]
136 |     ]
137 | 
138 |     _content: [#"{" space {"_content"} space #":" space value space "}"]  ; Flickr
139 | 
140 |     object: use [name list as-map] [
141 |         name: [
142 |             string space #":" space (
143 |                 emit either is-flat [
144 |                     to tag! val
145 |                 ][
146 |                     any [
147 |                         to-word val
148 |                         val
149 |                     ]
150 |                 ]
151 |             )
152 |         ]
153 |         list: [space opt [name value any [comma name value]] space]
154 |         as-map: [(unless is-flat [here: change back here make map! pick back here 1])]
155 | 
156 |         [#"{" new-child list #"}" neaten/2 to-parent as-map]
157 |     ]
158 | 
159 |     ident: use [initial ident] [
160 |         initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
161 |         ident: union initial charset [#"0" - #"9"]
162 | 
163 |         [initial any ident]
164 |     ]
165 | 
166 |     value: [
167 |         "null" (emit none)
168 |         | "true" (emit true)
169 |         | "false" (emit false)
170 |         | number (emit val)
171 |         | string (emit val)
172 |         | _content
173 |         | object | block
174 |     ]
175 | 
176 |     func [
177 |         "Convert a JSON string to Rebol data"
178 |         json [string! binary! file! url!] "JSON string"
179 |         /flat "Objects are imported as tag-value pairs"
180 |         /padded "Loads JSON data wrapped in a JSONP envelope"
181 |     ][
182 |         case/all [
183 |             any [file? json url? json] [
184 |                 if error? json: try [read/string (json)] [
185 |                     do :json
186 |                 ]
187 |             ]
188 |             binary? json [json: to string! json]
189 |         ]
190 | 
191 |         is-flat: :flat
192 |         tree: here: make block! 0
193 | 
194 |         either parse json either padded [
195 |             [space ident space "(" space opt value space ")" opt ";" space]
196 |         ][
197 |             [space opt value space]
198 |         ][
199 |             pick tree 1
200 |         ][
201 |             do make error! "Not a valid JSON string"
202 |         ]
203 |     ]
204 | ]
205 | 
206 | to-json: use [
207 |     json emit emits escape emit-issue emit-date
208 |     here lookup comma block object block-of-pairs value
209 | ][
210 |     emit: func [data] [repend json data]
211 |     emits: func [data] [emit {"} emit data emit {"}]
212 | 
213 |     escape: use [mp ch encode] [
214 |         mp: [#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/"]
215 |         ch: intersect ch: charset [#" " - #"~"] difference ch charset extract mp 2
216 | 
217 |         encode: func [here] [
218 |             change/part here any [
219 |                 select mp here/1
220 |                 rejoin ["\u" skip tail form to-hex to integer! here/1 -4]
221 |             ] 1
222 |         ]
223 | 
224 |         func [txt] [
225 |             parse txt [any [txt: some ch | skip (txt: encode txt) :txt]]
226 |             head txt
227 |         ]
228 |     ]
229 | 
230 |     emit-issue: use [dg nm mk] [
231 |         dg: charset "0123456789"
232 |         nm: [opt "-" some dg]
233 | 
234 |         [(either parse next form here/1 [copy mk nm] [emit mk] [emits here/1])]
235 |     ]
236 | 
237 |     emit-date: use [pad second] [
238 |         pad: func [part length] [part: to string! part head insert/dup part "0" length - length? part]
239 | 
240 |         quote (
241 |             emits rejoin collect [
242 |                 keep reduce [pad here/1/year 4 "-" pad here/1/month 2 "-" pad here/1/day 2]
243 |                 if here/1/time [
244 |                     keep reduce ["T" pad here/1/hour 2 ":" pad here/1/minute 2 ":"]
245 |                     keep either integer? here/1/second [
246 |                         pad here/1/second 2
247 |                     ][
248 |                         second: split to string! here/1/second "."
249 |                         reduce [pad second/1 2 "." second/2]
250 |                     ]
251 |                     keep either any [
252 |                         none? here/1/zone
253 |                         zero? here/1/zone
254 |                     ][
255 |                         "Z"
256 |                     ][
257 |                         reduce [
258 |                             either here/1/zone/hour < 0 ["-"] ["+"]
259 |                             pad abs here/1/zone/hour 2 ":" pad here/1/zone/minute 2
260 |                         ]
261 |                     ]
262 |                 ]
263 |             ]
264 |         )
265 |     ]
266 | 
267 |     lookup: [
268 |         here: [get-word! | get-path!]
269 |         (change here reduce reduce [here/1])
270 |         fail
271 |     ]
272 | 
273 |     comma: [(if not tail? here [emit ","])]
274 | 
275 |     block: [
276 |         (emit "[") any [here: value here: comma] (emit "]")
277 |     ]
278 | 
279 |     block-of-pairs: [
280 |           some [set-word! skip]
281 |         | some [tag! skip]
282 |     ]
283 | 
284 |     object: [
285 |         (emit "{")
286 |         any [
287 |             here: [set-word! (change here to word! here/1) | any-string! | any-word!]
288 |             (emit [{"} escape to string! here/1 {":}])
289 |             here: value here: comma
290 |         ]
291 |         (emit "}")
292 |     ]
293 | 
294 |     value: [
295 |           lookup ; resolve a GET-WORD! reference
296 |         | number! (emit here/1)
297 |         | [logic! | 'true | 'false] (emit to string! here/1)
298 |         | [none! | 'none] (emit 'null)
299 |         | date! emit-date
300 |         | issue! emit-issue
301 |         | [
302 |             any-string! | word! | lit-word! | tuple! | pair! | money! | time!
303 |         ] (emits escape form here/1)
304 |         | any-word! (emits escape form to word! here/1)
305 | 
306 |         | [object! | map!] :here (change/only here body-of first here) into object
307 |         | into block-of-pairs :here (change/only here copy first here) into object
308 |         | any-block! :here (change/only here copy first here) into block
309 | 
310 |         | any-type! (emits to tag! type? first here)
311 |     ]
312 | 
313 |     func [data] [
314 |         json: make string! 1024
315 |         if parse compose/only [(data)] [here: value] [json]
316 |     ]
317 | ]
318 | 


--------------------------------------------------------------------------------
/r3-alpha/altwebform.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "Web Form Encoder/Decoder for Rebol 3"
  3 |     Date: 6-Sep-2015
  4 |     Author: "Christopher Ross-Gill"
  5 |     Home: http://www.ross-gill.com/page/Web_Forms_and_REBOL
  6 |     File: %altwebform.r3
  7 |     Version: 0.10.2
  8 |     Purpose: "Convert a Rebol block to a URL-Encoded Web Form string"
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 | 
 11 |     Type: module
 12 |     Name: rgchris.altwebform
 13 |     Exports: [
 14 |         url-decode url-encode load-webform to-webform
 15 |     ]
 16 | 
 17 |     History: [
 18 |         06-Sep-2015 0.10.2 "Tidy/Detab"
 19 |         06-Sep-2015 0.10.1 "Add Ruby-style paths to encoding"
 20 |         06-Jul-2013 0.9.5 "Fix encoding/decoding of _ character"
 21 |         01-Mar-2013 0.9.4 "Detach URL-DECODE and URL-ENCODE"
 22 |         27-Feb-2013 0.9.2 "Correct encoding of UTF-8 values"
 23 |         18-Nov-2009 0.1.0 "Original Version"
 24 |     ]
 25 | 
 26 |     Usage: [
 27 |         load-webform "a=3&aa.a=1&b.c=1&b.c=2"
 28 |         to-webform [a "3" aa [a "1"] b [c ["1" "2"]]]
 29 |     ]
 30 | ]
 31 | 
 32 | url-decode: use [
 33 |     as-is hex space
 34 | ][
 35 |     as-is: charset [
 36 |         "-.~" #"0" - #"9" #"A" - #"Z" #"a" - #"z"
 37 |     ]
 38 | 
 39 |     hex: charset [
 40 |         #"0" - #"9" #"a" - #"f" #"A" - #"F"
 41 |     ]
 42 | 
 43 |     func [
 44 |         "Decode percent-encoded text from URLs and Web Forms"
 45 | 
 46 |         text [any-string!]
 47 |         "Text to Decode"
 48 | 
 49 |         /wiki
 50 |         "Assumes `_` character is used to represent spaces"
 51 |     ][
 52 |         space: either wiki [#"_"] [#"+"]
 53 | 
 54 |         either parse text: to binary! text [
 55 |             copy text any [
 56 |                 some as-is | remove space insert " "
 57 |                 | [#"_" | #"+" | #"." | #","]
 58 |                 | change "%0D%0A" "^/"  ; de-crlf
 59 |                 | remove ["%" copy text 2 hex] (text: debase/base text 16) insert text
 60 |             ]
 61 |         ][
 62 |             to string! text
 63 |         ][
 64 |             none
 65 |         ]
 66 |     ]
 67 | ]
 68 | 
 69 | url-encode: use [
 70 |     as-is space percent-encode
 71 | ][
 72 |     as-is: charset [
 73 |         "-." #"0" - #"9" #"A" - #"Z" #"-" #"a" - #"z" #"~"
 74 |     ]
 75 | 
 76 |     percent-encode: func [text] [
 77 |         insert next text enbase/base copy/part text 1 16 change text "%"
 78 |     ]
 79 | 
 80 |     func [
 81 |         "Encode text using percent-encoding for URLs and Web Forms"
 82 | 
 83 |         text [any-string!]
 84 |         "Text to encode"
 85 | 
 86 |         /wiki
 87 |         "Use `_` character to represent spaces"
 88 |     ][
 89 |         space: either wiki [#"_"] [#"+"]
 90 | 
 91 |         either parse text: to binary! text [
 92 |             copy text any [
 93 |                 text: some as-is | end | change " " space
 94 |                 |
 95 |                 [#"_" | #"."]
 96 |                 (either wiki [percent-encode text] [text])
 97 |                 |
 98 |                 skip
 99 |                 (percent-encode text)
100 |             ]
101 |         ][
102 |             to string! text
103 |         ][
104 |             ""
105 |         ]
106 |     ]
107 | ]
108 | 
109 | load-webform: use [
110 |     result path string pair as-path term
111 | ][
112 |     result: copy []
113 | 
114 |     as-path: func [
115 |         name [string!]
116 |     ][
117 |         to path! to block! replace/all name #"." #" "
118 |     ]
119 | 
120 |     path: use [aa an wd] [
121 |         aa: charset [#"a" - #"z" #"A" - #"Z" #"_"]
122 |         an: charset [#"-" #"0" - #"9" #"a" - #"z" #"A" - #"Z" #"_"]
123 |         wd: [aa 0 40 an]  ; one alpha, any alpha/numeric/dash/underscore
124 | 
125 |         [
126 |             wd 0 6 [#"." wd]
127 |         ]
128 |     ]
129 | 
130 |     string: use [ch hx] [
131 |         ch: charset ["-._~" #"0" - #"9" #"A" - #"Z" #"a" - #"z"]
132 |         hx: charset [#"0" - #"9" #"a" - #"f" #"A" - #"F"]
133 |         [
134 |             any [
135 |                 ch | #"+" | #"%" 2 hx
136 |             ]
137 |             ; any [unreserved | percent-encoded]
138 |         ]
139 |     ]
140 | 
141 |     term: [
142 |         #"&" | end
143 |     ]
144 | 
145 |     pair: use [
146 |         name value tree
147 |     ][
148 |         [
149 |             copy name path [
150 |                 #"="
151 |                 copy value string
152 |                 term
153 |                 |
154 |                 term
155 |                 (value: true)
156 |             ]
157 |             (
158 |                 tree: :result
159 |                 name: as-path name
160 |                 if string? value [
161 |                     value: url-decode value
162 |                 ]
163 | 
164 |                 until [
165 |                     tree: any [
166 |                         find/tail tree name/1
167 |                         insert tail tree name/1
168 |                     ]
169 | 
170 |                     name: next name
171 | 
172 |                     switch type?/word tree/1 [
173 |                         none! [
174 |                             if not tail? name [
175 |                                 insert/only tree tree: copy []
176 |                             ]
177 |                         ]
178 | 
179 |                         string! [
180 |                             change/only tree tree: reduce [
181 |                                 tree/1
182 |                             ]
183 |                         ]
184 | 
185 |                         block! [
186 |                             tree: tree/1
187 |                         ]
188 |                     ]
189 | 
190 |                     if tail? name [
191 |                         append tree value
192 |                     ]
193 |                 ]
194 |             )
195 |         ]
196 |     ]
197 | 
198 |     func [
199 |         [catch]
200 |         "Loads data from a URL-Encoded Web Form string"
201 | 
202 |         webform [string! none!]
203 |         "Form to decode"
204 |     ][
205 |         webform: any [
206 |             webform ""
207 |         ]
208 | 
209 |         result: copy []
210 | 
211 |         either parse webform [
212 |             opt [#"&" | #"?"]
213 |             any pair
214 |         ][
215 |             result
216 |         ][
217 |             do make error! "Not a URL Encoded Web Form"
218 |         ]
219 |     ]
220 | ]
221 | 
222 | to-webform: use [
223 |     webform form-key emit ruby-style?
224 |     here lookup reference path value block array key object
225 | ][
226 |     path: []
227 | 
228 |     form-key: does [
229 |         rejoin collect [
230 |             keep first path
231 | 
232 |             foreach key next path [
233 |                 keep reduce either ruby-style? [
234 |                     ["[" key "]"]
235 |                 ][
236 |                     ["." key]
237 |                 ]
238 |             ]
239 |         ]
240 |     ]
241 | 
242 |     emit: func [
243 |         data [string! logic!]
244 |     ][
245 |         repend webform [
246 |             "&" url-encode form-key "=" url-encode data
247 |         ]
248 |     ]
249 | 
250 |     lookup: [
251 |         here:
252 |         (reference: none)
253 |         set reference [
254 |             get-word! | get-path!
255 |         ]
256 |         (change/only here get here/1)
257 |         :here
258 |     ]
259 | 
260 |     value: [
261 |         number! (emit form here/1)
262 |         |
263 |         [
264 |             logic! | 'true | 'false
265 |         ]
266 |         (emit to string! here/1)
267 |         |
268 |         [
269 |             none! | 'none
270 |         ]
271 |         |
272 |         [
273 |             set-word! | lit-word! | get-word!
274 |         ]
275 |         (emit to string! to word! here/1)
276 |         |
277 |         date!
278 |         (emit replace mold here/1 "/" "T")
279 |         |
280 |         tag!
281 |         (emit mold here/1)
282 |         |
283 |         [
284 |             any-string! | word! | tuple! | money! | time! | pair! | issue!
285 |         ]
286 |         (emit to string! here/1)
287 |     ]
288 | 
289 |     array: [
290 |         (append path "")
291 | 
292 |         any [
293 |             opt lookup value
294 |             |
295 |             skip
296 |             (
297 |                 do make error! rejoin [
298 |                     "Invalid value: "
299 |                     copy/part mold any [reference here/1] 40
300 |                 ]
301 |             )
302 |         ]
303 | 
304 |         end
305 |         (remove back tail path)
306 |     ]
307 | 
308 |     key: [
309 |         word! | set-word! | tag!
310 |     ]
311 | 
312 |     object: [
313 |         and [
314 |             some [key skip]
315 |             end
316 |         ]
317 | 
318 |         some [
319 |             here:
320 |             key
321 |             (
322 |                 append path to string! either set-word? here/1 [
323 |                     to word! here/1
324 |                 ][
325 |                     here/1
326 |                 ]
327 |             )
328 |             opt lookup
329 |             [
330 |                 value | block
331 |             ]
332 |             (remove back tail path)
333 |         ] end
334 |     ]
335 | 
336 |     block: [
337 |         here:
338 |         and [
339 |             [
340 |                 any-block!
341 |             ]
342 |             (change/only here copy here/1)
343 |             |
344 |             [
345 |                 object! | map!
346 |             ]
347 |             (change/only here body-of here/1)
348 |         ][
349 |             into [
350 |                 object | array
351 |             ]
352 |         ]
353 |     ]
354 | 
355 |     func [
356 |         "Serializes block data as URL-Encoded Web Form string"
357 | 
358 |         data [block! map! object!]
359 |         "Block or object to encode"
360 | 
361 |         /prefix
362 |         "Includes the `?` character used to precede URL query strings"
363 | 
364 |         /ruby-style
365 |         "Encodes structured keys using `a[b][c]` notation"
366 |     ][
367 |         clear path
368 |         webform: copy ""
369 |         data: either block? data [
370 |             copy data
371 |         ][
372 |             body-of data
373 |         ]
374 | 
375 |         ruby-style?: :ruby-style
376 | 
377 |         if parse copy data object [
378 |             either all [
379 |                 prefix not tail? next webform
380 |             ][
381 |                 back change webform "?"
382 |             ][
383 |                 remove webform
384 |             ]
385 |         ]
386 |     ]
387 | ]
388 | 


--------------------------------------------------------------------------------
/r3-alpha/as.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "AS Function"
  3 |     Date: 14-Aug-2013
  4 |     Author: "Christopher Ross-Gill"
  5 |     File: %as.r3
  6 |     Version: 0.5.4
  7 |     Purpose: "Coerce arbitrary data into Rebol values."
  8 | 
  9 |     Type: module
 10 |     Name: rgchris.as
 11 |     Exports: [
 12 |         amend as
 13 |     ]
 14 | ]
 15 | 
 16 | wrap: func [body [block!]] [
 17 |     use collect [
 18 |         parse body [
 19 |             any [body: set-word! (keep to word! body/1) | skip]
 20 |         ]
 21 |     ] head body
 22 | ]
 23 | 
 24 | amend: wrap [
 25 |     ascii: charset ["^/^-" #"^(20)" - #"^(7E)"]
 26 |     digit: charset [#"0" - #"9"]
 27 |     upper: charset [#"A" - #"Z"]
 28 |     lower: charset [#"a" - #"z"]
 29 |     alpha: union upper lower
 30 |     alphanum: union alpha digit
 31 |     hex: union digit charset [#"A" - #"F" #"a" - #"f"]
 32 | 
 33 |     symbol: file*: union alphanum charset "_-"
 34 |     url-: union alphanum charset "!'*,-._~"  ; "!*-._"
 35 |     url*: union url- charset ":+%&=?"
 36 | 
 37 |     space: charset " ^-"
 38 |     ws: charset " ^-^/"
 39 | 
 40 |     word1: union alpha charset "!&*+-.?_|"
 41 |     word*: union word1 digit
 42 |     html*: exclude ascii charset {&<>"}
 43 | 
 44 |     para*: path*: union alphanum charset "!%'+-._"
 45 |     extended: charset [#"^(80)" - #"^(FF)"]
 46 | 
 47 |     chars: complement nochar: charset " ^-^/^@^M"
 48 |     ascii+: charset [#"^(20)" - #"^(7E)"]
 49 |     wiki*: complement charset [#"^(00)" - #"^(1F)" {:*.<>} #"{" #"}"]
 50 |     name: union union lower digit charset "*!',()_-"
 51 |     wordify-punct: charset "-_()!"
 52 | 
 53 |     ucs: charset ""
 54 |     utf-8: use [utf-2 utf-3 utf-4 utf-5 utf-b] [
 55 |         utf-2: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wAAAAA=}]
 56 |         utf-3: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//AAA=}]
 57 |         utf-4: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/wA=}]
 58 |         utf-5: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA8=}]
 59 |         utf-b: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP//////////AAAAAAAAAAA=}]
 60 | 
 61 |         [utf-2 1 utf-b | utf-3 2 utf-b | utf-4 3 utf-b | utf-5 4 utf-b]
 62 |     ]
 63 | 
 64 |     get-ucs-code: decode-utf: use [utf-os utf-fc int] [
 65 |         utf-os: [0 192 224 240 248 252]
 66 |         utf-fc: [1 64 4096 262144 16777216]
 67 | 
 68 |         func [char] [
 69 |             int: 0
 70 |             char: change char char/1 xor pick utf-os length? char
 71 |             forskip char 1 [change char char/1 xor 128]
 72 |             char: head reverse head char
 73 |             forskip char 1 [int: (to integer! char/1) * (pick utf-fc index? char) + int]
 74 |             all [int > 127 int <= 65535 int]
 75 |         ]
 76 |     ]
 77 | 
 78 |     inline: [ascii+ | utf-8]
 79 |     text-row: [chars any [chars | space]]
 80 |     text: [ascii | utf-8]
 81 | 
 82 |     ident: [alpha 0 14 file*]
 83 |     wordify: [alphanum 0 99 [wordify-punct | alphanum]]
 84 |     word: [word1 0 25 word*]
 85 |     number: [some digit]
 86 |     integer: [opt #"-" number]
 87 |     wiki: [some [wiki* | utf-8]]
 88 |     ws*: white-space: [some ws]
 89 | 
 90 |     amend: func [rule [block!]] [
 91 |         bind rule 'amend
 92 |     ]
 93 | ]
 94 | 
 95 | as: wrap [
 96 |     masks: reduce amend [
 97 |         issue!    [some url*]
 98 |         logic!    ["true" | "on" | "yes" | "1"]
 99 |         word!     [word]
100 |         url!      [ident #":" some [url* | #":" | #"/"]]
101 |         email!    [some url* #"@" some url*]
102 |         path!     [word 1 5 [#"/" [word | integer]]]
103 |         integer!  [integer]
104 |         string!   [some [some ascii | utf-8]]
105 |         'positive [number]
106 |         'id       [ident]
107 |         'key      [word 0 6 [#"." word]]
108 |     ]
109 | 
110 |     load-date: func [date [string!]] [
111 |         all [
112 |             date: attempt [load date]
113 |             date? date
114 |             date
115 |         ]
116 |     ]
117 | 
118 |     load-rfc3339: func [date [string!]] [
119 |         if parse/all date amend [
120 |             copy date [
121 |                 3 5 digit "-" 1 2 digit "-" 1 2 digit
122 |                 opt [
123 |                     ["T" | " "] 1 2 digit ":" 1 2 digit
124 |                     opt [":" 1 2 digit opt ["." 1 6 digit]]
125 |                     opt ["Z" | ["+" | "-"] 1 2 digit ":" 1 2 digit]
126 |                 ]
127 |             ]
128 |         ][
129 |             replace date "T" "/"
130 |             replace date " " "/"
131 |             replace date "Z" "+0:00"
132 |             load-date date
133 |         ]
134 |     ]
135 | 
136 |     load-rfc822: use [day month] [
137 |         ; http://www.w3.org/Protocols/rfc822/#z28
138 | 
139 |         day: ["Mon" | "Tue" | "Wed" | "Thu" | "Fri" | "Sat" | "Sun"]
140 | 
141 |         month: [
142 |               "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
143 |             | "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
144 |         ]
145 | 
146 |         ; "Tue, 08 Jan 2013 15:19:11 UTC"
147 |         func [date [string!] /local part checked] [
148 |             date: collect [
149 |                 checked: parse/all date amend [
150 |                     any space
151 |                     day ", "
152 |                     copy part 1 2 digit (keep part)  ; permissive--spec says 2 digit
153 |                     " " (keep "-")
154 |                     copy part month (keep part)
155 |                     " " (keep "-")
156 |                     copy part 4 digit (keep part)
157 |                     " " (keep "/")
158 |                     copy part [
159 |                         1 2 digit ":" 1 2 digit opt [":" 2 digit]
160 |                     ] (keep part)
161 |                     " "
162 |                     [
163 |                           "UTC" | "UT" | "GMT" | "Z"
164 |                         | "EDT" (keep "-4:00")
165 |                         | ["EST" | "CDT"] (keep "-5:00")
166 |                         | ["CST" | "MDT"] (keep "-6:00")
167 |                         | ["MST" | "PDT"] (keep "-7:00")
168 |                         | "PST" (keep "-8:00")
169 |                         | part: upper (  ; though not using PARSE/CASE
170 |                             part: to integer! uppercase first part
171 |                             case [
172 |                                 part < 74 [keep reduce ["+" part - 64 ":00"]]
173 |                                 part = 74 [keep now/zone]  ; J is local time
174 |                                 part < 78 [keep reduce ["+" part - 65 ":00"]]
175 |                                 part > 77 [keep reduce ["-" part - 77 ":00"]]
176 |                             ]
177 |                         )
178 |                         | copy part [["+" | "-"] 2 digit ":" 2 digit] (keep part)
179 |                         | copy part [["+" | "-"] 4 digit] (
180 |                             insert at part 4 ":"
181 |                             keep part
182 |                         )
183 |                     ]
184 |                     any space
185 |                     end  ; expects date to be the only content in the string
186 |                 ]
187 |             ]
188 |             if checked [load-date rejoin date]
189 |         ]
190 |     ]
191 | 
192 |     as: func [
193 |         [catch] type [datatype!] value [any-type!]
194 |         /where format [none! block! any-word!]
195 |     ][
196 |         case/all [
197 |             none? value [return none]
198 |             all [string? value any [type <> string! any-word? format]] [value: trim value]
199 |             type = logic! [if find ["false" "off" "no" "0" 0 false off no #[false]] value [return false]]
200 |             all [string? value type = date!] [
201 |                 value: any [
202 |                     load-date value
203 |                     load-rfc3339 value
204 |                     load-rfc822 value
205 |                 ]
206 |             ]
207 |             block? format [format: amend bind format 'value]
208 |             none? format [format: select masks type]
209 |             none? format [if type = type? value [return value]]
210 |             any-word? format [format: select masks to word! format]
211 |             block? format [
212 |                 unless parse/all value: form value format [return none]
213 |             ]
214 |             type = path! [return load value]
215 |         ]
216 | 
217 |         attempt [make type value]
218 |     ]
219 | ]
220 | 


--------------------------------------------------------------------------------
/r3-alpha/color-code.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "Color Code"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 21-Oct-2013
  5 |     File: %color-code.r3
  6 |     Version: 2.1.2
  7 |     Purpose: "Colorize Rebol (and derivative) source code based on datatype"
  8 |     Rights: http://opensource.org/licenses/Apache-2.0
  9 |     Type: module
 10 |     Name: rgchris.color-code
 11 |     Exports: [script? load-header color-code]
 12 |     History: [
 13 |         29-Aug-2016 2.1.2 "Remove functions from headers." "Christopher Ross-Gill"
 14 |         21-Oct-2013 2.1.1 "Custom header handling; revised sanitization process." "Christopher Ross-Gill"
 15 |         23-Oct-2009 2.1.0 "Rewritten as QM module." "Christopher Ross-Gill"
 16 |         29-May-2003 1.0.0 "Fixed deep parse rule bug." "Carl Sassenrath"
 17 |     ]
 18 | ]
 19 | 
 20 | ; cross-posted from %rsp.r3
 21 | sanitize: use [ascii html* extended] [
 22 |     html*: exclude ascii: charset ["^/^-" #"^(20)" - #"^(7E)"] charset {&<>"}
 23 |     extended: complement charset [#"^(00)" - #"^(7F)"]
 24 | 
 25 |     func [text [any-string!] /local char] [
 26 |         parse form text [
 27 |             copy text any [
 28 |                 text: some html*
 29 |                 | change #"<" "&lt;" | change #">" "&gt;" | change #"&" "&amp;"
 30 |                 | change #"^"" "&quot;" | remove #"^M"
 31 |                 | remove copy char extended (char: rejoin ["&#" to integer! char/1 ";"]) insert char
 32 |                 | change skip "&#65533;"
 33 |             ]
 34 |         ]
 35 |         any [text copy ""]
 36 |     ]
 37 | ]
 38 | 
 39 | script?: use [space id mark type] [
 40 |     space: charset " ^-"
 41 |     id: [
 42 |         any space mark:
 43 |         any ["[" mark: (mark: back mark) any space]
 44 |         copy type ["Rebol" | "Red" opt "/System" | "World" | "Topaz" | "Freebell"] (
 45 |             type: first find [  ; normalize capitalization
 46 |                 "Rebol" "Red" "Red/System" "World" "Topaz" "Freebell"
 47 |             ] type
 48 |         )
 49 |         any space
 50 |         "[" to end
 51 |     ]
 52 | 
 53 |     func [source [string! binary!] /language] [
 54 |         if all [
 55 |             parse source [
 56 |                 some [
 57 |                     id break |
 58 |                     (mark: none)
 59 |                     thru newline opt #"^M"
 60 |                 ]
 61 |             ]
 62 |             mark
 63 |         ][either language [type] [mark]]
 64 |     ]
 65 | ]
 66 | 
 67 | load-next: func [string [string!] /local out] [
 68 |     out: transcode/next to binary! string
 69 |     out/2: skip string subtract length? string length? to string! out/2
 70 |     out
 71 | ]
 72 | 
 73 | load-header: func [[catch] source [string! binary!] /local header] [
 74 |     source: to string! source
 75 |     unless header: script? source [make error! "Source does not contain header."]
 76 |     header: find next header "["
 77 |     unless header: attempt [load-next header] [make error! "Header is incomplete."]
 78 |     reduce [construct/with header/1 system/standard/script header/2]
 79 | ]
 80 | 
 81 | color-code: use [out emit emit-var emit-header rule value] [
 82 |     out: none
 83 |     emit: func [data] [
 84 |         data: reduce compose [(data)]
 85 |         until [append out take data empty? data]
 86 |     ]
 87 | 
 88 |     emit-var: func [value start stop /local type out] [
 89 |         either none? :value [type: "cmt"] [
 90 |             if path? :value [value: first :value]
 91 | 
 92 |             type: either word? :value [
 93 |                 any [
 94 |                     all [find [Rebol Red Topaz Freebell World] :value "rebol"]
 95 |                     all [value? :value any-function? get :value "function"]
 96 |                     all [value? :value datatype? get :value "datatype"]
 97 |                     "word"
 98 |                 ]
 99 |             ][
100 |                 any [replace to string! type?/word :value "!" ""]
101 |             ]
102 |         ]
103 | 
104 |         out: sanitize copy/part start stop
105 | 
106 |         emit either type [
107 |             [{<var class="dt-} type {">} out {</var>}]
108 |         ][
109 |             out
110 |         ]
111 |     ]
112 | 
113 |     rule: use [str new rule hx] [
114 |         hx: charset "0123456789abcdefABCDEF"
115 | 
116 |         rule: [
117 |             some [
118 |                 str:
119 |                 some [" " | tab] new: (emit copy/part str new) |
120 |                 [crlf | newline] (emit "^/") |
121 |                 #";" [thru newline | to end] new:
122 |                 (emit-var none str new) |
123 |                 [#"[" | #"("] (emit first str) rule |
124 |                 [#"]" | #")"] (emit first str) break |
125 |                 [8 hx | 4 hx | 2 hx] #"h" new:
126 |                 (emit-var 0 str new) |
127 |                 skip (
128 |                     set [value new] load-next str
129 |                     emit-var :value str new
130 |                 ) :new
131 |             ]
132 |         ]
133 | 
134 |         [
135 |             rule [end | str: to end (emit sanitize str)]
136 |         ]
137 |     ]
138 | 
139 |     func [
140 |         "Return color source code as HTML."
141 |         text [string!] "Source code text"
142 |     ][
143 |         out: make binary! 3 * length? text
144 | 
145 |         unless text: script? detab text [
146 |             make error! "Not a Rebol or Red script."
147 |         ]
148 | 
149 |         unless head? text [
150 |             emit [
151 |                 {<var class="dt-preamble">}
152 |                 sanitize copy/part head text text
153 |                 "</var>"
154 |             ]
155 |         ]
156 | 
157 |         parse text [rule]
158 | 
159 |         insert out {<pre class="code rebol">}
160 |         to string! append out {</pre>}
161 |     ]
162 | ]
163 | 


--------------------------------------------------------------------------------
/r3-alpha/combine.r3:
--------------------------------------------------------------------------------
 1 | Rebol [
 2 |     Title: "Combine"
 3 |     Date: 28-March-2014  ; or thereabouts
 4 |     Author: "Brian Dickens"
 5 |     Version: 1.0.0
 6 | 
 7 |     Type: module
 8 |     Name: hostilefork.combine
 9 |     Exports: [
10 |         combine
11 |     ]
12 | ]
13 | 
14 | combine: func [
15 |     {Combine evaluated expressions and substitute block variables to produce a string}
16 |     block [block! any-string!] "Specification to process"
17 |     /with "Add delimiter between values (will be combined if a block)"
18 |     delimiter [block! any-string! char!]
19 |     /into "Insert output into an existing string instead of making a new one"
20 |     out [any-string!]
21 |     /local
22 |     value pre-delimit needs-delimiter
23 | ][
24 |     out: any [out make string! 10]
25 | 
26 |     unless block? block [
27 |         block: reduce [block]
28 |     ]
29 | 
30 |     if block? delimiter [
31 |         delimiter: combine delimiter
32 |     ]
33 | 
34 |     needs-delimiter: none
35 | 
36 |     pre-delimit: does [
37 |         either needs-delimiter [
38 |             out: append out delimiter
39 |         ][
40 |             needs-delimiter: true? with
41 |         ]
42 |     ]
43 | 
44 |     ; Do evaluation of the block until a non-none evaluation result
45 |     ; is found... or the end of the input is reached.
46 |     ;
47 |     while [not tail? block] [
48 |         try/except [
49 |             value: do/next block 'block
50 |         ][
51 |             do system/state/last-error
52 |         ]
53 | 
54 |         ; Blocks are substituted in evaluation, like the recursive nature
55 |         ; of parse rules.
56 |         ;
57 |         switch/default type?/word :value [
58 |             unset! none! []
59 | 
60 |             function! [
61 |                 do make error! "Evaluation in COMBINE gave function"
62 |             ]
63 | 
64 |             block! [
65 |                 pre-delimit
66 |                 out: combine/into value out
67 |             ]
68 | 
69 |             paren! path! set-path! get-path! lit-path! [
70 |                 do make error! "Evaluation in COMBINE gave non-block! block"
71 |             ]
72 | 
73 |             word! set-word! get-word! lit-word! refinement! [
74 |                 do make error! join "Evaluation in COMBINE gave symbolic word: " mold value
75 |             ]
76 |         ][
77 |             pre-delimit
78 |             append out (form :value)
79 |         ]
80 |     ]
81 | 
82 |     either into [
83 |         out
84 |     ][
85 |         head out
86 |     ]
87 | ]
88 | 


--------------------------------------------------------------------------------
/r3-alpha/form-date.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "Date Formatter for Rebol 3"
  3 |     Date: 6-Sep-2015
  4 |     Author: "Christopher Ross-Gill"
  5 |     Home: http://scripts.rebol.info/scripts/form-date,docs
  6 |     File: %form-date.r3
  7 |     Version: 1.1.0
  8 |     Purpose: {Return formatted date string using strftime style format specifiers}
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 | 
 11 |     Type: module
 12 |     Name: rgchris.form-date
 13 |     Exports: [form-date form-time]
 14 | 
 15 |     History: [
 16 |         06-Sep-2015 1.1.0 "Change to use REWORD; Deprecate /GMT"
 17 |         12-Jun-2013 1.0.0 "Ported from Rebol 2"
 18 |     ]
 19 | 
 20 |     Notes: {Extracted from the QuarterMaster web framework}
 21 | ]
 22 | 
 23 | pad: func [
 24 |     text
 25 |     length [integer!]
 26 |     /with
 27 |     padding [char!]
 28 | ][
 29 |     padding: any [padding #"0"]
 30 |     text: form text
 31 |     skip tail insert/dup text padding length negate length
 32 | ]
 33 | 
 34 | pad-zone: func [
 35 |     time
 36 |     /flat
 37 | ][
 38 |     rejoin [
 39 |         pick "-+" time/hour < 0
 40 |         pad abs time/hour 2
 41 |         either flat [""][#":"]
 42 |         pad time/minute 2
 43 |     ]
 44 | ]
 45 | 
 46 | pad-precise: func [
 47 |     seconds [number!]
 48 |     /local out
 49 | ][
 50 |     seconds: form make time! seconds
 51 |     head change copy "00.000000" find/last/tail form seconds ":"
 52 | ]
 53 | 
 54 | to-epoch-time: func [
 55 |     date [date!]
 56 | ][
 57 |     ; date/time: date/time - date/zone
 58 |     date: form any [
 59 |         attempt [to integer! difference date 1-Jan-1970/0:0:0]
 60 |         date - 1-Jan-1970/0:0:0 * 86400.0
 61 |     ]
 62 | 
 63 |     clear find/last date "."
 64 |     date
 65 | ]
 66 | 
 67 | to-iso-week: use [get-iso-year][
 68 |     get-iso-year: func [
 69 |         year [integer!]
 70 |         /local d1 d2
 71 |     ][
 72 |         d1: to-date join "4-Jan-" year
 73 |         d2: to-date join "28-Dec-" year
 74 |         reduce [
 75 |             d1 + 1 - d1/weekday d2 + 7 - d2/weekday
 76 |         ]
 77 |     ]
 78 | 
 79 |     func [
 80 |         date [date!]
 81 |         /local out d1 d2
 82 |     ][
 83 |         out: [0 0]
 84 |         set [d1 d2] get-iso-year out/2: date/year
 85 | 
 86 |         case [
 87 |             date < d1 [
 88 |                 d1: first get-iso-year out/1: date/year - 1
 89 |             ]
 90 | 
 91 |             date > d2 [
 92 |                 d1: first get-iso-year out/2: date/year + 1
 93 |             ]
 94 |         ]
 95 | 
 96 |         out/1: to integer! date + 8 - date/weekday - d1 / 7
 97 |         out
 98 |     ]
 99 | ]
100 | 
101 | date-codes: [
102 |     #"a" [copy/part pick system/locale/days date/weekday 3]
103 |     #"A" [pick system/locale/days date/weekday]
104 |     #"b" [copy/part pick system/locale/months date/month 3]
105 |     #"B" [pick system/locale/months date/month]
106 |     #"C" [to integer! date/year / 100]
107 |     #"d" [pad date/day 2]
108 |     #"D" [
109 |         rejoin [
110 |             date/year #"-" pad date/month 2 #"-" pad date/day 2
111 |         ]
112 |     ]
113 |     #"e" [date/day]
114 |     #"g" [pad to integer! (second to-iso-week date) // 100 2]
115 |     #"G" [to integer! second to-iso-week date]
116 |     #"h" [time/hour + 11 // 12 + 1]
117 |     #"H" [pad time/hour 2]
118 |     #"i" [switch/default date/day [1 21 31 ["st"] 2 22 ["nd"] 3 23 ["rd"]]["th"]]
119 |     #"I" [pad time/hour + 11 // 12 + 1 2]
120 |     #"j" [pad date/julian 3]
121 |     #"J" [date/julian]
122 |     #"m" [pad date/month 2]
123 |     #"M" [pad time/minute 2]
124 |     #"p" [pick ["am" "pm"] time/hour < 12]
125 |     #"P" [pick ["AM" "PM"] time/hour < 12]
126 |     #"R" [pad time/hour 2 #":" pad time/minute 2]
127 |     #"s" [to-epoch-time date]
128 |     #"S" [pad to integer! time/second 2]
129 |     #"t" [#"^-"]
130 |     #"T" [
131 |         rejoin [
132 |             pad time/hour 2 #":" pad time/minute 2 #":" pad to integer! time/second 2
133 |         ]
134 |     ]
135 |     #"u" [date/weekday]
136 |     #"U" [pad to integer! date/julian + 6 - (date/weekday // 7) / 7 2]
137 |     #"V" [pad to integer! first to-iso-week date 2]
138 |     #"w" [date/weekday // 7]
139 |     #"W" [pad to integer! date/julian + 7 - date/weekday / 7 2]
140 |     #"x" [pad-precise time/second]
141 |     #"y" [pad date/year // 100 2]
142 |     #"Y" [date/year]
143 |     #"z" [pad-zone/flat zone]
144 |     #"Z" [pad-zone zone]
145 | 
146 |     #"c" [
147 |         rejoin [
148 |             date/year #"-" pad date/month 2 "-" pad date/day 2 "T"
149 |             pad time/hour 2 #":" pad time/minute 2 #":" pad to integer! time/second 2 
150 |             either utc ["Z"][pad-zone zone]
151 |         ]
152 |     ]
153 | ]
154 | 
155 | form-date: func [
156 |     "Renders a date to a given format"
157 | 
158 |     date [date!]
159 |     "Date to format"
160 | 
161 |     format [any-string!]
162 |     "Format (string largely compatible with strftime)"
163 | 
164 |     /utc
165 |     "Align time with UTC"
166 | 
167 |     /gmt
168 |     "To be deprecated"
169 | 
170 |     /local time zone
171 | ][
172 |     if all [gmt not system/options/quiet][
173 |         print "/GMT is to be deprecated, use /UTC"
174 |     ]
175 | 
176 |     utc: any [utc gmt]
177 | 
178 |     either date/time [
179 |         if date/zone [
180 |             date/time: date/time - date/zone
181 |         ]
182 | 
183 |         date/zone: either utc [
184 |             0:00
185 |         ][
186 |             date/zone
187 |         ]
188 | 
189 |         date/time: date/time + date/zone
190 |     ][
191 |         date/time: 0:00
192 |         date/zone: either utc [
193 |             0:00
194 |         ][
195 |             now/zone
196 |         ]
197 |     ]
198 | 
199 |     time: date/time
200 |     zone: date/zone
201 | 
202 |     reword/case/escape format bind date-codes 'date #"%"
203 | ]
204 | 
205 | form-time: func [
206 |     time [time!]
207 |     format [any-string!]
208 |     /local date zone
209 | ][
210 |     date: now/date
211 |     zone: 0:00
212 | 
213 |     reword/case/escape format bind date-codes 'time #"%"
214 | ]
215 | 


--------------------------------------------------------------------------------
/r3-alpha/jqm.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "jQuery Mobile Page Builder"
  3 |     Date: 30-Dec-2017
  4 |     Author: "Christopher Ross-Gill"
  5 |     ; Home: 'tbd
  6 |     File: %jqm.r3
  7 |     Version: 0.1.0
  8 |     Purpose: "Build JQuery Mobile pages for web apps."
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 | 
 11 |     Type: module
 12 |     Name: rgchris.jqm
 13 |     Exports: [
 14 |         build-jqm
 15 |     ]
 16 | 
 17 |     Needs: [
 18 |         %../r3-alpha/combine.r3
 19 |         %../r3-alpha/rsp.r3
 20 |     ]
 21 | 
 22 |     History: []
 23 | ]
 24 | 
 25 | |: newline
 26 | 
 27 | no-content: ""
 28 | 
 29 | section-builder: func [
 30 |     proto [block!]
 31 |     body [block!]
 32 | ][
 33 |     func [
 34 |         params [block! none!]
 35 |         content [string! block!]
 36 |         /local yield
 37 |     ] compose/only [
 38 |         params: make (make object! proto) any [:params []]
 39 |         yield: combine/with compose [(content)] newline
 40 |         combine bind (body) params  ; newline
 41 |     ]
 42 | ]
 43 | 
 44 | app: section-builder [
 45 |     title: "My App"
 46 |     style: none
 47 | ][
 48 |     <!DOCTYPE html> 
 49 |     | <html>
 50 |         | <head>
 51 |             | <meta charset="utf-8">
 52 |             | <title> :title </title>
 53 |             | <link rel="stylesheet" href="//code.jquery.com/mobile/1.4.5/jquery.mobile-1.4.5.min.css" />
 54 |             | <script src="//code.jquery.com/jquery-1.11.1.min.js"> </script>
 55 |             | <script src="//code.jquery.com/mobile/1.4.5/jquery.mobile-1.4.5.min.js"> </script>
 56 |             if style [
 57 |                 foreach value compose [(style)] [
 58 |                     switch/default type?/word style [
 59 |                         file! url! [
 60 |                             combine [
 61 |                                 | build-tag compose [
 62 |                                     link href (style) rel "stylesheet" type "text/css"
 63 |                                 ]
 64 |                             ]
 65 |                         ]
 66 | 
 67 |                         string! [
 68 |                             combine [
 69 |                                 | <style type="text/css">
 70 |                                 | sanitize trim/auto style
 71 |                                 | </style>
 72 |                             ]
 73 |                         ]
 74 |                     ][
 75 |                         no-content
 76 |                     ]
 77 |                 ]
 78 |             ]
 79 |         | </head> 
 80 |         | <body>
 81 |         | yield
 82 |         | </body>
 83 |     | </html>
 84 | ]
 85 | 
 86 | h4: section-builder [
 87 |     id:
 88 |     style: none
 89 | ][
 90 |     | build-tag [
 91 |         h4
 92 |         style (
 93 |             if style [
 94 |                 trim/lines copy :style
 95 |             ]
 96 |         )
 97 |         id :id
 98 |     ]
 99 |     yield
100 |     </h4>
101 | ]
102 | 
103 | page: section-builder [
104 |     title: "Page Title"
105 |     footer: []
106 |     id:
107 |     class:
108 |     style:
109 |     back: none
110 | ][
111 |     | build-tag [
112 |         div
113 |         data-role "page"
114 |         id :id
115 |         style (
116 |             if style [
117 |                 trim/lines copy :style
118 |             ]
119 |         )
120 |     ]
121 |         | <div data-role="header">
122 |             | <h1> :title </h1>
123 |             rejoin collect [
124 |                 if back [
125 |                     keep '|
126 |                     keep build-tag [
127 |                         a
128 |                         data-rel "back"
129 |                         href (
130 |                             mold form back
131 |                         )
132 |                     ]
133 |                     keep ["Back" </a>]
134 |                 ]
135 |             ]
136 |         | </div>
137 |         | <div role="main" class="ui-content">
138 |             yield
139 |         | </div>
140 |         | <div data-role="footer" data-position="fixed">
141 |             footer
142 |         | </div>
143 |     | </div>
144 | ]
145 | 
146 | build-jqm: func [
147 |     params [block!]
148 |     content [block!]
149 | ][
150 |     app bind params 'app bind content 'app
151 | ]
152 | 


--------------------------------------------------------------------------------
/r3-alpha/make-feed.r3:
--------------------------------------------------------------------------------
 1 | Rebol [
 2 |     Title: "Make Feed"
 3 |     Author: "Christopher Ross-Gill"
 4 |     Date: 12-Jun-2013
 5 |     File: %make-feed.r3
 6 |     Version: 1.0.0
 7 |     Purpose: "Create an Atom Feed."
 8 |     Needs: [
 9 |         %form-date.r3
10 |         %rsp.r3
11 |     ]
12 |     Usage: [
13 |         make-feed reduce [
14 |             make object! [
15 |                 Title: "Feed Name"
16 |                 ID: Home: http://www.example.com/
17 |                 Link: http://www.example.com/our.feed
18 |                 Subtitle: "Describes this Feed"
19 |                 Updated: none
20 |             ]
21 | 
22 |             make object! [
23 |                 Title: "Journal Éntry title...."
24 |                 ID: Link: http://www.example.com/some/page/or/other
25 |                 Author: "Somebody"
26 |                 Published: Modified: 30-Dec-2004/12:00-9:00
27 |                 Description: {Entry HTML goes here...}
28 |             ]
29 |         ]
30 |     ]
31 | ]
32 | 
33 | make-feed: use [feed.rsp entry.rsp][
34 |     feed.rsp: trim/auto {
35 |         <?xml version='1.0' encoding='UTF-8'?>
36 |         <feed xmlns='http://www.w3.org/2005/Atom'
37 |               xml:base='<%== header/home %>'
38 |               xml:lang='en-us'>
39 | 
40 |         <title><%== header/title %></title>
41 |         <id><%== header/id %></id>
42 |         <link href='<%== header/home %>' />
43 |         <link rel='self' href='<%== form header/link %>' />
44 |         <updated><%= form-date/gmt any [header/updated now] "%c" %></updated>
45 |         <subtitle><%== header/subtitle %></subtitle>
46 | 
47 |         <%= render-each entry feed entry.rsp %>
48 |         </feed>
49 |     }
50 | 
51 |     entry.rsp: trim/auto {
52 |         <entry>
53 |             <title><%== entry/title %></title>
54 |             <link href='<%= entry/link %>' />
55 |             <id><%== entry/id %></id>
56 |             <author><name><%== entry/author %></name></author>
57 |             <published><%= form-date/gmt entry/published "%c" %></published>
58 |             <updated><%= form-date/gmt entry/modified "%c" %></updated>
59 |             <content type='html'><%== entry/description %></content>
60 |         </entry>
61 |     }
62 | 
63 |     make-feed: func [feed [block!] /local header][
64 |         header: take feed: copy feed
65 |         render/with feed.rsp [header feed entry.rsp]
66 |     ]
67 | ]
68 | 


--------------------------------------------------------------------------------
/r3-alpha/match.r3:
--------------------------------------------------------------------------------
 1 | Rebol [
 2 |     Title: "Match"
 3 |     Date: 4-Aug-2008
 4 |     Author: "Christopher Ross-Gill"
 5 |     Home: http://www.ross-gill.com/page/Match
 6 |     File: %match.r3
 7 |     Version: 0.1.2
 8 |     Purpose: {Extract structured data from an unstructured block.}
 9 |     Rights: http://opensource.org/licenses/Apache-2.0
10 | 
11 |     Type: module
12 |     Name: rgchris.match
13 |     Exports: [
14 |         match
15 |     ]
16 | 
17 |     History: [
18 |         4-Aug-2008 0.1.2 "Ported to Rebol 3"
19 |     ]
20 | 
21 |     Notes: "Extracted from QuarterMaster"
22 | 
23 |     Usage: [
24 |         result: match ["Product" $12.99][
25 |             name: string!       ; requires a string value to be present, set to string value
26 |             price: some money!  ; requires one or more money values, set to block
27 |             place: opt url!     ; optional url value, set to url value or none
28 |         ]
29 |     ]
30 | ]
31 | 
32 | match: use [get-one get-some datatype raise][
33 |     datatype: [
34 |         'binary! | 'char! | 'date! | 'decimal! | 'email! | 'file! | 'get-word! |
35 |         'integer! | 'issue! | 'lit-path! | 'lit-word! | 'logic! | 'money! | 'none! |
36 |         'number! | 'pair! | 'paren! | 'path! | 'percent! | 'refinement! | 'set-path! |
37 |         'set-word! | 'string! | 'tag! | 'time! | 'tuple! | 'url! | 'word!
38 |     ]
39 | 
40 |     if system/version > 2.90.0 [throw: :do]
41 | 
42 |     raise: func [reason][throw make error! rejoin compose [(reason)]]
43 | 
44 |     get-one: func [source type /local out][
45 |         parse source [some [out: type to end break | skip]]
46 |         unless tail? out [take out]
47 |     ]
48 | 
49 |     get-some: func [source type /local rule pos out][
50 |         out: make block! length? source
51 |         parse source rule: [[pos: type (append out take pos) :pos | skip] opt rule]
52 |         unless empty? out [out]
53 |     ]
54 | 
55 |     func [
56 |         [catch]
57 |         source [block!] "Data source"
58 |         spec [block!] "Match specification"
59 |         /loose "Ignore unmatched values"
60 |         /local out val key required type
61 |     ][
62 |         source: copy source
63 |         remove-each item out: copy spec [not set-word? item]
64 |         out: context append out none
65 | 
66 |         unless parse spec [
67 |             some [
68 |                 set key set-word! (key: to-word key)
69 |                 set required ['opt | 'any | 'some | ]
70 |                 copy type [lit-word! any ['| lit-word!] | datatype any ['| datatype]]
71 |                 (
72 |                     switch/default required [
73 |                         any [val: any [get-some source type make block! 0]]
74 |                         opt [val: get-one source type]
75 |                         some [
76 |                             unless val: get-some source type [
77 |                                 do make error! reform ["Required:" key]
78 |                             ]
79 |                         ]
80 |                     ][
81 |                         unless val: get-one source type [
82 |                             do make error! reform ["Required:" key]
83 |                         ]
84 |                     ]
85 |                     out/(key): val
86 |                 )
87 |             ]
88 |         ][
89 |             do make error! "Invalid MATCH Spec"
90 |         ]
91 | 
92 |         either any [loose empty? source][out][
93 |             do make error! reform ["Too Many Options:" mold source]
94 |         ]
95 |     ]
96 | ]


--------------------------------------------------------------------------------
/r3-alpha/rest.r3:
--------------------------------------------------------------------------------
 1 | [
 2 | 
 3 | Rebol [
 4 | 	Title: "Service-oriented HTTP Protocol"
 5 | 	Author: "Christopher Ross-Gill"
 6 | 	Date: 24-Jul-2013
 7 | 	Home: http://ross-gill.com/page/REST_Protocol
 8 | 	File: %rest.r3
 9 | 	Version: 0.0.1
10 | 	Type: module
11 | 	Name: rgchris.rest
12 | 	Usage: [
13 | 		read [
14 | 			scheme: 'rest
15 | 			url: http://www.ross-gill.com/
16 | 		]
17 | 
18 | 		write [
19 | 			scheme: 'rest
20 | 			method: 'post
21 | 			type: 'webform
22 | 			url: http://somewhere-to-write/target
23 | 		][
24 | 			some data
25 | 		]
26 | 	]
27 | 	Notes: {
28 | 		Rebol 3 Alpha does not have a working CALL and thus this module as-is
29 | 		cannot sit upon the shell version of cURL.
30 | 	}
31 | ]
32 | 
33 | sys/make-scheme [
34 | 	Title: "Service-oriented HTTP Protocol"
35 | 	Name: 'rest
36 | 
37 | 	Actor: [
38 | 		open: funct [port][
39 | 			probe port/spec
40 | 		]
41 | 
42 | 		read: funct [port][
43 | 			open port
44 | 		]
45 | 	]
46 | ]
47 | 
48 | ]
49 | 


--------------------------------------------------------------------------------
/r3-alpha/rsp.r3:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "RSP Preprocessor"
  3 |     Date: 12-Jun-2013
  4 |     Author: "Christopher Ross-Gill"
  5 |     Home: http://ross-gill.com/page/RSP
  6 |     File: %rsp.r3
  7 |     Version: 0.4.1
  8 |     Purpose: {Rebol-embedded Markup}
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 | 
 11 |     Type: module
 12 |     Name: rgchris.rsp
 13 |     Exports: [
 14 |         sanitize build-tag load-rsp render render-each
 15 |     ]
 16 | 
 17 |     Notes: "Extracted from QuarterMaster"
 18 | ]
 19 | 
 20 | sanitize: use [
 21 |     ascii html* extended
 22 | ][
 23 |     ascii: charset ["^/^-" #"^(20)" - #"^(7E)"]
 24 |     html*: exclude ascii charset {&<>"}
 25 |     extended: complement charset [#"^(00)" - #"^(7F)"]
 26 | 
 27 |     func [
 28 |         text [any-string!]
 29 |         /local char
 30 |     ][
 31 |         parse form text [
 32 |             copy text any [
 33 |                 text: some html*
 34 |                 |
 35 |                 change #"<" "&lt;"
 36 |                 |
 37 |                 change #">" "&gt;"
 38 |                 |
 39 |                 change #"&" "&amp;"
 40 |                 |
 41 |                 change #"^"" "&quot;"
 42 |                 |
 43 |                 remove #"^M"
 44 |                 |
 45 |                 remove copy char extended
 46 |                 (
 47 |                     char: rejoin [
 48 |                         "&#" to integer! char/1 ";"
 49 |                     ]
 50 |                 )
 51 |                 insert char
 52 |                 |
 53 |                 change skip "&#65533;"
 54 |             ]
 55 |         ]
 56 | 
 57 |         any [
 58 |             text copy ""
 59 |         ]
 60 |     ]
 61 | ]
 62 | 
 63 | build-tag: use [
 64 |     to-name slash
 65 | ][
 66 |     to-name: func [
 67 |         name [word! path!]
 68 |     ][
 69 |         back replace/all next mold name "/" ":"
 70 |     ]
 71 | 
 72 |     slash: to lit-word! first [/]
 73 | 
 74 |     func [
 75 |         "Generates a tag from a composed block"
 76 | 
 77 |         values [block!]
 78 |         "Block of parens to evaluate and other data."
 79 | 
 80 |         /local tag has-value xml? name is-name value
 81 |     ][
 82 |         xml?: false
 83 | 
 84 |         tag: collect [
 85 |             is-name: [
 86 |                 word!
 87 |                 |
 88 |                 and path! into [
 89 |                     word! word!
 90 |                 ]
 91 |             ]
 92 | 
 93 |             has-value: [
 94 |                 [
 95 |                     set value [
 96 |                         get-word! | get-path! | paren!
 97 |                         |
 98 |                         'true | 'false | 'none
 99 |                     ]
100 |                     (value: take/last reduce reduce [value])
101 |                     |
102 |                     and not [
103 |                         slash | is-name
104 |                     ]
105 |                     set value skip
106 |                 ]
107 |                 (
108 |                     value: switch/default type?/word :value [
109 |                         string! url! email! [
110 |                             value
111 |                         ]
112 | 
113 |                         logic! none! [
114 |                             either :value [
115 |                                 name
116 |                             ][
117 |                                 none
118 |                             ]
119 |                         ]
120 | 
121 |                         binary! [
122 |                             enbase value
123 |                         ]
124 | 
125 |                         tag! [
126 |                             to string! value
127 |                         ]
128 | 
129 |                         file! [
130 |                             replace/all to string! value #" " "%20"
131 |                         ]
132 | 
133 |                         char! [
134 |                             form value
135 |                         ]
136 | 
137 |                         date! [
138 |                             ; form-date value "%c"
139 |                             form value
140 |                         ]
141 | 
142 |                         tuple! [
143 |                             rejoin [
144 |                                 "#" enbase/base to binary! value 16
145 |                             ]
146 |                         ]
147 | 
148 |                         issue! integer! decimal! money! time! percent! [
149 |                             mold value
150 |                         ]
151 | 
152 |                         lit-word! [
153 |                             form value
154 |                         ]
155 |                     ][
156 |                         none
157 |                     ]
158 |                 )
159 |             ]
160 | 
161 |             parse values [
162 |                 set name [
163 |                     '?xml
164 |                     (xml?: true)
165 |                     |
166 |                     is-name
167 |                 ]
168 |                 (keep to-name name)
169 | 
170 |                 any [
171 |                     slash end
172 |                     (
173 |                         keep either xml? ["?"] [" /"]
174 |                         xml?: false
175 |                     )
176 |                     |
177 |                     set name is-name
178 |                     [
179 |                         has-value
180 |                         (
181 |                             if value [
182 |                                 keep rejoin [
183 |                                     " " to-name name {="} sanitize form value {"}
184 |                                 ]
185 |                             ]
186 |                         )
187 |                         |
188 |                         (
189 |                             keep " "
190 |                             keep to-name name
191 |                         )
192 |                     ]
193 |                 ]
194 |                 end (
195 |                     if xml? [
196 |                         keep "?"
197 |                     ]
198 |                 )
199 |                 |
200 |                 and set name path! into [
201 |                     none! word! opt word!
202 |                 ]
203 |                 to end
204 |                 (keep to-name name)
205 |                 |
206 |                 end
207 |                 (tag: [])
208 |             ]
209 |         ]
210 | 
211 |         to tag! rejoin tag
212 |     ]
213 | ]
214 | 
215 | load-rsp: use [
216 |     prototype to-set-block
217 | ][
218 |     prototype: make object! [
219 |         out*: ""
220 | 
221 |         prin: func [val] [
222 |             repend out* val
223 |         ]
224 | 
225 |         print: func [val] [
226 |             prin val prin newline
227 |         ]
228 |     ]
229 | 
230 |     to-set-block: func [
231 |         block [block! object!]
232 |         /local word
233 |     ][
234 |         either object? block [
235 |             block: third block
236 |         ][
237 |             parse copy block [
238 |                 (block: copy [])
239 |                 any [
240 |                     set word word!
241 |                     (
242 |                         repend block [
243 |                             to-set-word word
244 |                             get/any word
245 |                         ]
246 |                     )
247 |                 ]
248 |             ]
249 |         ]
250 | 
251 |         block
252 |     ]
253 | 
254 |     func [
255 |         body [string!]
256 |         /local code part
257 |     ][
258 |         code: make string! length? body
259 | 
260 |         append code "^/out*: make string! {}^/"
261 | 
262 |         parse body [
263 |             any [
264 |                 end
265 |                 (append code "out*")
266 |                 break
267 |                 |
268 |                 "<%" [
269 |                     "==" copy part to "%>"
270 |                     (
271 |                         repend code [
272 |                             "prin sanitize form (" part "^/)^/"
273 |                         ]
274 |                     )
275 |                     |
276 |                     "=" copy part to "%>"
277 |                     (
278 |                         repend code [
279 |                             "prin (" part "^/)^/"
280 |                         ]
281 |                     )
282 |                     |
283 |                     [#":" | #"!"]
284 |                     copy part to "%>"
285 |                     (
286 |                         repend code [
287 |                             "prin build-tag [" part "^/]^/"
288 |                         ]
289 |                     )
290 |                     |
291 |                     #"#" to "%>"  ; comment
292 |                     |
293 |                     copy part to "%>"
294 |                     (
295 |                         repend code [
296 |                             part newline
297 |                         ]
298 |                     )
299 |                     |
300 |                     (throw make error! "Expected '%>'")
301 |                 ]
302 | 
303 |                 2 skip
304 |                 |
305 |                 copy part [
306 |                     to "<%"
307 |                     |
308 |                     to end
309 |                 ]
310 |                 (
311 |                     repend code [
312 |                         "prin " mold part "^/"
313 |                     ]
314 |                 )
315 |             ]
316 |         ]
317 | 
318 |         func [
319 |             args [block! object!]
320 |         ] compose/only [
321 |             args: make prototype to-set-block args
322 |             do bind/copy (load code) args
323 |         ]
324 |     ]
325 | ]
326 | 
327 | render: use [depth*] [
328 |     depth*: 0  ; -- to break recursion
329 | 
330 |     func [
331 |         rsp [file! url! string!]
332 |         /with
333 |         locals [block! object!]
334 |     ][
335 |         if depth* > 20 [
336 |             return ""
337 |         ]
338 | 
339 |         depth*: depth* + 1
340 | 
341 |         rsp: case/all [
342 |             file? rsp [
343 |                 rsp: read rsp
344 |             ]
345 | 
346 |             url? rsp [
347 |                 rsp: read rsp
348 |             ]
349 | 
350 |             binary? rsp [
351 |                 rsp: to string! rsp
352 |             ]
353 | 
354 |             string? rsp [
355 |                 rsp: load-rsp rsp
356 | 
357 |                 rsp any [
358 |                     locals []
359 |                 ]
360 |             ]
361 |         ]
362 | 
363 |         depth*: depth* - 1
364 | 
365 |         rsp
366 |     ]
367 | ]
368 | 
369 | render-each: func [
370 |     'items [word! block!]
371 |     source [series!]
372 |     body [file! url! string!]
373 |     /with locals [object! block!]
374 | ][
375 |     locals: collect [
376 |         switch type?/word locals [
377 |             object! [
378 |                 keep words-of locals
379 |             ]
380 | 
381 |             block! [
382 |                 keep locals
383 |             ]
384 |         ]
385 | 
386 |         keep items
387 |     ]
388 | 
389 |     rejoin collect [
390 |         foreach :items source compose/only [
391 |             keep render/with body (locals)
392 |         ]
393 |     ]
394 | ]
395 | 


--------------------------------------------------------------------------------
/r3-alpha/uuid.r3:
--------------------------------------------------------------------------------
 1 | Rebol [
 2 |     Title: "UUID Generator"
 3 |     Date: 6-Jan-2022
 4 |     File: %uuid.r3
 5 |     Version: 1.0.0
 6 | 
 7 |     Type: module
 8 |     Name: rgchris.uuid
 9 |     Exports: [
10 |         uuid
11 |     ]
12 | ]
13 | 
14 | uuid: make object! [
15 |     generate: func [
16 |         "Generates a Version 4 UUID that is compliant with RFC 4122"
17 |     ][
18 |         random/seed now/precise
19 | 
20 |         collect [
21 |             loop 16 [
22 |                 keep -1 + random/secure 256
23 |             ]
24 |         ]
25 |     ]
26 | 
27 |     to-text: func [
28 |         uuid
29 |     ][
30 |         uuid/7: uuid/7 and 15 or 64
31 |         uuid/9: uuid/9 and 63 or 128
32 | 
33 |         uuid: enbase to binary! uuid 16
34 | 
35 |         uuid: insert skip uuid 8 "-"
36 |         uuid: insert skip uuid 4 "-"
37 |         uuid: insert skip uuid 4 "-"
38 |         uuid: insert skip uuid 4 "-"
39 |         head uuid
40 |     ]
41 | ]
42 | 


--------------------------------------------------------------------------------
/rebol-2/curl.r:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "cURL"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 15-Jan-2017
  5 |     File: %curl.r
  6 |     Version: 0.1.4
  7 |     Needs: [2.7.7 shell]
  8 |     Purpose: "Rebol wrapper for cURL command."
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: 'module
 11 |     Name: 'rgchris.curl
 12 |     Exports: [curl]
 13 |     History: [
 14 |         15-Jan-2017 0.1.4 "Fix /BINARY mode"
 15 |         15-Jan-2017 0.1.3 "Added /LEGACY Refinement; Binary Uploads"
 16 |         21-Oct-2012 0.1.2 "First Published Version"
 17 |     ]
 18 |     Notes: [
 19 |         "cURL Home Page" http://curl.haxx.se/
 20 |     ]
 21 | ]
 22 | 
 23 | curl: use [user-agent form-headers enquote curl-location] [
 24 |     if not exists? curl-location: %/usr/local/opt/curl/bin/curl [
 25 |         call/wait/output "which curl" curl-location: make string! 0
 26 |         curl-location: to file! trim/tail curl-location
 27 |     ]
 28 | 
 29 |     user-agent: reform ["Rebol" system/product system/version]
 30 | 
 31 |     enquote: func [
 32 |         data [block! any-string!]
 33 |         /local mark
 34 |     ][
 35 |         mark: switch/default system/version/4 [3 [{"}]] ["'"]
 36 |         rejoin compose [mark (data) mark]
 37 |     ]
 38 | 
 39 |     form-headers: func [headers [block! object!] /local out] [
 40 |         collect [
 41 |             foreach [header value] switch type?/word headers [
 42 |                 block! [headers]
 43 |                 object! [body-of headers]
 44 |             ][
 45 |                 if value [
 46 |                     keep rejoin [" -H " enquote [form header ": " value]]
 47 |                 ]
 48 |             ]
 49 |         ]
 50 |     ]
 51 | 
 52 |     curl: func [
 53 |         "Wrapper for the cURL shell function"
 54 |         [catch]
 55 |         url [url!] "URL to Retrieve"
 56 |         /method "Specify HTTP request method"
 57 |         verb [word! string! none!] "HTTP request method"
 58 |         /with "Include request body"
 59 |         data [string! binary! file! none!] "Request body"
 60 |         /header "Specify HTTP headers"
 61 |         headers [block! object! none!] "HTTP headers"
 62 |         /as "Specify user agent"
 63 |         agent [string!] "User agent"
 64 |         /user "Provide User Credentials"
 65 |         name [string! none!] "User Name"
 66 |         pass [string! none!] "User Password"
 67 |         /full "Include HTTP headers in response"
 68 |         /binary "Receive response as binary"
 69 |         /follow "Follow HTTP redirects"
 70 |         /fail "Return none! on 4xx/5xx HTTP responses"
 71 |         /secure "Disallow 'insecure' SSL transactions"
 72 |         /into "Specify result string"
 73 |         out [string! none!] "String to contain result"
 74 |         /error "Specify error string"
 75 |         err [string! none!] "String to contain error"
 76 |         /timeout "Specify a time limit"
 77 |         time [time! none!] "Time limit"
 78 |         /legacy "Use HTTP/1.0"
 79 |         /local command code
 80 |     ][
 81 |         out: any [out copy ""]
 82 |         err: any [err copy ""]
 83 | 
 84 |         command: rejoin collect [
 85 |             keep form curl-location
 86 |             
 87 |             keep " -s"
 88 | 
 89 |             case/all [
 90 |                 legacy [keep "0"]
 91 |                 full [keep "i"]
 92 |                 fail [keep "f"]
 93 |                 not secure [keep "k"]
 94 |                 follow [keep "L"]
 95 |                 verb [keep " -X " keep verb: uppercase form verb]
 96 |                 time [keep " -m " keep to integer! time]
 97 |                 data [
 98 |                     either file? data [
 99 |                         keep reduce [" --data-binary @" form data]
100 |                         data: ""
101 |                     ][
102 |                         keep " --data-binary @-"
103 |                     ]
104 |                 ]
105 |                 all [name pass] [keep " -u " keep enquote [name ":" pass]]
106 |                 headers [keep form-headers headers]
107 |             ]
108 | 
109 |             keep reduce [
110 |                 " -A " enquote any [agent user-agent]
111 |             ]
112 | 
113 |             keep reduce [" " enquote url]
114 |         ]
115 | 
116 |         data: as-string any [data ""]
117 | 
118 |         code: call/wait/input/output/error command data out err
119 | 
120 |         net-utils/net-log [to word! any [verb "GET"] url]
121 |         net-utils/net-log command
122 |         net-utils/net-log reform ["cURL Response Code:" code]
123 | 
124 |         switch/default code [
125 |             0 18 [either binary [as-binary out] [out]]
126 |             1 [
127 |                 if empty? trim/head/tail err [
128 |                     err: "Unsupported protocol. This build of curl has no support for this protocol."
129 |                 ]
130 |                 throw make error! :err
131 |             ]
132 |             2 [throw make error! "Failed to initialize."]
133 |             3 [throw make error! "URL malformed. The syntax was not correct."]
134 |             4 [throw make error! "Feature not included in this cURL build."]
135 |             6 [throw make error! "Couldn't resolve host. The given remote host was not resolved."]
136 |             7 [throw make error! "Failed to connect to host."]
137 |             22 [none]
138 |             28 [throw make error! "Request timed out."]
139 |             50 [throw make error! "OS shell error."]
140 |             52 [throw make error! "The server didn't reply anything."]
141 |             56 [throw make error! "Failure with receiving network data."]
142 |         ][
143 |             code: reform ["cURL Error Code" code trim/head/tail err]
144 |             throw make error! code
145 |         ]
146 |     ]
147 | ]
148 | 


--------------------------------------------------------------------------------
/rebol-2/do-with.r:
--------------------------------------------------------------------------------
 1 | Rebol [
 2 |     Title: "Do-With"
 3 |     Date: 12-Jan-2022
 4 |     Author: "Christopher Ross-Gill"
 5 |     Home: https://github.com/rgchris/Scripts/
 6 |     File: %do-with.r
 7 |     Version: 0.1.0
 8 |     Rights: http://opensource.org/licenses/Apache-2.0
 9 |     Purpose: {
10 |         Create a context for evaluating a block of code suitable
11 |         for accumulating values (similar in concept to COLLECT/KEEP)
12 |     }
13 | 
14 |     Type: 'module
15 |     Name: 'rgchris.do-with
16 |     Exports: [
17 |         reduce-only do-with
18 |     ]
19 | 
20 |     History: [
21 |         12-Jan-2022 0.1.0 "Created module"
22 |     ]
23 | 
24 |     Comment: {
25 |         Such functionality could be useful in Core
26 |     }
27 | ]
28 | 
29 | reduce-only: func [
30 |     "Evaluates a block of expressions excepting SET-WORD! values"
31 | 
32 |     block [block!]
33 |     "Block to evaluate"
34 | 
35 |     /local value
36 | ][
37 |     collect [
38 |         while [
39 |             not tail? block
40 |         ][
41 |             either set-word? first block [
42 |                 keep first block
43 |                 block: next block
44 |             ][
45 |                 set [value block] do/next block
46 |                 keep/only :value
47 |             ]
48 |         ]
49 |     ]
50 | ]
51 | 
52 | do-with: func [
53 |     "Evaluate a block with a collection of context-sensitive functions"
54 | 
55 |     body [block!]
56 |     "Block to evaluate"
57 | 
58 |     context [block!]
59 |     "Specification for the context-sensitive functions"
60 | 
61 |     /local
62 |     args
63 | ][
64 |     context: reduce-only context
65 | 
66 |     args: collect [
67 |         foreach [name value] context [
68 |             keep to lit-word! name
69 |         ]
70 |     ]
71 | 
72 |     do collect [
73 |         keep func args copy/deep body
74 | 
75 |         foreach [name value] context [
76 |             keep :value
77 |         ] 
78 |     ]
79 | ]
80 | 


--------------------------------------------------------------------------------
/rebol-2/match.r:
--------------------------------------------------------------------------------
 1 | REBOL [
 2 | 	Title: "Match"
 3 | 	Author: "Christopher Ross-Gill"
 4 | 	Date: 4-Aug-2008
 5 | 	Purpose: {Extract structured data from an unstructured block.}
 6 | 	Version: 0.1.2
 7 | 	Home: http://www.ross-gill.com/page/Match
 8 | 	Usage: [
 9 | 		result: match ["Product" $12.99][
10 | 			name: string!       ; requires a string value to be present, set to string value
11 | 			price: some money!  ; requires one or more money values, set to block
12 | 			place: opt url!     ; optional url value, set to url value or none
13 | 		]
14 | 	]
15 | ]
16 | 
17 | match: use [get-one get-some datatype raise][
18 | 	datatype: [
19 | 		'binary! | 'char! | 'date! | 'decimal! | 'email! | 'file! | 'get-word! |
20 | 		'integer! | 'issue! | 'lit-path! | 'lit-word! | 'logic! | 'money! | 'none! |
21 | 		'number! | 'pair! | 'paren! | 'path! | 'range! | 'refinement! | 'set-path! |
22 | 		'set-word! | 'string! | 'tag! | 'time! | 'tuple! | 'url! | 'word!
23 | 	]
24 | 
25 | 	if system/version > 2.90.0 [throw: :do]
26 | 
27 | 	raise: func [reason][throw make error! rejoin compose [(reason)]]
28 | 
29 | 	get-one: func [source type /local out][
30 | 		parse source [some [out: type to end break | skip]]
31 | 		unless tail? out [take out]
32 | 	]
33 | 
34 | 	get-some: func [source type /local rule pos out][
35 | 		out: make block! length? source
36 | 		parse source rule: [[pos: type (append out take pos) :pos | skip] opt rule]
37 | 		unless empty? out [out]
38 | 	]
39 | 
40 | 	func [
41 | 		[catch]
42 | 		source [block!] "Data source"
43 | 		spec [block!] "Match specification"
44 | 		/loose "Ignore unmatched values"
45 | 		/local out val key required type
46 | 	][
47 | 		source: copy source
48 | 		remove-each item out: copy spec [not set-word? item]
49 | 		out: context append out none
50 | 
51 | 		unless parse spec [
52 | 			some [
53 | 				set key set-word! (key: to-word key)
54 | 				set required ['opt | 'any | 'some | ]
55 | 				copy type [lit-word! any ['| lit-word!] | datatype any ['| datatype]]
56 | 				(
57 | 					switch/default required [
58 | 						any [val: any [get-some source type make block! 0]]
59 | 						opt [val: get-one source type]
60 | 						some [
61 | 							unless val: get-some source type [
62 | 								raise rejoin ["Required: " form key]
63 | 							]
64 | 						]
65 | 					][
66 | 						unless val: get-one source type [
67 | 							raise rejoin ["Required: " form key]
68 | 						]
69 | 					]
70 | 					out/(key): val
71 | 				)
72 | 			]
73 | 		][raise "Invalid MATCH Spec"]
74 | 
75 | 		either any [loose empty? source][out][
76 | 			raise rejoin ["Too Many Options: " mold source]
77 | 		]
78 | 	]
79 | ]


--------------------------------------------------------------------------------
/rebol-2/metadb.r:
--------------------------------------------------------------------------------
 1 | REBOL [
 2 | 	Title: "MetaStore"
 3 | 	Author: "Christopher Ross-Gill"
 4 | 	Version: 1.0.0
 5 | 	Date: 18-Mar-2010
 6 | 	Purpose: "Quick associative database"
 7 | 	Comment: {Extracted from QuarterMaster project.}
 8 | 	Usage: [
 9 | 		write meta/Subject/key "Value"
10 | 		read meta/Subject/key
11 | 		read meta/Subject
12 | 		write meta/(probe "Subject")/key "Value"
13 | 	]
14 | 	Folder: %/My/DB/Target/
15 | ]
16 | 
17 | meta: use [root meta with url-encode load-spec][
18 | 	root: any [
19 | 		system/script/args
20 | 		system/script/header/folder
21 | 	]
22 | 
23 | 	assert/type [root file!]
24 | 	
25 | 	with: func [object [any-word! object! port!] block [any-block!] /only][
26 | 		block: bind block object
27 | 		either only [block] :block
28 | 	]
29 | 
30 | 	url-encode: use [ch sp][
31 | 		ch: charset ["-." #"0" - #"9" #"A" - #"Z" #"-" #"a" - #"z" #"~"]
32 | 
33 | 		func [text [any-string!] /wiki][
34 | 			sp: either wiki ["_"]["+"]
35 | 
36 | 			either parse/all copy to-binary text [
37 | 				copy text any [
38 | 					text: some ch | end | change #" " sp |
39 | 					if (wiki) change #"_" "%5F" | #"_" |
40 | 					(text: join "%" back back tail to-hex text/1 16)
41 | 					change skip text
42 | 				]
43 | 			][to-string text][""]
44 | 		]
45 | 	]
46 | 
47 | 	load-spec: func [spec [object!]][
48 | 		all with/only spec [
49 | 			url? ref
50 | 			spec: find/tail ref meta
51 | 			spec: parse/all spec "/" ; to be 'split
52 | 			parse spec [
53 | 				set host string!
54 | 				(host: join lowercase url-encode/wiki host %.r)
55 | 				set path opt string!
56 | 				(path: all [path to-word path])
57 | 			]
58 | 		]
59 | 	]
60 | 
61 | 	sys/make-scheme [
62 | 		name: 'meta
63 | 		title: "Mini-MetaDB"
64 | 
65 | 		actor: [
66 | 			open: func [port][
67 | 				port/locals: any [
68 | 					all [
69 | 						load-spec port/spec
70 | 						attempt [load root/(port/spec/host)]
71 | 					]
72 | 					copy []
73 | 				]
74 | 			]
75 | 
76 | 			read: func [port][
77 | 				open port
78 | 				either port/spec/path [
79 | 					select port/locals port/spec/path
80 | 				][
81 | 					port/locals
82 | 				]
83 | 			]
84 | 
85 | 			write: func [port value][
86 | 				open port
87 | 				with port [
88 | 					remove-each [key val] locals [key = spec/path]
89 | 					if all [spec/path value][repend locals [spec/path value]]
90 | 					new-line/all/skip locals true 2
91 | 					save/all root/(spec/host) locals
92 | 				]
93 | 			]
94 | 		]
95 | 	]
96 | 
97 | 	meta: meta://
98 | ]
99 | 


--------------------------------------------------------------------------------
/red/clean.red:
--------------------------------------------------------------------------------
 1 | Red [
 2 | 	Title: "Clean"
 3 | 	Author: "Christopher Ross-Gill"
 4 | 	Date: 18-Jul-2017
 5 | 	File: %clean.red
 6 | 	Version: 0.1.2
 7 | 	Purpose: "Converts errant CP-1252 codepoints within a UTF-8 binary"
 8 | 	Rights: http://opensource.org/licenses/Apache-2.0
 9 | 	Type: module
10 | 	Name: rgchris.clean
11 | 	Exports: [clean]
12 | 	History: [
13 | 		18-Jul-2017 0.1.2 "Red Version"
14 | 		14-Aug-2013 0.1.1 "Working Version"
15 | 	]
16 | ]
17 | 
18 | rgchris.clean: context [
19 | 	codepoints: #(
20 | 		; CP-1252 specific range
21 | 		128 #{E282AC} 130 #{E2809A} 131 #{C692} 132 #{E2809E} 133 #{E280A6} 134 #{E280A0}
22 | 		135 #{E280A1} 136 #{CB86} 137 #{E280B0} 138 #{C5A0} 139 #{E280B9} 140 #{C592}
23 | 		142 #{C5BD} 145 #{E28098} 146 #{E28099} 147 #{E2809C} 148 #{E2809D} 149 #{E280A2}
24 | 		150 #{E28093} 151 #{E28094} 152 #{CB9C} 153 #{E284A2} 154 #{C5A1} 155 #{E280BA}
25 | 		156 #{C593} 158 #{C5BE}
26 | 	)
27 | 
28 | 	ascii: charset [#"^(00)" - #"^(7F)"]
29 | 	utf-2: charset [#"^(C2)" - #"^(DF)"]
30 | 	utf-3: charset [#"^(E0)" - #"^(EF)"]
31 | 	utf-4: charset [#"^(F0)" - #"^(F4)"]
32 | 	utf-b: charset [#"^(80)" - #"^(BF)"]
33 | 
34 | 	here: none
35 | 
36 | 	cleaner: [
37 | 		ascii
38 | 		  ; simplistic representation of UTF-8
39 | 		| utf-2 utf-b | utf-3 2 utf-b | utf-4 3 utf-b
40 | 		| change here: skip (
41 | 			case [
42 | 				codepoints/(here/1) [codepoints/(here/1)]
43 | 				here/1 > 191 [reduce [#{C3} here/1 and 191]]
44 | 				here/1 > 158 [reduce [#{C2} here/1]]
45 | 				/else [#{EFBFBD}]
46 | 			]
47 | 		)
48 | 	]
49 | 
50 | 	clean: func [
51 | 		"Converts errant CP-1252 codepoints within a UTF-8 binary"
52 | 		string [binary!] "Binary to convert"
53 | 	][
54 | 		parse string [any cleaner]
55 | 		to string! string
56 | 	]
57 | ]
58 | 
59 | clean: get in rgchris.clean 'clean


--------------------------------------------------------------------------------
/red/color-code.red:
--------------------------------------------------------------------------------
  1 | Red [
  2 | 	Title: "Color Code"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 5-Nov-2017
  5 | 	Home: https://github.com/rgchris/Scripts
  6 | 	File: %color-code.red
  7 | 	Version: 2.1.2
  8 | 	Purpose: {Colorize Red source code}
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	History: [
 11 | 		05-Nov-2017 2.2.0 "First Red version" "Christopher Ross-Gill"
 12 | 		23-Oct-2009 2.1.0 "Rewritten as QM module." "Christopher Ross-Gill"
 13 | 		29-May-2003 1.0.0 "Fixed deep parse rule bug." "Carl Sassenrath"
 14 | 	]
 15 | 	Comment: {
 16 | 		Result is HTML <pre> block.
 17 | 		Sample CSS: http://reb4.me/s/rebol.css
 18 | 	}
 19 | ]
 20 | 
 21 | #macro ['use set locals block!] func [s e][
 22 | 	reduce [
 23 | 		make function! [
 24 | 			[locals [object!] body [block!]]
 25 | 			[do bind body locals]
 26 | 		]
 27 | 		make object! collect [
 28 | 			forall locals [keep to set-word! locals/1]
 29 | 			keep none
 30 | 		]
 31 | 	]
 32 | ]
 33 | 
 34 | sanitize: use [html*][
 35 | 	html*: exclude charset ["^/^-" #"^(20)" - #"^(7E)"] charset {&<>"}
 36 | 
 37 | 	sanitize: func [text [string!]][
 38 | 		also text: copy text parse text [
 39 | 			any [
 40 | 				some html*
 41 | 				| change #"&" ("&amp;")
 42 | 				| change #"<" ("&lt;")
 43 | 				| change #">" ("&gt;")
 44 | 				| change #"^"" ("&quot;")
 45 | 				| remove #"^M"
 46 | 				| text: change skip (rejoin ["&#" to integer! text/1 ";"])
 47 | 			]
 48 | 		]
 49 | 	]
 50 | ]
 51 | 
 52 | color-code: use [delim mark-up values][
 53 | 	delim: charset "^-^/^M ])"
 54 | 
 55 | 	mark-up: func [value [any-type!] from mark /local type part][
 56 | 		either none? :value [type: "cmt"][
 57 | 			if path? :value [value: first :value]
 58 | 
 59 | 			type: case [
 60 | 				find [Red Rebol Topaz Freebell World] :value ["lang"]
 61 | 				not word? :value [replace form type? :value "!" ""]
 62 | 				not value? :value [none] ; could be "word" ?
 63 | 				any-function? get :value ["function"]
 64 | 				datatype? get :value ["datatype"]
 65 | 				value ["word"]
 66 | 			]
 67 | 		]
 68 | 
 69 | 		part: sanitize copy/part from mark
 70 | 
 71 | 		either type [
 72 | 			rejoin [{<var class="dt-} type {">} part {</var>}]
 73 | 		][
 74 | 			part
 75 | 		]
 76 | 	]
 77 | 
 78 | 	values: use [value mark here rule][
 79 | 		rule: [
 80 | 			some [
 81 | 				  mark: some [" " | "^-"] here: keep (
 82 | 					replace/all copy/part mark here "^-" "    "
 83 | 				)
 84 | 				| [crlf | newline] keep ("^/")
 85 | 				| #";" [to newline | to end] here: keep (
 86 | 					mark-up none mark here
 87 | 				)
 88 | 				| keep [opt #"#" [#"[" | #"("]] rule
 89 | 				| keep [#"]" | #")"] break
 90 | 				| skip keep (
 91 | 					if error? value: try [load/next mark 'here][
 92 | 						here: any [
 93 | 							find mark delim
 94 | 							tail mark
 95 | 						]
 96 | 					]
 97 | 					mark-up :value mark here
 98 | 				) :here
 99 | 			]
100 | 		]
101 | 
102 | 		[
103 | 			collect [rule [end | mark: to end keep (sanitize mark)]]
104 | 		]
105 | 	]
106 | 
107 | 	func [
108 | 		[catch] "Return color source code as HTML."
109 | 		text [string!] "Source code text"
110 | 	][
111 | 		rejoin collect [
112 | 			keep {<pre class="code rebol">}
113 | 			keep parse text values
114 | 			keep {</pre>}
115 | 		]
116 | 	]
117 | ]
118 | 


--------------------------------------------------------------------------------
/red/form-date.red:
--------------------------------------------------------------------------------
  1 | Red [
  2 |     Title: "Date Formatter for Red"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 10-Jul-2017
  5 |     Home: http://scripts.rebol.info/scripts/form-date,docs
  6 |     File: %form-date.red
  7 |     Version: 1.1.1
  8 |     Purpose: "Return formatted date string using strftime style format specifiers"
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: 'module
 11 |     Name: 'rgchris.form-date
 12 |     Exports: [form-date form-time]
 13 |     History: [
 14 |         10-Jul-2017 1.1.1 "Ported to Red"
 15 |         06-Sep-2015 1.1.0 "Reviewed for Publication"
 16 |         12-Jun-2013 1.0.0 "Ported from Rebol 2 to Rebol 3"
 17 |     ]
 18 |     Comment: {Extracted from the QuarterMaster web framework}
 19 | ]
 20 | 
 21 | form-date: make object! [
 22 |     interpolate: func [body [string!] escapes [block!] /local out][
 23 |         body: out: copy body
 24 | 
 25 |         parse body [
 26 |             any [
 27 |                 to #"%" body: (
 28 |                     body: change/part body reduce any [
 29 |                         select/case escapes body/2 body/2
 30 |                     ] 2
 31 |                 ) :body
 32 |             ]
 33 |         ]
 34 | 
 35 |         out
 36 |     ]
 37 | 
 38 |     pad: func [text length [integer!] /with padding [char!]][
 39 |         padding: any [padding #"0"]
 40 |         text: form text
 41 |         skip tail insert/dup text padding length negate length
 42 |     ]
 43 | 
 44 |     pad-zone: func [time /flat][
 45 |         rejoin [
 46 |             pick "-+" time/hour < 0
 47 |             pad absolute time/hour 2
 48 |             either flat [""][#":"]
 49 |             pad time/minute 2
 50 |         ]
 51 |     ]
 52 | 
 53 |     pad-precise: func [second /local point] [
 54 |         second: form second
 55 |         unless point: find second "." [insert point: tail second "."]
 56 |         second: pad copy/part second point 2
 57 |         point: head change copy ".000000" point
 58 |         rejoin [second point]
 59 |     ]
 60 | 
 61 |     date-codes: [
 62 |         "The abbreviated weekday name according to the current locale"
 63 |         #"a" [copy/part pick system/locale/days date/weekday 3]
 64 | 
 65 |         "The full weekday name according to the current locale"
 66 |         #"A" [pick system/locale/days date/weekday]
 67 | 
 68 |         "The abbreviated month name according to the current locale"
 69 |         #"b" [copy/part pick system/locale/months date/month 3]
 70 | 
 71 |         "The full month name according to the current locale"
 72 |         #"B" [pick system/locale/months date/month]
 73 | 
 74 |         "The century number (year/100) as a 2-digit integer"
 75 |         #"C" [to integer! date/year / 100]
 76 | 
 77 |         "The day of the month as a number (range 01 to 31)"
 78 |         #"d" [pad date/day 2]
 79 | 
 80 |         "Equivalent to '%m/%d/%Y'"
 81 |         #"D" [pad date/month 2 #"/" pad date/day 2 #"/" date/year]
 82 | 
 83 |         "The day of the month as a number, without padding"
 84 |         #"e" [date/day]
 85 | 
 86 |         "Equivalent to '%Y-%m-%d'"
 87 |         #"F" [date/year #"-" pad date/month 2 #"-" pad date/day 2]
 88 | 
 89 |         "The ISO 8601 year as a number [needs review]"
 90 |         #"g" [pad date/year 2] ; for review
 91 | 
 92 |         "The ISO 8601 year without century as a number [needs review]"
 93 |         #"G" [date/year] ; for review
 94 | 
 95 |         "The hour as a number using a 12-hour clock (range 1 to 12)"
 96 |         #"h" [time/hour + 11 // 12 + 1]
 97 | 
 98 |         "The hour as a 2-digit number using a 24-hour clock (range 00 to 23)"
 99 |         #"H" [pad time/hour 2]
100 | 
101 |         "The english suffix for numeric day value, 'st' for 01, 'th' for 04"
102 |         #"i" [switch/default date/day [1 21 31 ["st"] 2 22 ["nd"] 3 23 ["rd"]]["th"]]
103 | 
104 |         "The hour as a 2-digit number using a 12-hour clock (range 01 to 12)"
105 |         #"I" [pad time/hour + 11 // 12 + 1 2]
106 | 
107 |         "The day of the year as a number (range 001 to 366)"
108 |         #"j" [pad date/julian 3]
109 | 
110 |         "The day of the year as a number without padding (range 1 to 366)"
111 |         #"J" [date/julian]
112 | 
113 |         "The month as a 2-digit number (range 01 to 12)"
114 |         #"m" [pad date/month 2]
115 | 
116 |         "The minute as a 2-digit number (range 00 to 59)"
117 |         #"M" [pad time/minute 2]
118 | 
119 |         "Either 'AM' or 'PM' according to the given time value. Noon is treated as 'PM' and midnight as 'AM'"
120 |         #"p" [pick ["AM" "PM"] time/hour < 12]
121 | 
122 |         "Either 'am' or 'pm' according to the given time value. Noon is treated as 'pm' and midnight as 'am'"
123 |         #"P" [pick ["am" "pm"] time/hour < 12]
124 | 
125 |         "Equivalent to '%h:%M:%S %p'"
126 |         #"r" [
127 |             pad time/hour + 11 // 12 + 1 2
128 |             #":" pad time/minute 2 #":" pad to integer! time/second 2
129 |             #" " pick ["AM" "PM"] time/hour < 12
130 |         ]
131 | 
132 |         "Equivalent to '%H:%M'"
133 |         #"R" [pad time/hour 2 #":" pad time/minute 2]
134 | 
135 |         "The number of seconds since the Epoch, 1970-01-01 00:00:00 +0000 (UTC)"
136 |         #"s" [to integer! date]
137 | 
138 |         "The second as a 2-digit number (range 00 to 60)"
139 |         #"S" [pad to integer! time/second 2]
140 | 
141 |         "Tab character"
142 |         #"t" [#"^-"]
143 | 
144 |         "Equivalent to '%H:%M:%S'"
145 |         #"T" [pad time/hour 2 #":" pad time/minute 2 #":" pad to integer! time/second 2]
146 | 
147 |         "The day of the week as a number (range 1 to 7, Monday being 1). See also %w"
148 |         #"u" [date/weekday]
149 | 
150 |         "The week number of the current year as a 2-digit number (range 00 to 53, starting with the first Sunday as the first day of week 01)"
151 |         #"U" [pad to integer! date/julian + 6 - (date/weekday // 7) / 7 2]
152 | 
153 |         "The ISO 8601 week number of the current year as a 2-digit decimal number (range 01 to 53, where week 1 is the first week that has at least 4 days in the new year) [needs review]"
154 |         #"V" [pad date/isoweek 2] ; for review
155 | 
156 |         "The day of the week as a number (range 0 to 6, Sunday being 0). See also %u"
157 |         #"w" [date/weekday // 7]
158 | 
159 |         "The week number of the current year as a 2-digit number (range 00 to 53, starting with the first Monday as the first day of week 01)"
160 |         #"W" [pad to integer! date/julian + 7 - date/weekday / 7 2]
161 | 
162 |         "The second as a decimal number 00-60 with Red nanosecond precision, a period followed by 6 digits"
163 |         #"x" [pad-precise time/second]
164 | 
165 |         "The year as a 2-digit number without a century (range 00 to 99)"
166 |         #"y" [pad date/year // 100 2]
167 | 
168 |         "The year as a number (range 0 to maximum supported)"
169 |         #"Y" [date/year]
170 | 
171 |         "The time-zone as hour offset from UTC (without a ':' separator)"
172 |         #"z" [pad-zone/flat zone]
173 | 
174 |         "The time-zone as hour offset from UTC"
175 |         #"Z" [pad-zone zone]
176 | 
177 |         "RFC3339 Date Stamp"
178 |         #"c" [
179 |             date/year #"-" pad date/month 2 #"-" pad date/day 2 #"T"
180 |             pad time/hour 2 #":" pad time/minute 2 #":" pad to integer! time/second 2 
181 |             either utc [#"Z"][pad-zone zone]
182 |         ]
183 |     ]
184 | 
185 |     description: rejoin collect [
186 |         keep "Formats a date to a given specification (similar to STRFTIME). Possible codes:"
187 |         while [not tail? date-codes][
188 |             keep reduce ["^/        %" date-codes/2 "  " take date-codes]
189 |             date-codes: skip date-codes 2
190 |         ]
191 |     ]
192 | 
193 |     date-codes: head date-codes
194 | 
195 |     form-date: func compose [
196 |         (description)
197 |         date [date!] "Date to Format"
198 |         format [any-string!] "Target format (see description above)"
199 |         /utc "Convert the date to UTC prior to formatting"
200 |         /local time zone
201 |     ][
202 |         either date/time [
203 |             if utc [date/timezone: 0]
204 |         ][
205 |             date/time: 0:00
206 |             date/zone: either utc [0:00][now/zone]
207 |         ]
208 | 
209 |         time: date/time
210 |         zone: date/zone
211 |         interpolate format bind date-codes 'date
212 |     ]
213 | 
214 |     form-time: func [time [time!] format [any-string!] /local date zone][
215 |         date: now/date zone: 0:00
216 |         interpolate format bind date-codes 'time
217 |     ]
218 | ]
219 | 
220 | form-time: get in form-date 'form-time
221 | form-date: get in form-date 'form-date


--------------------------------------------------------------------------------
/red/rsp.red:
--------------------------------------------------------------------------------
  1 | Red [
  2 |     Title: "RSP Preprocessor"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 25-Jan-2020
  5 |     Home: http://ross-gill.com/page/RSP
  6 |     File: %rsp.red
  7 |     Version: 0.5.0
  8 |     Purpose: {Red-embedded Markup}
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: module
 11 |     Name: rgchris.rsp
 12 |     Exports: [sanitize load-rsp render render-each]
 13 |     History: [
 14 |         25-Jan-2020 0.5.0 "Renovated BUILD-TAG function, fix PATH! namespaced tag/attribute name handling"
 15 |         25-Jan-2019 0.4.3 "Red Late 2018 Changes"
 16 |     ]
 17 |     Notes: "Extracted from QuarterMaster"
 18 | ]
 19 | 
 20 | sanitize: func [text [any-string!] /local mark] bind [
 21 |     either parse text: form text [
 22 |         copy text any [
 23 |             some safe | change #"&" "&amp;" | change #"<" "&lt;" | change #">" "&gt;"
 24 |             | change #"^"" "&quot;" | change #"'" "&apos;" | remove #"^M"
 25 |             | change mark: extended (char: rejoin ["&#" to integer! mark/1 ";"])
 26 |             | change skip "&#65533;"
 27 |         ]
 28 |     ][
 29 |         text
 30 |     ][
 31 |         make string! 0
 32 |     ]
 33 | ]
 34 |     make object! [
 35 |         safe: exclude ascii: charset ["^/^-" #"^(20)" - #"^(7E)"] charset {&<>"}
 36 |         extended: complement charset [#"^(00)" - #"^(7F)"]
 37 |     ]
 38 | 
 39 | build-tag: func [
 40 |     "Generates a tag from a composed block."
 41 |     values [block!] "Block of parens to evaluate and other data."
 42 |     /local to-name tag is-name has-value name value xml?
 43 | ][
 44 |     to-name: func [name [word! path! set-word! set-path!]][
 45 |         name: mold name
 46 |         replace name ":" ""
 47 |         replace/all name "/" ":"
 48 |     ]
 49 | 
 50 |     xml?: false
 51 | 
 52 |     tag: collect [
 53 |         is-name: [
 54 |             word! | ahead path! into [2 word!]
 55 |         ]
 56 | 
 57 |         has-value: [
 58 |             [
 59 |                 set value [get-word! | get-path! | paren!] (
 60 |                     value: do reduce reduce [value]
 61 |                 )
 62 |                 |
 63 |                 ahead word! set value ['true | 'false | 'none] (value: get value)
 64 |                 |
 65 |                 set value [
 66 |                     any-string! | logic! | char! | lit-word! | word! | issue!
 67 |                     |
 68 |                     number! | date! | time! | tuple! ; | money!
 69 |                 ]
 70 |             ]
 71 |             (
 72 |                 value: switch type?/word :value [
 73 |                     string! url! email! [value]
 74 |                     logic! none! [either :value [name][none]]
 75 |                     binary! [enbase value]
 76 |                     tag! [to string! value]
 77 |                     file! [replace/all form value #" " "%20"]
 78 |                     char! [form value]
 79 |                     date! [
 80 |                         ; form-date value "%c"
 81 |                         form value
 82 |                     ]
 83 |                     tuple! [mold as-color value/1 value/2 value/3]
 84 |                     issue! integer! float! percent! money! time! [mold value]
 85 |                     word! lit-word! [to string! value]
 86 |                 ]
 87 |             )
 88 |         ]
 89 | 
 90 |         parse values [
 91 |             set name ['?xml (xml?: true) | is-name] (
 92 |                 keep to-name name
 93 |             )
 94 |             any [
 95 |                 '/ end (
 96 |                     keep either xml? ["?"]["/"]
 97 |                     xml?: false
 98 |                 )
 99 |                 |
100 |                 set name [is-name | set-word!] [
101 |                     has-value (
102 |                         if value [
103 |                             keep rejoin [
104 |                                 " " to-name name {="} sanitize form value {"}
105 |                             ]
106 |                         ]
107 |                     )
108 |                     |
109 |                     (
110 |                         keep " "
111 |                         keep to-name name
112 |                     )
113 |                 ]
114 |             ]
115 |             end (
116 |                 if xml? [keep "?"]
117 |             )
118 |             |
119 |             [set name refinement! to end (tag: mold name)]
120 |         ]
121 |     ]
122 | 
123 |     if tag: rejoin tag [to tag! tag]
124 | ]
125 | 
126 | load-rsp: func [body [string!] /local code mark return: [function!]] bind [
127 |     code: rejoin collect [
128 |         keep rejoin ["^/out*: make string! " length? body "^/"]
129 |         parse body [
130 |             any [
131 |                 end (keep "^/out*") break
132 |                 |
133 |                 "<%" [
134 |                     "==" copy mark to "%>" (
135 |                         keep rejoin ["prin sanitize form (" mark "^/)^/"]
136 |                     )
137 |                     |
138 |                     "=" copy mark to "%>" (
139 |                         keep rejoin ["prin (" mark "^/)^/"]
140 |                     )
141 |                     |
142 |                     [#":" | #"!"] copy mark to "%>" (
143 |                         keep rejoin ["prin build-tag [" mark "^/]^/"]
144 |                     )
145 |                     |
146 |                     #"#" to "%>" ; comment
147 |                     |
148 |                     copy mark to "%>" (keep rejoin [mark newline])
149 |                     |
150 |                     (
151 |                         do make error! "Expected '%>'"
152 |                     )
153 |                 ] 2 skip
154 |                 | copy mark [to "<%" | to end] (
155 |                     keep rejoin ["prin " mold mark "^/"]
156 |                 )
157 |             ]
158 |         ]
159 |     ]
160 | 
161 |     func [args [block! object!]] compose/only [
162 |         args: make prototype to-set-block args
163 |         do bind/copy (load code) args
164 |     ]
165 | ]
166 |     make object! [
167 |         prototype: context [
168 |             out*: none prin: func [val][append reduce out* val]
169 |             print: func [val][prin val prin newline]
170 |         ]
171 | 
172 |         to-set-block: func [locals [block! object!] /local word][
173 |             case [
174 |                 object? locals [
175 |                     body-of locals
176 |                 ]
177 | 
178 |                 block? locals [
179 |                     collect [
180 |                         parse locals [
181 |                             any [
182 |                                 set word word! (
183 |                                     keep reduce [to set-word! word get :word]
184 |                                 )
185 |                             ]
186 |                         ]
187 |                     ]
188 |                 ]
189 |             ]
190 |         ]
191 |     ]
192 | 
193 | render: func [
194 |     rsp [file! url! string!]
195 |     /with locals [block! object!]
196 | ] bind [
197 |     if depth* > 20 [return ""]
198 |     depth*: depth* + 1
199 | 
200 |     rsp: case/all [
201 |         file? rsp [rsp: read rsp]
202 |         url? rsp [rsp: read rsp]
203 |         binary? rsp [rsp: to string! rsp]
204 |         string? rsp [
205 |             rsp: load-rsp rsp
206 |             rsp any [:locals []]
207 |         ]
208 |     ]
209 | 
210 |     depth*: depth* - 1
211 |     rsp
212 | ]
213 |     make object! [
214 |         depth*: 0
215 |     ]
216 | 
217 | render-each: func [
218 |     'items [word! block!]
219 |     source [series!]
220 |     body [file! url! string!]
221 |     /with locals /local out
222 | ][
223 |     locals: append any [locals []] items: compose [(items)]
224 |     rejoin collect [
225 |         foreach :items source compose/only [
226 |             append out render/with body (locals)
227 |         ]
228 |     ]
229 | ]
230 | 


--------------------------------------------------------------------------------
/red/simplediff.red:
--------------------------------------------------------------------------------
  1 | Red [
  2 | 	Title: "SimpleDiff"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 25-Aug-2016
  5 | 	Home: https://github.com/paulgb/simplediff
  6 | 	File: %simplediff.red
  7 | 	Version: 1.1.0
  8 | 	Purpose: "Identify the differences between two series"
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	Type: module
 11 | 	Name: rgchris.simplediff
 12 | 	Exports: [diff]
 13 | 	Comment: {
 14 | 		Based on Simple Diff for Python, CoffeeScript v0.1
 15 | 		(C) Paul Butler 2008 <http://www.paulbutler.org/>
 16 | 	}
 17 | 	History: [
 18 | 		25-Aug-2016 1.1.0 "Tweaked to be compatible with Ren/C and Red"
 19 | 		22-May-2014 1.0.0 "Original Version"
 20 | 	]
 21 | 	Usage: [
 22 | 		probe diff probe [a b c d]   probe [b c d e]
 23 | 		probe diff probe [a b c d]   probe [e f g h d]
 24 | 		probe diff probe [a b c d]   probe [e f g h]
 25 | 		probe diff probe [A B c D]   probe [a b c d]
 26 | 		probe diff probe ["A" "B" "c" "D"]   probe ["a" "b" "c" "d"]
 27 | 		probe diff probe [a b b b c] probe [a b b b b c]
 28 | 		probe diff
 29 | 			probe parse "you might say that, I couldn't possibly comment" none
 30 | 			probe parse "You may wish to say that, couldn't possibly comment either way." none
 31 | 	]
 32 | ]
 33 | 
 34 | diff: func [
 35 | 	{
 36 | 		Find the differences between two blocks. Returns a block of pairs, where the first value
 37 | 		is in [+ - =] and represents an insertion, deletion, or no change for that list.
 38 | 		The second value of the pair is the element.
 39 | 	}
 40 | 	before [block! string!] after [block! string!]
 41 | 	/local items-before starts-before starts-after run this-run test tests limit
 42 | ][
 43 | 	unless all [equal? type? before type? after][
 44 | 		make error! "Before and After values must be of the same type."
 45 | 	]
 46 | 
 47 | 	run: 0
 48 | 
 49 | 	; Build a map with elements from 'before as keys, and
 50 | 	; each position starting with each element as values.
 51 | 	items-before: make map! 0
 52 | 
 53 | 	forall before [
 54 | 		append/only any [
 55 | 			select items-before first before
 56 | 			put items-before first before make block! 0
 57 | 		] before
 58 | 	]
 59 | 
 60 | 	; Find the largest subseries common to before and after
 61 | 	forall after [
 62 | 		if tests: select items-before first after [
 63 | 			limit: length? after
 64 | 
 65 | 			foreach test tests [
 66 | 				repeat offset min limit length? test [
 67 | 					this-run: :offset
 68 | 					unless test/:offset == after/:offset [
 69 | 						this-run: offset - 1
 70 | 						break
 71 | 					]
 72 | 				]
 73 | 
 74 | 				if this-run > run [
 75 | 					run: :this-run
 76 | 					starts-before: :test
 77 | 					starts-after: :after
 78 | 				]
 79 | 			]
 80 | 		]
 81 | 	]
 82 | 
 83 | 	new-line/all/skip collect [
 84 | 		either zero? run [
 85 | 			; If no common subseries is found, assume that an
 86 | 			; insert and delete has taken place
 87 | 
 88 | 			unless tail? before [keep reduce ['- before]]
 89 | 			unless tail? after [keep reduce ['+ after]]
 90 | 		][
 91 | 			; Otherwise he common subseries is considered to have no change, and we
 92 | 			; recurse on the text before and after the substring
 93 | 
 94 | 			keep diff copy/part before starts-before copy/part after starts-after
 95 | 			keep reduce ['= copy/part starts-after run]
 96 | 			keep diff copy skip starts-before run copy skip starts-after run
 97 | 		]
 98 | 	] true 2
 99 | ]
100 | 


--------------------------------------------------------------------------------
/ren-c/altjson.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 | 	Title: "JSON Parser for Rebol 3"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 18-Sep-2015
  5 | 	Home: http://www.ross-gill.com/page/JSON_and_Rebol
  6 | 	File: %altjson.reb
  7 | 	Version: 0.3.6.1
  8 | 	Purpose: "Convert a Rebol block to/from a JSON string"
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	Type: module
 11 | 	Name: rgchris.altjson
 12 | 	Exports: [load-json to-json]
 13 | 	History: [
 14 | 		25-Feb-2017 0.3.6.1 "Ren-C Compatibilities"
 15 | 		18-Sep-2015 0.3.6 "Non-Word keys loaded as strings"
 16 | 		17-Sep-2015 0.3.5 "Added GET-PATH! lookup"
 17 | 		16-Sep-2015 0.3.4 "Reinstate /FLAT refinement"
 18 | 		21-Apr-2015 0.3.3 {
 19 | 			- Merge from Reb4.me version
 20 | 			- Recognise set-word pairs as objects
 21 | 			- Use map! as the default object type
 22 | 			- Serialize dates in RFC 3339 form
 23 | 		}
 24 | 		14-Mar-2015 0.3.2 "Converts Json input to string before parsing"
 25 | 		07-Jul-2014 0.3.0 "Initial support for JSONP"
 26 | 		15-Jul-2011 0.2.6 "Flattens Flickr '_content' objects"
 27 | 		02-Dec-2010 0.2.5 "Support for time! added"
 28 | 		28-Aug-2010 0.2.4 "Encodes tag! any-type! paired blocks as an object"
 29 | 		06-Aug-2010 0.2.2 "Issue! composed of digits encoded as integers"
 30 | 		22-May-2005 0.1.0 "Original Version"
 31 | 	]
 32 | 	Comment: {
 33 | 		- Converts date! to RFC 3339 Date String
 34 | 	}
 35 | ]
 36 | 
 37 | load-json: use [
 38 | 	tree branch here val is-flat emit new-child to-parent neaten word to-word
 39 | 	space comma number string block object _content value ident
 40 | ][
 41 | 	branch: make block! 10
 42 | 
 43 | 	emit: func [val][here: insert/only here val]
 44 | 	new-child: [(insert/only branch insert/only here here: make block! 10)]
 45 | 	to-parent: [(here: take branch)]
 46 | 	neaten: [
 47 | 		(new-line/all head here true)
 48 | 		(new-line/all/skip head here true 2)
 49 | 	]
 50 | 
 51 | 	to-word: use [word1 word+][
 52 | 		; upper ranges borrowed from AltXML
 53 | 		word1: charset [
 54 | 			"!&*=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
 55 | 			#"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
 56 | 			#"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
 57 | 			#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
 58 | 			#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
 59 | 		]
 60 | 
 61 | 		word+: charset [
 62 | 			"!&'*+-.0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
 63 | 			#"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
 64 | 			#"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
 65 | 			#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
 66 | 			#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
 67 | 		]
 68 | 
 69 | 		func [val [string!]][
 70 | 			all [
 71 | 				parse val [word1 any word+]
 72 | 				to word! val
 73 | 			]
 74 | 		]
 75 | 	]
 76 | 
 77 | 	space: use [space][
 78 | 		space: charset " ^-^/^M"
 79 | 		[any space]
 80 | 	]
 81 | 
 82 | 	comma: [space #"," space]
 83 | 
 84 | 	number: use [dg ex nm as-num][
 85 | 		dg: charset "0123456789"
 86 | 		ex: [[#"e" | #"E"] opt [#"+" | #"-"] some dg]
 87 | 		nm: [opt #"-" some dg opt [#"." some dg] opt ex]
 88 | 
 89 | 		as-num: func [val [string!]][
 90 | 			case [
 91 | 				not parse val [opt "-" some dg][to decimal! val]
 92 | 				not integer? try [val: to integer! val][to issue! val]
 93 | 				val [val]
 94 | 			]
 95 | 		]
 96 | 
 97 | 		[copy val nm (val: as-num val)]
 98 | 	]
 99 | 
100 | 	string: use [ch es hx mp decode][
101 | 		ch: complement charset {\"}
102 | 		es: charset {"\/bfnrt}
103 | 		hx: charset "0123456789ABCDEFabcdef"
104 | 		mp: [#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-"]
105 | 
106 | 		decode: use [ch mk escape][
107 | 			escape: [
108 | 				; should be possible to use CHANGE keyword to replace escaped characters.
109 | 				mk: #"\" [
110 | 					es (mk: change/part mk select mp mk/2 2)
111 | 					|
112 | 					#"u" copy ch 4 hx (
113 | 						mk: change/part mk to char! to-integer/unsigned debase/base ch 16 6
114 | 					)
115 | 				] :mk
116 | 			]
117 | 
118 | 			func [text [string! blank!]][
119 | 				either blank? text [make string! 0][
120 | 					all [parse text [any [to "\" escape] to end] text]
121 | 				]
122 | 			]
123 | 		]
124 | 
125 | 		[#"^"" copy val [any [some ch | #"\" [#"u" 4 hx | es]]] #"^"" (val: decode val)]
126 | 	]
127 | 
128 | 	block: use [list][
129 | 		list: [space opt [value any [comma value]] space]
130 | 
131 | 		[#"[" new-child list #"]" neaten/1 to-parent]
132 | 	]
133 | 
134 | 	_content: [#"{" space {"_content"} space #":" space value space "}"] ; Flickr
135 | 
136 | 	object: use [name list as-map][
137 | 		name: [
138 | 			string space #":" space (
139 | 				emit either is-flat [
140 | 					to tag! val
141 | 				][
142 | 					any [
143 | 						to-word val
144 | 						lock val
145 | 					]
146 | 				]
147 | 			)
148 | 		]
149 | 		list: [space opt [name value any [comma name value]] space]
150 | 		as-map: [(unless is-flat [here: change back here make map! pick back here 1])]
151 | 
152 | 		[#"{" new-child list #"}" neaten/2 to-parent as-map]
153 | 	]
154 | 
155 | 	ident: use [initial ident][
156 | 		initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
157 | 		ident: union initial charset [#"0" - #"9"]
158 | 
159 | 		[initial any ident]
160 | 	]
161 | 
162 | 	value: [
163 | 		  "null" (emit _)
164 | 		| "true" (emit true)
165 | 		| "false" (emit false)
166 | 		| number (emit val)
167 | 		| string (emit val)
168 | 		| _content
169 | 		| object | block
170 | 	]
171 | 
172 | 	func [
173 | 		"Convert a JSON string to Rebol data"
174 | 		json [string! binary! file! url!] "JSON string"
175 | 		/flat "Objects are imported as tag-value pairs"
176 | 		/padded "Loads JSON data wrapped in a JSONP envelope"
177 | 	][
178 | 		case/all [
179 | 			any [file? json url? json][
180 | 				if error? json: try [read/string (json)][
181 | 					do :json
182 | 				]
183 | 			]
184 | 			binary? json [json: to string! json]
185 | 		]
186 | 
187 | 		is-flat: :flat
188 | 		tree: here: make block! 0
189 | 
190 | 		either parse json either padded [
191 | 			[space ident space "(" space opt value space ")" opt ";" space]
192 | 		][
193 | 			[space opt value space]
194 | 		][
195 | 			pick tree 1
196 | 		][
197 | 			do make error! "Not a valid JSON string"
198 | 		]
199 | 	]
200 | ]
201 | 
202 | to-json: use [
203 | 	json emit emits escape emit-issue emit-date
204 | 	here lookup comma block object block-of-pairs value
205 | ][
206 | 	emit: func [data][repend json data]
207 | 	emits: func [data][emit {"} emit data emit {"}]
208 | 
209 | 	escape: use [mp ch encode][
210 | 		mp: [#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/"]
211 | 		ch: intersect ch: charset [#" " - #"~"] difference ch charset extract mp 2
212 | 
213 | 		encode: func [here][
214 | 			change/part here any [
215 | 				select mp here/1
216 | 				rejoin ["\u" skip tail form to-hex to integer! here/1 -4]
217 | 			] 1
218 | 		]
219 | 
220 | 		func [txt][
221 | 			parse txt [any [txt: some ch | skip (txt: encode txt) :txt]]
222 | 			head txt
223 | 		]
224 | 	]
225 | 
226 | 	emit-issue: use [dg nm mk][
227 | 		dg: charset "0123456789"
228 | 		nm: [opt "-" some dg]
229 | 
230 | 		[(either parse next form here/1 [copy mk nm][emit mk][emits here/1])]
231 | 	]
232 | 
233 | 	emit-date: use [pad second][
234 | 		pad: func [part length][part: to string! part head insert/dup part "0" length - length? part]
235 | 
236 | 		quote (
237 | 			emits rejoin collect [
238 | 				keep reduce [pad here/1/year 4 "-" pad here/1/month 2 "-" pad here/1/day 2]
239 | 				if here/1/time [
240 | 					keep reduce ["T" pad here/1/hour 2 ":" pad here/1/minute 2 ":"]
241 | 					keep either integer? here/1/second [
242 | 						pad here/1/second 2
243 | 					][
244 | 						second: split to string! here/1/second "."
245 | 						reduce [pad second/1 2 "." second/2]
246 | 					]
247 | 					keep either any [
248 | 						blank? here/1/zone
249 | 						zero? here/1/zone
250 | 					]["Z"][
251 | 						reduce [
252 | 							either here/1/zone/hour < 0 ["-"]["+"]
253 | 							pad abs here/1/zone/hour 2 ":" pad here/1/zone/minute 2
254 | 						]
255 | 					]
256 | 				]
257 | 			]
258 | 		)
259 | 	]
260 | 
261 | 	lookup: [
262 | 		here: [get-word! | get-path!]
263 | 		(change here reduce reduce [here/1])
264 | 		fail
265 | 	]
266 | 
267 | 	comma: [(if not tail? here [emit ","])]
268 | 
269 | 	block: [
270 | 		(emit "[") any [here: value here: comma] (emit "]")
271 | 	]
272 | 
273 | 	block-of-pairs: [
274 | 		  some [set-word! skip]
275 | 		| some [tag! skip]
276 | 	]
277 | 
278 | 	object: [
279 | 		(emit "{")
280 | 		any [
281 | 			here: [set-word! (change here to word! here/1) | any-string! | any-word!]
282 | 			(emit [{"} escape to string! here/1 {":}])
283 | 			here: value here: comma
284 | 		]
285 | 		(emit "}")
286 | 	]
287 | 
288 | 	value: [
289 | 		  lookup ; resolve a GET-WORD! reference
290 | 		| number! (emit here/1)
291 | 		| [logic! | 'true | 'false] (emit to string! here/1)
292 | 		| [blank! | 'none | 'blank] (emit quote 'null)
293 | 		| date! emit-date
294 | 		| issue! emit-issue
295 | 		| [
296 | 			any-string! | word! | lit-word! | tuple! | pair! | money! | time!
297 | 		] (emits escape form here/1)
298 | 		| any-word! (emits escape form to word! here/1)
299 | 
300 | 		| [object! | map!] :here (change/only here body-of first here) into object
301 | 		| into block-of-pairs :here (change/only here copy first here) into object
302 | 		| any-block! :here (change/only here copy first here) into block
303 | 
304 | 		| any-type! (emits to tag! type-of first here)
305 | 	]
306 | 
307 | 	func [data][
308 | 		json: make string! 1024
309 | 		if parse compose/only [(data)][here: value][json]
310 | 	]
311 | ]
312 | 


--------------------------------------------------------------------------------
/ren-c/altwebform.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 | 	Title: "Web Form Encoder/Decoder for Rebol 3"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 14-Jul-2017
  5 | 	Home: http://www.ross-gill.com/page/Web_Forms_and_Rebol
  6 | 	File: %altwebform.reb
  7 | 	Version: 0.10.4
  8 | 	Purpose: "Convert a Rebol block to/from a URL-Encoded Web Form string"
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	Type: module
 11 | 	Name: rgchris.altwebform
 12 | 	Exports: [url-decode url-encode load-webform to-webform]
 13 | 	History: [
 14 | 		14-Jul-2017 0.10.4 "Raise error if input block is invalid"
 15 | 		14-May-2017 0.10.2 "Ren-C changes"
 16 | 		06-Sep-2015 0.10.1 "Add Ruby-style paths to encoding"
 17 | 		06-Jul-2013  0.9.5 "Fix encoding/decoding of _ character"
 18 | 		01-Mar-2013  0.9.4 "Detach URL-DECODE and URL-ENCODE"
 19 | 		27-Feb-2013  0.9.2 "Correct encoding of UTF-8 values"
 20 | 		18-Nov-2009  0.1.0 "Original Version"
 21 | 	]
 22 | 	Usage: [
 23 | 		load-webform "a=3&aa.a=1&b.c=1&b.c=2"
 24 | 		to-webform [a "3" aa [a "1"] b [c ["1" "2"]]]
 25 | 	]
 26 | ]
 27 | 
 28 | url-decode: use [as-is hex space][
 29 | 	as-is: charset ["-.~" #"0" - #"9" #"A" - #"Z" #"a" - #"z"]
 30 | 	hex: charset [#"0" - #"9" #"a" - #"f" #"A" - #"F"]
 31 | 
 32 | 	func [
 33 | 		"Decode percent-encoded text from URLs and Web Forms"
 34 | 		text [any-string!] "Text to Decode"
 35 | 		/wiki "Assumes `_` character is used to represent spaces"
 36 | 	][
 37 | 		space: either wiki [#"_"][#"+"]
 38 | 		either parse text: to binary! text [
 39 | 			copy text any [
 40 | 				  some as-is | remove space insert " "
 41 | 				| [#"_" | #"+" | #"." | #","]
 42 | 				| change "%0D%0A" "^/" ; de-crlf
 43 | 				| remove ["%" copy text 2 hex] (text: debase/base text 16) insert text
 44 | 			]
 45 | 		][to string! text][_]
 46 | 	]
 47 | ]
 48 | 
 49 | url-encode: use [as-is space percent-encode][
 50 | 	as-is: charset ["-." #"0" - #"9" #"A" - #"Z" #"-" #"a" - #"z" #"~"]
 51 | 	percent-encode: func [text][
 52 | 		insert next text enbase/base copy/part text 1 16 change text "%"
 53 | 	]
 54 | 
 55 | 	func [
 56 | 		"Encode text using percent-encoding for URLs and Web Forms"
 57 | 		text [any-string!] "Text to encode"
 58 | 		/wiki "Use `_` character to represent spaces"
 59 | 	][
 60 | 		space: either wiki [#"_"][#"+"]
 61 | 		either parse text: to binary! text [
 62 | 			copy text any [
 63 | 				  text: some as-is | end | change " " space
 64 | 				| [#"_" | #"."] (either wiki [percent-encode text][text])
 65 | 				| skip (percent-encode text)
 66 | 			]
 67 | 		][to string! text][""]
 68 | 	]
 69 | ]
 70 | 
 71 | load-webform: use [result path string pair as-path term][
 72 | 	result: copy []
 73 | 
 74 | 	as-path: func [name [string!]][
 75 | 		to path! to block! replace/all name #"." #" "
 76 | 	]
 77 | 
 78 | 	path: use [aa an wd][
 79 | 		aa: charset [#"a" - #"z" #"A" - #"Z" #"_"]
 80 | 		an: charset [#"-" #"0" - #"9" #"a" - #"z" #"A" - #"Z" #"_"]
 81 | 		wd: [aa 0 40 an] ; one alpha, any alpha/numeric/dash/underscore
 82 | 		[wd 0 6 [#"." wd]]
 83 | 	]
 84 | 
 85 | 	string: use [ch hx][
 86 | 		ch: charset ["-._~" #"0" - #"9" #"A" - #"Z" #"a" - #"z"]
 87 | 		hx: charset [#"0" - #"9" #"a" - #"f" #"A" - #"F"]
 88 | 		[any [ch | #"+" | #"%" 2 hx]] ; any [unreserved | percent-encoded]
 89 | 	]
 90 | 
 91 | 	term: [#"&" | end]
 92 | 
 93 | 	pair: use [name value tree][
 94 | 		[
 95 | 			copy name path [
 96 | 				#"=" copy value string term | term (value: _)
 97 | 			] (
 98 | 				tree: :result
 99 | 				name: as-path name
100 | 				value: url-decode value
101 | 
102 | 				loop-until [
103 | 					tree: any [
104 | 						find/tail tree name/1
105 | 						insert tail tree name/1
106 | 					]
107 | 
108 | 					name: next name
109 | 
110 | 					switch to word! type-of pick tree 1 [
111 | 						blank! [unless tail? name [insert/only tree tree: copy []]]
112 | 						string! [change/only tree tree: reduce [tree/1]]
113 | 						block! [tree: tree/1]
114 | 					]
115 | 
116 | 					if tail? name [append tree value]
117 | 				]
118 | 			)
119 | 		]
120 | 	]
121 | 
122 | 	func [
123 | 		"Loads data from a URL-Encoded Web Form string"
124 | 		webform [string! blank!] "Form to decode"
125 | 	][
126 | 		webform: any [webform copy ""]
127 | 		result: make block! 0
128 | 
129 | 		case [
130 | 			parse webform [opt [#"&" | #"?"] any pair][
131 | 				result
132 | 			]
133 | 			
134 | 			/else [
135 | 				do make error! "Not a URL-Encoded Web Form"
136 | 			]
137 | 		]
138 | 	]
139 | ]
140 | 
141 | to-webform: use [
142 | 	webform form-key emit ruby-style?
143 | 	here path reference value block array object
144 | ][
145 | 	path: copy []
146 | 	form-key: does [
147 | 		url-encode rejoin collect [
148 | 			keep first path
149 | 			foreach key next path [
150 | 				keep reduce either ruby-style? [["[" key "]"]][["." key]]
151 | 			]
152 | 		]
153 | 	]
154 | 
155 | 	emit: func [data][
156 | 		repend webform ["&" form-key "=" url-encode data]
157 | 	]
158 | 
159 | 	reference: [
160 | 		some [
161 | 			here: get-word!
162 | 			(change/only here get here/1)
163 | 			| skip
164 | 		]
165 | 	]
166 | 
167 | 	value: [
168 | 		  here: number! (emit form here/1)
169 | 		| [logic! | 'true | 'false] (emit form here/1)
170 | 		| [blank! | '_]
171 | 		| date! (replace form date "/" "T")
172 | 		| [any-string! | tuple! | money! | time! | pair! | issue!] (emit form here/1)
173 | 	]
174 | 
175 | 	array: [and opt reference any value end]
176 | 
177 | 	object: [
178 | 		and opt reference any [
179 | 			here: [word! | set-word!] (
180 | 				append path to string! to word! here/1
181 | 			)
182 | 			[value | block] (remove back tail path)
183 | 		] end
184 | 	]
185 | 
186 | 	block: [
187 | 		here: and [
188 | 			  any-block! (change/only here copy here/1)
189 | 			| object! (change/only here body-of here/1)
190 | 		] into [object | array]
191 | 	]
192 | 
193 | 	func [
194 | 		"Serializes block data as URL-Encoded Web Form string"
195 | 		data [block! object!] "Block or object to encode"
196 | 		/prefix "Includes the `?` character used to precede URL query strings"
197 | 		/ruby-style "Encodes structured keys using `a[b][c]` notation"
198 | 	][
199 | 		clear path
200 | 		webform: make string! 0
201 | 		data: either object? data [body-of data][copy data]
202 | 		ruby-style?: did :ruby-style
203 | 
204 | 		case [
205 | 			not parse copy data object [
206 | 				do make error! "Unsupported block structure"
207 | 			]
208 | 
209 | 			all [
210 | 				prefix not tail? next webform
211 | 			][
212 | 				back change webform "?"
213 | 			]
214 | 
215 | 			/else [
216 | 				remove webform
217 | 			]
218 | 		]
219 | 	]
220 | ]
221 | 


--------------------------------------------------------------------------------
/ren-c/altxml.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 | 	Title: "XML Parser/Object Model for Rebol 3"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 22-Oct-2009
  5 | 	Home: http://www.ross-gill.com/page/XML_and_REBOL
  6 | 	File: %altxml.r
  7 | 	Version: 0.4.1
  8 | 	Purpose: "XML handler for Rebol v3"
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	Type: module
 11 | 	Name: altxml
 12 | 	Exports: [load-xml decode-xml]
 13 | 	History: [
 14 | 		02-Apr-2017 "Ported to Ren/C" 
 15 | 		07-Apr-2014 0.4.1 "Fixed loop when handling unterminated empty tags"
 16 | 		14-Apr-2013 0.4.0 "Added /PATH method"
 17 | 		16-Feb-2013 0.3.0 "Switch to using PATH! type to represent Namespaces"
 18 | 		22-Oct-2009 0.2.0 "Conversion from Rebol 2"
 19 | 	]
 20 | ]
 21 | 
 22 | word: use [w1 w+][
 23 | 	w1: charset [
 24 | 		"ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
 25 | 		#"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
 26 | 		#"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
 27 | 		#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
 28 | 		#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
 29 | 	]
 30 | 	w+: charset [
 31 | 		"-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
 32 | 		#"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
 33 | 		#"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
 34 | 		#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
 35 | 		#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
 36 | 	]
 37 | 	[w1 any w+]
 38 | ]
 39 | 
 40 | decode-xml: use [nm hx ns entity char][
 41 | 	nm: charset "0123456789"
 42 | 	hx: charset "0123456789abcdefABCDEF"
 43 | 	ns: make map! ["lt" 60 "gt" 62 "amp" 38 "quot" 34 "apos" 39 "nbsp" 160]
 44 | 	; nbsp is not in the XML spec but is still commonly found in XML
 45 | 
 46 | 	entity: [
 47 | 		"&" [ ; should be #"&"
 48 | 			#"#" [
 49 | 				  #"x" copy char 2 4 hx ";" (char: to-integer to-issue char)
 50 | 				| copy char 2 5 nm ";" (char: to-integer char)
 51 | 			]
 52 | 			| copy char word ";" (char: any [ns/:char 63])
 53 | 		] (char: to-char char)
 54 | 	]
 55 | 
 56 | 	func [text [string! blank!]][
 57 | 		either text [
 58 | 			if parse text [any [remove entity insert char | skip]][text]
 59 | 		][copy ""]
 60 | 	]
 61 | ]
 62 | 
 63 | load-xml: use [
 64 | 	xml! doc make-node name-to-tag is-tag is-attr
 65 | 	space entity text name attribute element header content
 66 | ][
 67 | 	xml!: context [
 68 | 		this: name: space: value: tree: branch: position: blank
 69 | 
 70 | 		flatten: use [xml path emit encode form-name element attribute tag attr text][
 71 | 			path: copy []
 72 | 			emit: func [data][repend xml data]
 73 | 
 74 | 			encode: func [text][
 75 | 				parse text: copy text [
 76 | 					some [
 77 | 						  change #"<" "&lt;"
 78 | 						| change #"^"" "&quot;"
 79 | 						| change #"&" "&amp;"
 80 | 						| skip
 81 | 					]
 82 | 				]
 83 | 
 84 | 				head text
 85 | 			]
 86 | 
 87 | 			form-name: func [name [path!]][
 88 | 				rejoin [
 89 | 					either head? name [""][append form first back name ":"]
 90 | 					switch type?/word name/1 [
 91 | 						tag! [to-string name/1]
 92 | 						issue! [next to-string name/1]
 93 | 					]
 94 | 				]
 95 | 			]
 96 | 
 97 | 			attribute: [
 98 | 				set attr is-attr set text [any-string! | number! | logic!] (
 99 | 					attr: form-name attr
100 | 					emit [" " attr {="} encode form text {"}]
101 | 				)
102 | 			]
103 | 
104 | 			element: [
105 | 				set tag is-tag (
106 | 					insert path tag: form-name tag
107 | 					emit ["<" either head? tag [tag][]]
108 | 				) [
109 | 					  blank! (emit " />" remove path)
110 | 					| set text string! (emit [">" encode form text "</" tag ">"] remove path)
111 | 					| and block! into [
112 | 						any attribute [
113 | 							  end (emit " />" remove path)
114 | 							| (emit ">") some element end (emit ["</" take path ">"])
115 | 						]
116 | 					]
117 | 				]
118 | 				| %.txt set text string! (emit encode form text)
119 | 				| attribute
120 | 			]
121 | 
122 | 			does [
123 | 				xml: copy ""
124 | 				if parse tree element [xml]
125 | 			]
126 | 		]
127 | 
128 | 		find-element: func [element [tag! issue! datatype! word!] /local hit][
129 | 			parse value [
130 | 				any [and path! hit: into [element] break | (hit: blank) skip]
131 | 			]
132 | 			hit
133 | 		]
134 | 
135 | 		get-by-tag: func [tag [tag! issue!] /local rule hits hit][
136 | 			hits: copy []
137 | 			tree
138 | 			parse tree rule: [
139 | 				some [
140 | 					opt [hit: and path! into [tag] skip (append hits make-node hit) :hit]
141 | 					skip [and block! into rule | skip]
142 | 				]
143 | 			] hits
144 | 		]
145 | 
146 | 		get-by-id: func [id /local rule at hit][
147 | 			parse tree rule: [
148 | 				some [
149 | 					  hit: tag! and block! into [thru #id id to end] return (hit: make-node hit)
150 | 					| skip [and block! into rule | skip]
151 | 				]
152 | 			] hit
153 | 		]
154 | 
155 | 		text: func [/local rule text part][
156 | 			case/all [
157 | 				string? value [text: copy value]
158 | 				block? value [
159 | 					parse value rule: [
160 | 						any [
161 | 							  [%.txt | is-tag] set part string! (append any [text text: copy ""] part)
162 | 							| skip and block! into rule | 2 skip
163 | 						]
164 | 					]
165 | 				]
166 | 				string? text [trim/auto text]
167 | 			]
168 | 		]
169 | 
170 | 		get: func [name [issue! tag!] /local hit pos][
171 | 			if parse tree [
172 | 				is-tag and block! into [
173 | 					any [
174 | 						  pos: and path! into [name] [block! (hit: make-node pos) | set hit skip] to end
175 | 						| [is-tag | is-attr | file!] skip
176 | 					]
177 | 				]
178 | 			][hit]
179 | 		]
180 | 
181 | 		sibling: func [/before /after][
182 | 			case [
183 | 				all [after parse after: skip position 2 [[file! | is-tag] to end]][
184 | 					make-node after
185 | 				]
186 | 				all [before parse before: skip position -2 [[file | is-tag] to end]][
187 | 					make-node before
188 | 				]
189 | 			]
190 | 		]
191 | 
192 | 		parent: func [/local branch]["Need Branch" blank]
193 | 
194 | 		children: func [/local hits hit][
195 | 			hits: copy []
196 | 			parse case [
197 | 				block? value [value] string? value [reduce [%.txt value]] blank? value [[]]
198 | 			][
199 | 				any [is-attr skip]
200 | 				any [hit: [is-tag | file!] skip (append hits make-node hit)]
201 | 			]
202 | 			hits
203 | 		]
204 | 
205 | 		path: func [path [block! path!] /local result selector kids][
206 | 			unless parse path [some ['* [tag! | issue!] | tag! | issue! | integer!] opt '?][
207 | 				do make error! "Invalid Path Spec"
208 | 			]
209 | 
210 | 			result: :this
211 | 
212 | 			unless parse path [
213 | 				opt [tag! (either result/name = path/1 [result: compose [(any [:result []])]][result: blank])]
214 | 
215 | 				any [
216 | 					selector:
217 | 					['* [tag! | issue!]]
218 | 					(
219 | 						kids: collect [
220 | 							foreach kid compose [(any [:result []])][
221 | 								keep kid
222 | 							]
223 | 						]
224 | 
225 | 						result: collect [
226 | 							foreach kid kids [
227 | 								keep kid/get-by-tag selector/2
228 | 							]
229 | 						]
230 | 					)
231 | 					|
232 | 					[tag! | issue!] (
233 | 						kids: collect [
234 | 							foreach kid compose [(any [:result []])] [
235 | 								keep kid/attributes
236 | 								keep kid/children
237 | 							]
238 | 						]
239 | 
240 | 						remove-each kid kids [not selector/1 = kid/name]
241 | 						result: :kids
242 | 					)
243 | 					|
244 | 					integer! (
245 | 						result: pick compose [(any [:result []])] selector/1
246 | 					)
247 | 				]
248 | 
249 | 				opt [
250 | 					'? (
251 | 						case [
252 | 							block? result [
253 | 								kids: copy :result
254 | 								result: collect [foreach kid kids [keep/only kid/value]]
255 | 							]
256 | 							object? result [
257 | 								result: result/value
258 | 							]
259 | 						]
260 | 					)
261 | 				]
262 | 			][do make error! rejoin ["Error at: " mold selector]]
263 | 
264 | 			result
265 | 		]
266 | 
267 | 		attributes: func [/local hits hit][
268 | 			hits: copy []
269 | 			parse either block? value [value][[]] [
270 | 				any [hit: is-attr skip (append hits make-node hit)] to end
271 | 			]
272 | 			hits
273 | 		]
274 | 
275 | 		clone: does [make-node tree]
276 | 
277 | 		append-child: func [name data /attr /local pos][
278 | 			case [
279 | 				blank? position/2 [value: tree/2: position/2: copy []]
280 | 				string? position/2 [
281 | 					new-line value: tree/2: position/2: compose [%.txt (position/2)] true
282 | 				]
283 | 			]
284 | 
285 | 			either attr [
286 | 				parse position/2 [any [into [issue!] skip] pos:]
287 | 			][
288 | 				pos: tail position/2
289 | 			]
290 | 
291 | 			insert pos reduce [name data]
292 | 			new-line pos true
293 | 		]
294 | 
295 | 		append-text: func [text][
296 | 			case [
297 | 				blank? position/2 [value: tree/2: position/2: text]
298 | 				string? position/2 [append position/2 text]
299 | 				%.txt = pick tail position/2 -2 [append last position/2 text]
300 | 				block? position/2 [append-child %.txt text]
301 | 			]
302 | 		]
303 | 
304 | 		append-attr: func [name value][
305 | 			append-child/attr name value
306 | 		]
307 | 	]
308 | 
309 | 	doc: make xml! [
310 | 		branch: make block! 10
311 | 		document: true
312 | 		new: does [clear branch tree: position: reduce ['document blank]]
313 | 
314 | 		open-tag: func [tag][
315 | 			insert/only branch position
316 | 			tag: name-to-tag tag
317 | 			tag/1: to-tag tag/1
318 | 			tree: position: append-child tag blank
319 | 		]
320 | 
321 | 		close-tag: func [tag][
322 | 			tag: name-to-tag tag
323 | 			tag/1: to-tag tag/1
324 | 			while [tag <> position/1][
325 | 				probe reform ["No End Tag:" position/1]
326 | 				if empty? branch [do make error! "End tag error!"]
327 | 				take branch
328 | 			]
329 | 			tree: position: take branch
330 | 		]
331 | 	]
332 | 
333 | 	is-tag: [and path! into [tag!]]
334 | 	is-attr: [and path! into [issue!]]
335 | 
336 | 	name-to-tag: func [name [string!]][
337 | 		back tail to-path replace name ":" " "
338 | 	]
339 | 
340 | 	make-node: func [here /base][
341 | 		here: make either base [doc][xml!][
342 | 			position: here
343 | 			name: here/1
344 | 			space: all [path? name not head? name pick head name 1]
345 | 			value: here/2
346 | 			tree: reduce [name value]
347 | 			name: name/1
348 | 		]
349 | 		here/this: here
350 | 	]
351 | 
352 | 	space: use [space][
353 | 		space: charset "^-^/^M "
354 | 		[some space]
355 | 	]
356 | 
357 | 	name: [word opt [":" word]]
358 | 
359 | 	entity: use [nm hx][
360 | 		nm: charset "0123456789"
361 | 		hx: charset "0123456789abcdefABCDEF"
362 | 		[#"&" [word | #"#" [1 5 nm | #"x" 1 4 hx]] ";" | #"&"]
363 | 	]
364 | 
365 | 	text: use [mk char value][
366 | 		; intersect charset ["^-^/^M" #" " - #"^(FF)"] complement charset [#"^(00)" - #"^(20)" "&<"]
367 | 		char: charset ["^-^/^M" #"^(20)" - #"^(25)" #"^(27)" - #"^(3B)" #"^(3D)" - #"^(FFFF)"] ; "
368 | 		[	copy value [
369 | 				opt space [char | entity]
370 | 				any [char | entity | space]
371 | 			] (doc/append-text decode-xml value)
372 | 		]
373 | 	]
374 | 
375 | 	attribute: use [attr value][
376 | 		[	opt space copy attr name opt space "=" opt space [
377 | 				  {"} copy value to {"}
378 | 				| {'} copy value to {'}
379 | 			] skip (
380 | 				attr: name-to-tag attr
381 | 				attr/1: to-issue attr/1
382 | 				doc/append-attr attr decode-xml value
383 | 			)
384 | 		]
385 | 	]
386 | 
387 | 	element: use [tag value][
388 | 		[	#"<" [
389 | 				copy tag name (doc/open-tag tag) any attribute opt space [
390 | 					  "/>" (doc/close-tag tag)
391 | 					| #">" content "</" copy tag name (doc/close-tag tag) opt space #">"
392 | 				]
393 | 				| #"!" [
394 | 					  "--" copy value to "-->" 3 skip ; (doc/append-child %.cmt value)
395 | 					| "[CDATA[" copy value to "]]>" 3 skip (doc/append-text value) ; (doc/append-child %.bin value)
396 | 				]
397 | 			]
398 | 		]
399 | 	]
400 | 
401 | 	header: [
402 | 		any [
403 | 			  space 
404 | 			| "<" ["?xml" thru "?>" | "!" ["--" thru "-->" | thru ">"] | "?" thru "?>"]
405 | 		]
406 | 	]
407 | 
408 | 	content: [any [text | element | space]]
409 | 
410 | 	load-xml: func [
411 | 		"Transform an XML document to a REBOL block"
412 | 		document [any-string!] "An XML string/location to transform"
413 | 		/dom "Returns an object with DOM-like methods to traverse the XML tree"
414 | 		/local root
415 | 	][
416 | 		case/all [
417 | 			any [file? document url? document][document: read/string document]
418 | 			binary? document [document: to-string document]
419 | 		]
420 | 
421 | 		root: doc/new
422 | 		parse/case document [header element to end]
423 | 		doc/tree: any [root/document []]
424 | 		doc/value: doc/tree/2
425 | 		either dom [make-node/base doc/tree][doc/tree]
426 | 	]
427 | ]
428 | 


--------------------------------------------------------------------------------
/ren-c/clean.reb:
--------------------------------------------------------------------------------
 1 | Rebol [
 2 | 	Title: "Clean"
 3 | 	Author: "Christopher Ross-Gill"
 4 | 	Date: 18-Apr-2018
 5 | 	File: %clean.red
 6 | 	Version: 0.1.2
 7 | 	Purpose: "Converts errant CP-1252 codepoints within a UTF-8 binary"
 8 | 	Rights: http://opensource.org/licenses/Apache-2.0
 9 | 	Type: module
10 | 	Name: rgchris.clean
11 | 	Exports: [clean]
12 | 	History: [
13 | 		18-Apr-2018 0.1.2 "Ren-C Version"
14 | 		14-Aug-2013 0.1.1 "Working Version"
15 | 	]
16 | ]
17 | 
18 | clean: use [
19 | 	codepoints ascii utf-b utf-2 utf-3 utf-4 here cleaner
20 | ][
21 | 	codepoints: make map! [
22 | 		; CP-1252 specific range
23 | 		128 #{E282AC} 130 #{E2809A} 131 #{C692} 132 #{E2809E} 133 #{E280A6} 134 #{E280A0}
24 | 		135 #{E280A1} 136 #{CB86} 137 #{E280B0} 138 #{C5A0} 139 #{E280B9} 140 #{C592}
25 | 		142 #{C5BD} 145 #{E28098} 146 #{E28099} 147 #{E2809C} 148 #{E2809D} 149 #{E280A2}
26 | 		150 #{E28093} 151 #{E28094} 152 #{CB9C} 153 #{E284A2} 154 #{C5A1} 155 #{E280BA}
27 | 		156 #{C593} 158 #{C5BE}
28 | 	]
29 | 
30 | 	ascii: charset [  0 - 127]
31 | 	utf-b: charset [128 - 191]
32 | 	utf-2: charset [194 - 223]
33 | 	utf-3: charset [224 - 239]
34 | 	utf-4: charset [240 - 244]
35 | 
36 | 	here: _
37 | 
38 | 	cleaner: [
39 | 		ascii
40 | 		  ; simplistic representation of UTF-8
41 | 		| utf-2 utf-b | utf-3 2 utf-b | utf-4 3 utf-b
42 | 		| change here: skip (
43 | 			case [
44 | 				did select codepoints here/1 [codepoints/(here/1)]
45 | 				here/1 > 191 [reduce [195 here/1 and+ 191]]
46 | 				here/1 > 158 [reduce [194 here/1]]
47 | 			] else [[239 191 189]]
48 | 		)
49 | 	]
50 | 
51 | 	clean: func [
52 | 		"Converts errant CP-1252 codepoints within a UTF-8 binary"
53 | 		string [binary!] "Binary to convert"
54 | 	][
55 | 		parse string [any cleaner]
56 | 		to string! string
57 | 	]
58 | ]
59 | 


--------------------------------------------------------------------------------
/ren-c/curl.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "cURL"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 08-Feb-2019
  5 |     Home: http://ross-gill.com/page/REST_Protocol
  6 |     File: %curl.reb
  7 |     Version: 0.1.5
  8 |     Purpose: "Rebol wrapper for cURL command."
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: module
 11 |     Name: rgchris.curl
 12 |     Exports: [curl]
 13 |     History: [
 14 |         08-Feb-2019 0.1.5 "Ren-C compatibilities"
 15 |         04-Feb-2018 0.1.4 "Ren-C compatibilities"
 16 |         18-Jul-2017 0.1.3 "Initial Ren-C version"
 17 |         02-May-2013 0.1.2 "Use COLLECT; basic Auth support"
 18 |         21-Oct-2012 0.1.1 "Initial published version"
 19 |     ]
 20 |     Comment: ["cURL Home Page" http://curl.haxx.se/]
 21 | ]
 22 | 
 23 | curl: use [user-agent form-headers enquote][
 24 |     user-agent: unspaced ["Rebol/" uppercase/part form system/product 1 " " system/version]
 25 | 
 26 |     enquote: func [
 27 |         data [block! any-string!]
 28 |         /local mark
 29 |     ][
 30 |         mark: switch system/version/4 [3 [{"}] ("'")]
 31 |         unspaced compose [mark (data) mark]
 32 |     ]
 33 | 
 34 |     form-headers: func [headers [block! object!] /local out][
 35 |         collect [
 36 |             for-each [header value] switch type of headers [
 37 |                 block! [headers]
 38 |                 object! [body of headers]
 39 |             ][
 40 |                 if value [
 41 |                     keep unspaced [" -H " enquote [as text! header ": " value]]
 42 |                 ]
 43 |             ]
 44 |         ]
 45 |     ]
 46 | 
 47 |     curl: func [
 48 |         "Wrapper for the cURL shell function"
 49 |         url [url!] "URL to Retrieve"
 50 |         /method "Specify HTTP request method"
 51 |         verb [word! text! blank!] "HTTP request method"
 52 |         /send "Include request body"
 53 |         data [text! binary! file! blank!] "Request body"
 54 |         /header "Specify HTTP headers"
 55 |         headers [block! object! blank!] "HTTP headers"
 56 |         /as "Specify user agent"
 57 |         agent [text!] "User agent"
 58 |         /user "Provide User Credentials"
 59 |         name [text! blank!] "User Name"
 60 |         pass [text! blank!] "User Password"
 61 |         /full "Include HTTP headers in response"
 62 |         /binary "Receive response as binary"
 63 |         /follow "Follow HTTP redirects"
 64 |         /quiet "Return blank! on 4xx/5xx HTTP responses"
 65 |         /secure "Disallow 'insecure' SSL transactions"
 66 |         /into "Specify result string"
 67 |         out [text! binary! blank!] "String to contain result"
 68 |         /error "Specify error string"
 69 |         err [text! blank!] "String to contain error"
 70 |         /timeout "Specify a time limit"
 71 |         time [time! integer! blank!] "Time limit"
 72 |         /local command options code
 73 |     ][
 74 |         out: any [:out make binary! 0]
 75 |         err: any [:err make text! 0]
 76 | 
 77 |         options: unspaced collect [
 78 |             keep "-s"
 79 | 
 80 |             case/all [
 81 |                 full [keep "i"]
 82 |                 quiet [keep "f"]
 83 |                 not secure [keep "k"]
 84 |                 follow [keep "L"]
 85 | 
 86 |                 :verb [
 87 |                     keep " -X "
 88 |                     keep verb: uppercase form verb
 89 |                 ]
 90 | 
 91 |                 :time [
 92 |                     keep " -m "
 93 |                     keep to integer! time
 94 |                 ]
 95 | 
 96 |                 not send [data: _]
 97 | 
 98 |                 file? data [
 99 |                     keep reduce [" -d @" form data]
100 |                     data: _
101 |                 ]
102 | 
103 |                 data [
104 |                     either empty? data [
105 |                         data: _
106 |                     ][
107 |                         keep " -d @-"
108 |                         data: to binary! data
109 |                     ]
110 |                 ]
111 | 
112 |                 all [:name :pass][
113 |                     keep " -u "
114 |                     keep enquote [name ":" pass]
115 |                 ]
116 | 
117 |                 :headers [keep form-headers headers]
118 |             ]
119 | 
120 |             keep reduce [
121 |                 " -A " enquote any [:agent user-agent]
122 |             ]
123 |         ]
124 | 
125 |         command: spaced ["curl" options enquote url]
126 | 
127 |         code: call/shell/wait/input/output/error command data out err
128 | 
129 |         switch code [
130 |             0 18 [
131 |                 either binary [out][
132 |                     to text! out
133 |                 ]
134 |             ]
135 |             1 [
136 |                 if empty? trim/head/tail err [
137 |                     err: "Unsupported protocol. This build of curl has no support for this protocol."
138 |                 ]
139 |                 fail/where :err 'url
140 |             ]
141 |             2 [fail/where "Failed to initialize." 'url]
142 |             3 [fail/where "URL malformed. The syntax was not correct." 'url]
143 |             4 [fail/where "Feature not included in this cURL build." 'url]
144 |             6 [fail/where "Couldn't resolve host. The given remote host was not resolved." 'url]
145 |             7 [fail/where "Failed to connect to host." 'url]
146 |             22 [_]
147 |             28 [fail/where "Request timed out." 'url]
148 |             50 [fail/where "OS shell error." 'url]
149 |             52 [fail/where "The server didn't reply anything." 'url]
150 |             (
151 |                 code: spaced ["cURL Error Code" code trim/head/tail err]
152 |                 fail/where :code 'url
153 |             )
154 |         ]
155 |     ]
156 | ]
157 | 


--------------------------------------------------------------------------------
/ren-c/form-date.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "Date Formatter for Ren-C"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 2-Feb-2020
  5 |     Home: http://scripts.rebol.info/scripts/form-date,docs
  6 |     File: %form-date.reb
  7 |     Version: 1.1.0
  8 |     Purpose: {Return formatted date string using strftime style format specifiers}
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: module
 11 |     Name: rgchris.form-date
 12 |     Exports: [form-date form-time]
 13 |     History: [
 14 |         02-Feb-2020 1.1.0 "Port to Ren-C"
 15 |         06-Sep-2015 1.1.0 "Change to use REWORD; Deprecate /GMT"
 16 |         12-Jun-2013 1.0.0 "Ported from Rebol 2"
 17 |     ]
 18 |     Notes: {Extracted from the QuarterMaster web framework}
 19 | ]
 20 | 
 21 | pad: func [text length [integer!] /with [char!]][
 22 |     with: default [#"0"]
 23 |     text: form text
 24 |     skip tail insert/dup text with length negate length
 25 | ]
 26 | 
 27 | pad-zone: func [time /flat][
 28 |     rejoin [
 29 |         pick "-+" time/hour < 0
 30 |         pad abs time/hour 2
 31 |         either flat [""][#":"]
 32 |         pad time/minute 2
 33 |     ]
 34 | ]
 35 | 
 36 | pad-precise: func [seconds [any-number!] <local> out][
 37 |     seconds: form make time! seconds
 38 |     head change copy "00.000000" find/last/tail form seconds ":"
 39 | ]
 40 | 
 41 | to-epoch-time: func [date [date!]][
 42 |     ; date/time: date/time - date/zone
 43 |     date: form any [
 44 |         attempt [to integer! difference date 1-Jan-1970/0:0:0]
 45 |         date - 1-Jan-1970/0:0:0 * 86400.0
 46 |     ]
 47 |     clear find/last date "."
 48 |     date
 49 | ]
 50 | 
 51 | to-iso-week: use [get-iso-year][
 52 |     get-iso-year: func [
 53 |         year [integer!]
 54 |         <local> d1 d2
 55 |     ][
 56 |         d1: to date! join "4-Jan-" year
 57 |         d2: to date! join "28-Dec-" year
 58 |         reduce [d1 + 1 - d1/weekday d2 + 7 - d2/weekday]
 59 |     ]
 60 | 
 61 |     func [
 62 |         date [date!]
 63 |         <local> out d1 d2
 64 |     ][
 65 |         out: [0 0]
 66 |         set [d1 d2] get-iso-year out/2: date/year
 67 | 
 68 |         case [
 69 |             date < d1 [d1: first get-iso-year out/1: date/year - 1]
 70 |             date > d2 [d1: first get-iso-year out/2: date/year + 1]
 71 |         ]
 72 | 
 73 |         out/1: to integer! date + 8 - date/weekday - d1 / 7
 74 |         out
 75 |     ]
 76 | ]
 77 | 
 78 | date-codes: [
 79 |     "The abbreviated weekday name according to the current locale"
 80 |     #"a" [copy/part pick system/locale/days date/weekday 3]
 81 | 
 82 |     "The full weekday name according to the current locale"
 83 |     #"A" [pick system/locale/days date/weekday]
 84 | 
 85 |     "The abbreviated month name according to the current locale"
 86 |     #"b" [copy/part pick system/locale/months date/month 3]
 87 | 
 88 |     "The full month name according to the current locale"
 89 |     #"B" [pick system/locale/months date/month]
 90 | 
 91 |     "The century number (year/100) as a 2-digit integer"
 92 |     #"C" [to integer! date/year / 100]
 93 | 
 94 |     "The day of the month as a number (range 01 to 31)"
 95 |     #"d" [pad date/day 2]
 96 | 
 97 |     "Equivalent to '%m/%d/%Y'"
 98 |     #"D" [
 99 |         unspaced [
100 |             date/year #"-" pad date/month 2 #"-" pad date/day 2
101 |         ]
102 |     ]
103 |     "The day of the month as a number, without padding"
104 |     #"e" [date/day]
105 | 
106 |     "Equivalent to '%Y-%m-%d'"
107 |     #"F" [
108 |         unspaced [
109 |             date/year #"-" pad date/month 2 #"-" pad date/day 2
110 |         ]
111 |     ]
112 | 
113 |     "The ISO 8601 year as a number [needs review]"
114 |     #"g" [pad to integer! (second to-iso-week date) // 100 2]
115 | 
116 |     "The ISO 8601 year without century as a number [needs review]"
117 |     #"G" [to integer! second to-iso-week date]
118 | 
119 |     "The hour as a number using a 12-hour clock (range 1 to 12)"
120 |     #"h" [time/hour + 11 // 12 + 1]
121 | 
122 |     "The hour as a 2-digit number using a 24-hour clock (range 00 to 23)"
123 |     #"H" [pad time/hour 2]
124 | 
125 |     "The english suffix for numeric day value, 'st' for 01, 'th' for 04"
126 |     #"i" [switch date/day [1 21 31 ["st"] 2 22 ["nd"] 3 23 ["rd"] default ["th"]]]
127 | 
128 |     "The hour as a 2-digit number using a 12-hour clock (range 01 to 12)"
129 |     #"I" [pad time/hour + 11 // 12 + 1 2]
130 | 
131 |     "The day of the year as a number (range 001 to 366)"
132 |     #"j" [pad date/julian 3]
133 | 
134 |     "The day of the year as a number without padding (range 1 to 366)"
135 |     #"J" [date/julian]
136 | 
137 |     "The month as a 2-digit number (range 01 to 12)"
138 |     #"m" [pad date/month 2]
139 | 
140 |     "The minute as a 2-digit number (range 00 to 59)"
141 |     #"M" [pad time/minute 2]
142 | 
143 |     "Either 'AM' or 'PM' according to the given time value. Noon is treated as 'PM' and midnight as 'AM'"
144 |     #"p" [pick ["am" "pm"] time/hour < 12]
145 | 
146 |     "Either 'am' or 'pm' according to the given time value. Noon is treated as 'pm' and midnight as 'am'"
147 |     #"P" [pick ["AM" "PM"] time/hour < 12]
148 | 
149 |     "Equivalent to '%h:%M:%S %p'"
150 |     #"r" [
151 |         unspaced [
152 |             pad time/hour + 11 // 12 + 1 2
153 |             #":" pad time/minute 2 #":" pad to integer! time/second 2
154 |             #" " pick ["AM" "PM"] time/hour < 12
155 |         ]
156 |     ]
157 | 
158 |     "Equivalent to '%H:%M'"
159 |     #"R" [pad time/hour 2 #":" pad time/minute 2]
160 | 
161 |     "The number of seconds since the Epoch, 1970-01-01 00:00:00 +0000 (UTC)"
162 |     #"s" [to-epoch-time date]
163 | 
164 |     "The second as a 2-digit number (range 00 to 60)"
165 |     #"S" [pad to integer! time/second 2]
166 | 
167 |     "Tab character"
168 |     #"t" [#"^-"]
169 | 
170 |     "Equivalent to '%H:%M:%S'"
171 |     #"T" [
172 |         unspaced [
173 |             pad time/hour 2 #":" pad time/minute 2 #":" pad to integer! time/second 2
174 |         ]
175 |     ]
176 | 
177 |     "The day of the week as a number (range 1 to 7, Monday being 1). See also %w"
178 |     #"u" [date/weekday]
179 | 
180 |     "The week number of the current year as a 2-digit number (range 00 to 53, starting with the first Sunday as the first day of week 01)"
181 |     #"U" [pad to integer! date/julian + 6 - (date/weekday // 7) / 7 2]
182 | 
183 |     "The ISO 8601 week number of the current year as a 2-digit decimal number (range 01 to 53, where week 1 is the first week that has at least 4 days in the new year) [needs review]"
184 |     #"V" [pad to integer! first to-iso-week date 2]
185 | 
186 |     "The day of the week as a number (range 0 to 6, Sunday being 0). See also %u"
187 |     #"w" [date/weekday // 7]
188 | 
189 |     "The week number of the current year as a 2-digit number (range 00 to 53, starting with the first Monday as the first day of week 01)"
190 |     #"W" [pad to integer! date/julian + 7 - date/weekday / 7 2]
191 | 
192 |     "The second as a decimal number 00-60 with Red nanosecond precision, a period followed by 6 digits"
193 |     #"x" [pad-precise time/second]
194 | 
195 |     "The year as a 2-digit number without a century (range 00 to 99)"
196 |     #"y" [pad date/year // 100 2]
197 | 
198 |     "The year as a number (range 0 to maximum supported)"
199 |     #"Y" [date/year]
200 | 
201 |     "The time-zone as hour offset from UTC (without a ':' separator)"
202 |     #"z" [pad-zone/flat zone]
203 | 
204 |     "The time-zone as hour offset from UTC"
205 |     #"Z" [pad-zone zone]
206 | 
207 |     "RFC3339 Date Stamp"
208 |     #"c" [
209 |         unspaced [
210 |             date/year #"-" pad date/month 2 "-" pad date/day 2 "T"
211 |             pad time/hour 2 #":" pad time/minute 2 #":" pad to integer! time/second 2 
212 |             either utc ["Z"][pad-zone zone]
213 |         ]
214 |     ]
215 | ]
216 | 
217 | ; self-documentation to follow
218 | remove-each item date-codes [text? item]
219 | 
220 | form-date: func [
221 |     "Renders a date to a given format"
222 |     date [date!] "Date to gormat"
223 |     format [any-string!] "Format (string largely compatible with strftime)"
224 |     /utc "Align time with UTC"
225 |     <local> time zone
226 | ][
227 |     either date/time [
228 |         if date/zone [date/time: date/time - date/zone]
229 |         date/zone: either utc [0:00][date/zone]
230 |         date/time: date/time + date/zone
231 |     ][
232 |         date/time: 0:00
233 |         date/zone: either utc [0:00][now/zone]
234 |     ]
235 | 
236 |     time: date/time
237 |     zone: date/zone
238 |     reword/case/escape format bind date-codes 'date #"%"
239 | ]
240 | 
241 | form-time: func [
242 |     time [time!]
243 |     format [any-string!]
244 |     <local> date zone
245 | ][
246 |     date: now/date zone: 0:00
247 |     reword/case/escape format bind date-codes 'time #"%"
248 | ]
249 | 


--------------------------------------------------------------------------------
/ren-c/readme.md:
--------------------------------------------------------------------------------
1 | Ren-C Scripts (experimental)
2 | ============================
3 | 
4 | Scripts targeted at the [Ren-C](https://github.com/metaeducation/ren-c) fork of Rebol 3.
5 | 


--------------------------------------------------------------------------------
/ren-c/rsp.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "RSP Preprocessor"
  3 |     Author: "Christopher Ross-Gill"
  4 |     Date: 8-Feb-2019
  5 |     Home: http://ross-gill.com/page/RSP
  6 |     File: %rsp.reb
  7 |     Version: 0.5.0
  8 |     Purpose: {Rebol-embedded Markup}
  9 |     Rights: http://opensource.org/licenses/Apache-2.0
 10 |     Type: module
 11 |     Name: rgchris.rsp
 12 |     Exports: [sanitize build-tag load-rsp render render-each]
 13 |     History: [
 14 |         08-Feb-2019 0.5.0 "Reworked BUILD-TAG function"
 15 |         11-Dec-2018 0.4.3 "Ren-C Late 2018 Changes; Add BUILD-TAG"
 16 |         02-Sep-2017 0.4.2 "Replace GET/ANY"
 17 |         21-Jul-2017 0.4.1 ""
 18 |         13-Jun-2013 0.4.0 "Support Extended Characters in SANITIZE"
 19 |         12-Jun-2013 0.3.0 "Add SANITIZE function"
 20 |         12-Jun-2013 0.2.0 "Extracted from QuarterMaster"
 21 |         14-Nov-2002 _ "Build-Tag 1.2.0 by Andrew Martin"
 22 |     ]
 23 |     Notes: "Extracted from QuarterMaster"
 24 | ]
 25 | 
 26 | sanitize: use [ascii html* extended][
 27 |     html*: exclude ascii: charset ["^/^-" #"^(20)" - #"^(7E)"] charset {&<>"}
 28 |     extended: complement charset [#"^(00)" - #"^(7F)"]
 29 | 
 30 |     func [text [text!] /local char][
 31 |         parse form text [
 32 |             copy text any [
 33 |                 text: some html*
 34 |                 |
 35 |                 change #"<" "&lt;"
 36 |                 |
 37 |                 change #">" "&gt;"
 38 |                 |
 39 |                 change #"&" "&amp;"
 40 |                 |
 41 |                 change #"^"" "&quot;"
 42 |                 |
 43 |                 remove #"^M"
 44 |                 |
 45 |                 remove copy char extended
 46 |                 (char: rejoin ["&#" to integer! char/1 ";"])
 47 |                 insert char
 48 |                 |
 49 |                 change skip "&#65533;"
 50 |             ]
 51 |         ]
 52 | 
 53 |         any [text copy ""]
 54 |     ]
 55 | ]
 56 | 
 57 | build-tag: use [to-name slash][
 58 |     to-name: func [name [word! path!]][
 59 |         back replace/all next mold name "/" ":"
 60 |     ]
 61 | 
 62 |     slash: first [/]
 63 | 
 64 |     make action! [
 65 |         [
 66 |             "Generates a tag from a composed block." 
 67 |             values [block!] "Block of parens to evaluate and other data." 
 68 |             /local tag has-value xml? name is-name value
 69 |         ]
 70 |         [
 71 |             xml?: false
 72 | 
 73 |             tag: collect [
 74 |                 is-name: [
 75 |                     word! | and path! into [word! word!]
 76 |                 ]
 77 | 
 78 |                 has-value: [
 79 |                     [
 80 |                         set value [get-word! | get-path! | group!] (
 81 |                             value: eval value
 82 |                         )
 83 |                         |
 84 |                         and not [slash | is-name]
 85 |                         set value skip
 86 |                     ]
 87 |                     (
 88 |                         value: switch type of :value [
 89 |                             text! url! email! [value]
 90 |                             logic! blank! [either :value [name][_]]
 91 |                             binary! [enbase value]
 92 |                             tag! [to text! value]
 93 |                             file! [replace/all as text! value #" " "%20"]
 94 |                             char! date! [form value]
 95 |                             tuple! [unspaced ["#" enbase/base to binary! value 16]]
 96 |                             issue! integer! decimal! money! time! percent! [mold value]
 97 |                             lit-word! [as text! value]
 98 |                             (_)
 99 |                         ]
100 |                     )
101 |                 ]
102 | 
103 |                 parse values [
104 |                     set name ['?xml (xml?: true) | is-name] (
105 |                         keep to-name name
106 |                     )
107 |                     any [
108 |                         slash end (
109 |                             keep either xml? ["?"][" /"]
110 |                             xml?: false
111 |                         )
112 |                         |
113 |                         set name is-name [
114 |                             has-value (
115 |                                 if value [
116 |                                     keep unspaced [
117 |                                         " " to-name name {="} sanitize form value {"}
118 |                                     ]
119 |                                 ]
120 |                             )
121 |                             |
122 |                             (
123 |                                 keep " "
124 |                                 keep to-name name
125 |                             )
126 |                         ]
127 |                     ]
128 |                     end (
129 |                         if xml? [keep "?"]
130 |                     )
131 |                     |
132 |                     and set name path! into [blank! word! opt word!] to end (
133 |                         keep to-name name
134 |                     )
135 |                     |
136 |                     end (tag: [])
137 |                 ]
138 |             ]
139 | 
140 |             if tag: unspaced tag [to tag! tag]
141 |         ]
142 |     ]
143 | ]
144 | 
145 | load-rsp: use [prototype to-set-block][
146 |     prototype: context [
147 |         out*: _ prin: method [value][append out* unspaced compose [(value)]]
148 |         print: method [val][prin value prin newline]
149 |     ]
150 | 
151 |     to-set-block: func [locals [block! object!] /local word][
152 |         case [
153 |             object? locals [
154 |                 body of locals
155 |             ]
156 | 
157 |             block? locals [
158 |                 collect [
159 |                     keep []
160 |                     parse locals [
161 |                         any [
162 |                             set word word! (keep reduce [to set-word! word get :word])
163 |                         ]
164 |                     ]
165 |                 ]
166 |             ]
167 |         ]
168 |     ]
169 | 
170 |     func [body [text!] /local source mark return: [action!]][
171 |         source: unspaced collect [
172 |             keep unspaced ["^/out*: make text! " length-of body "^/"]
173 |             parse body [
174 |                 any [
175 |                     end (keep "^/out*") break
176 |                     |
177 |                     "<%" [
178 |                         "==" copy mark to "%>" (
179 |                             keep unspaced ["prin sanitize form (" mark "^/)^/"]
180 |                         )
181 |                         |
182 |                         "=" copy mark to "%>" (
183 |                             keep unspaced ["prin (" mark "^/)^/"]
184 |                         )
185 |                         |
186 |                         [#":" | #"!"] copy mark to "%>" (
187 |                             keep unspaced ["prin any [build-tag [" mark "^/] {}]^/"]
188 |                         )
189 |                         |
190 |                         #"#" to "%>" ; comment
191 |                         |
192 |                         copy mark to "%>" (keep unspaced [mark newline])
193 |                         |
194 |                         mark: (
195 |                             fail ["Expected '%>' at" mold copy/part mark 20]
196 |                         )
197 |                     ] 2 skip
198 |                     | copy mark [to "<%" | to end] (
199 |                         keep unspaced ["prin " mold mark "^/"]
200 |                     )
201 |                 ]
202 |             ]
203 |         ]
204 | 
205 |         make action! compose/deep/only [
206 |             [args [block! object!]]
207 |             [
208 |                 args: make prototype to-set-block args
209 |                 do bind/copy (load source) args
210 |             ]
211 |         ]
212 |     ]
213 | ]
214 | 
215 | render: use [depth*][
216 |     depth*: 0  ; to break recursion
217 | 
218 |     make action! [
219 |         [
220 |             rsp [file! url! text!]
221 |             /with locals [block! object!]
222 |         ]
223 |         [
224 |             either depth* > 20 [return ""][
225 |                 depth*: depth* + 1
226 | 
227 |                 case/all [
228 |                     file? rsp [rsp: read rsp]
229 |                     url? rsp [rsp: read rsp]
230 |                     binary? rsp [rsp: to text! rsp]
231 |                     text? rsp [
232 |                         rsp: load-rsp rsp
233 |                         rsp any [:locals | make block! 0]
234 |                     ]
235 |                 ]
236 | 
237 |                 elide depth*: depth* - 1
238 |             ]
239 |         ]
240 |     ]
241 | ]
242 | 
243 | render-each: func [
244 |     'items [word! block!]
245 |     source [any-series!]
246 |     body [file! url! text!]
247 |     /with locals
248 | ][
249 |     locals: compose [(:locals) (items)]
250 |     "" unless unspaced try collect [
251 |         for-each :items source compose/only [
252 |             keep render/with body (locals)
253 |         ]
254 |     ]
255 | ]
256 | 


--------------------------------------------------------------------------------
/ren-c/twitter.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 |     Title: "Twitter Client for Rebol"
  3 |     Author: ["Christopher Ross-Gill" "John Kenyon"]
  4 |     Date: 10-Jun-2013
  5 |     Home: http://ross-gill.com/page/Twitter_API_and_Rebol
  6 |     File: %twitter.reb
  7 |     Version: 0.3.8
  8 |     Purpose: {
  9 |         Rebol script to access and use the Twitter OAuth API.
 10 |         Warning: Currently configured to use HTTP only
 11 |         New user registration must be done using rebol 2 version
 12 |         This function will be updated when https is available (for Linux)
 13 |     }
 14 |     Rights: http://opensource.org/licenses/Apache-2.0
 15 |     Type: module
 16 |     Name: rgchris.twitter
 17 |     Exports: [twitter]
 18 |     Needs: [<webform> <json>]
 19 |     History: []
 20 | ]
 21 | 
 22 | twitter: make object! bind [
 23 |     as: func [
 24 |         "Set current user"
 25 |         user [string!] "Twitter user name"
 26 |     ][
 27 |         either user: select users user [
 28 |             persona: make persona user
 29 |             persona/name
 30 |         ][
 31 |             either not error? user: try [register][
 32 |                 repend users [
 33 |                     user/name
 34 |                     new-line/skip/all body-of user true 2
 35 |                 ]
 36 |                 persona/name
 37 |             ][do :user]
 38 |         ]
 39 |     ]
 40 | 
 41 |     save-users: func [
 42 |         "Saves authorized users"
 43 |         /to location [file! url!] "Alternate Storage Location"
 44 |     ][
 45 |         location: any [location settings/user-store]
 46 |         unless any [file? location url? location][
 47 |             make error! "No Storage Location Provided"
 48 |         ]
 49 |         save/header location new-line/skip/all users true 2 context [
 50 |             Title: "Twitter Authorized Users"
 51 |             Date: now/date
 52 |         ]
 53 |     ]
 54 | 
 55 |     authorized-users: func ["Lists authorized users"][extract users 2] 
 56 | 
 57 |     find: func [
 58 |         "Tweets by Search"
 59 |         query [string! issue! email!] "Search String"
 60 |         /size count [integer!] /page offset [integer!]
 61 |     ][ 
 62 |         case [
 63 |             issue? query [query: mold query]
 64 |             email? query [query: join-of "@" query/host]
 65 |         ]
 66 |         set words-of params reduce [query offset count]
 67 |         either attempt [
 68 |             result: to string! read join-of http://search.twitter.com/search.json? to-webform params
 69 |         ] load-result error/connection
 70 |     ]
 71 | 
 72 |     timeline: func [
 73 |         "Retrieve a User Timeline"
 74 |         /for user [string!] /size count [integer!] /page offset [integer!]
 75 |     ][
 76 |         unless persona/name error/credentials
 77 | 
 78 |         set words-of options reduce [
 79 |             any [:user persona/name _]
 80 |             any [if integer? :count [min 200 abs count] _]
 81 |             any [:offset _]
 82 |         ]
 83 | 
 84 |         either do [
 85 |             result: send/with 'get %1.1/statuses/user_timeline.json options
 86 |         ] load-result error/connection
 87 |     ]
 88 | 
 89 |     home: friends: func [
 90 |         "Retrieve status messages from friends"
 91 |         /size count [integer!] /page offset [integer!]
 92 |     ][
 93 |         unless persona/name error/credentials
 94 | 
 95 |         set words-of options reduce [
 96 |             _
 97 |             all [count min 200 abs count]
 98 |             offset
 99 |         ]
100 | 
101 |         either attempt [
102 |             result: send/with 'get %1.1/statuses/home_timeline.json options
103 |         ] load-result error/connection
104 |     ]
105 | 
106 |     update: func [
107 |         "Send Twitter status update"
108 |         status [string!] "Status message"
109 |         /reply "As reply to" id [issue!] "Reply reference" /override
110 |     ][
111 |         override: either override [200][140]
112 |         unless persona/name error/credentials
113 |         unless all [0 < length? status override > length? status] error/invalid
114 |         set words-of message reduce [
115 |             status
116 |             any [:id _]
117 |         ]
118 |         either attempt [
119 |             result: send/with 'post %1.1/statuses/update.json message
120 |         ] load-result error/connection
121 |     ]
122 | 
123 | ] make object! [ ; internals
124 |     config: case [
125 |         block? system/script/args [
126 |             make object! system/script/args
127 |         ]
128 | 
129 |         file? system/script/args [
130 |             make object! load system/script/args
131 |         ]
132 | 
133 |         exists? %twitter.config.reb [
134 |             make object! load %twitter.config.reb
135 |         ]
136 | 
137 |         /else [
138 |             do make error! "No Configuration Provided"
139 |         ]
140 |     ]
141 | 
142 |     root: config/twitter
143 | 
144 |     settings: make make object! [
145 |         twitter: consumer-key: consumer-secret: users: _
146 |     ][
147 |         consumer-key: config/consumer-key
148 |         consumer-secret: config/consumer-secret
149 |     ]
150 | 
151 |     users: config/users
152 | 
153 |     options: make object! [screen_name: count: page: _]
154 |     params: make object! [q: page: rpp: _]
155 |     message: make object! [status: in_reply_to_status_id: _]
156 | 
157 |     result: _
158 |     load-result: [load-json result]
159 | 
160 |     error: [
161 |         credentials [do make error! "User must be authorized to use this application"]
162 |         connection [do make error! "Unable to connect to Twitter"]
163 |         invalid [do make error! "Status length should be between between 1 and 140"]
164 |     ]
165 | 
166 |     persona: context [
167 |         id: name: _
168 |         token: secret: _
169 |     ]
170 | 
171 |     oauth!: context [
172 |         oauth_callback: _
173 |         oauth_consumer_key: settings/consumer-key
174 |         oauth_token: oauth_nonce: _
175 |         oauth_signature_method: "HMAC-SHA1"
176 |         oauth_timestamp: _
177 |         oauth_version: 1.0
178 |         oauth_verifier: oauth_signature: _
179 |     ]
180 | 
181 |     send: use [make-nonce timestamp sign][
182 |         make-nonce: does [
183 |             enbase/base checksum/secure to binary! join-of form now/precise settings/consumer-key 64
184 |         ]
185 | 
186 |         timestamp: func [/for date [date!]][
187 |             date: any [:date now]
188 |             date: form any [
189 |                 attempt [to integer! difference date 1-Jan-1970/0:0:0]
190 |                 date - 1-Jan-1970/0:0:0 * 86400.0
191 |             ]
192 |             clear find/last date "."
193 |             date
194 |         ]
195 | 
196 |         sign: func [
197 |             method [word!]
198 |             lookup [url!]
199 |             oauth [object! block! blank!]
200 |             params [object! block! blank!]
201 |             /local out
202 |         ][
203 |             out: copy ""
204 | 
205 |             oauth: any [oauth make oauth! []]
206 |             oauth/oauth_nonce: make-nonce
207 |             oauth/oauth_timestamp: timestamp
208 |             oauth/oauth_token: persona/token
209 | 
210 |             params: sort/skip unique/skip collect [
211 |                 for-each [key value] body-of make oauth any [:params []][
212 |                     keep to word! key
213 |                     keep switch/default type-of value [
214 |                         issue! [to string! to word! value]
215 |                     ][
216 |                         value
217 |                     ]
218 |                 ]
219 |             ] 2 2
220 | 
221 |             oauth/oauth_signature: enbase/base checksum/secure/key to binary! rejoin [
222 |                 uppercase form method "&" replace/all url-encode form lookup "%5f" "_" "&"
223 |                 replace/all replace/all url-encode replace/all to-webform params "+" "%20" "%5f" "_" "%255F" "_"
224 |             ] rejoin [
225 |                 settings/consumer-secret "&" any [persona/secret ""]
226 |             ] 64
227 | 
228 |             foreach [header value] body-of oauth [
229 |                 if value [
230 |                     repend out [", " form to string! to word! header {="} url-encode form value {"}]
231 |                 ]
232 |             ]
233 | 
234 |             join-of "OAuth" next out
235 |         ]
236 | 
237 |         send: func [
238 |             method [word!] lookup [file!]
239 |             /auth oauth [object!]
240 |             /with params [object!]
241 |         ][
242 |             lookup: join-of dirize root lookup
243 |             oauth: make oauth! any [:oauth []]
244 |             if object? :params [params: body-of params ]
245 | 
246 |             switch method [
247 |                 put delete [
248 |                     params: compose [method: (uppercase form method) (any [params []])]
249 |                     method: 'post
250 |                 ]
251 |             ]
252 | 
253 |             switch method [
254 |                 get [
255 |                     method: compose/deep [
256 |                         get [ Authorization: (sign 'get lookup oauth params) ]
257 |                     ] 
258 |                     if params [
259 |                         params: context sort/skip params 2
260 |                         append lookup to-webform/prefix params
261 |                     ]
262 |                 ]
263 |                 post put delete [
264 |                     method: compose/deep [
265 |                         (method) [
266 |                             Authorization: (sign method lookup oauth params)
267 |                             Content-Type: "application/x-www-form-urlencoded"
268 |                         ]
269 |                         (either params [to-webform params][""]) 
270 |                     ]
271 |                 ]
272 |             ]
273 |             lookup: to string! write lookup method
274 |         ]
275 |     ]
276 | 
277 |     register: use [request-broker access-broker verification-page][
278 |         request-broker: %oauth/request_token
279 |         verification-page: %oauth/authorize?oauth_token=
280 |         access-broker: %oauth/access_token
281 | 
282 |         func [
283 |             /requester request [function!]
284 |             /local response verifier
285 |         ][
286 |             request: any [:request :ask]
287 |             set words-of persona _
288 | 
289 |             response: load-webform send/auth 'post request-broker make oauth! [
290 |                 oauth_callback: "oob"
291 |             ]
292 | 
293 |             persona/token: response/oauth_token
294 |             persona/secret: response/oauth_token_secret
295 | 
296 |             browse join-of twitter-url/:verification-page response/oauth_token 
297 |             unless verifier: request "Enter your PIN from Twitter: " [
298 |                 make error! "Not a valid PIN"
299 |             ]
300 | 
301 |             response: load-webform send/auth 'post access-broker make oauth! [
302 |                 oauth_verifier: trim/all verifier
303 |             ]
304 | 
305 |             persona/id: to-issue response/user_id
306 |             persona/name: response/screen_name
307 |             persona/token: response/oauth_token
308 |             persona/secret: response/oauth_token_secret
309 | 
310 |             persona
311 |         ]
312 |     ]
313 | ]
314 | 


--------------------------------------------------------------------------------
/ren-c/wordify.reb:
--------------------------------------------------------------------------------
  1 | Rebol [
  2 | 	Title: "Wordify"
  3 | 	Author: "Christopher Ross-Gill"
  4 | 	Date: 18-Oct-2011
  5 | 	Home: https://github.com/rgchris/Scripts
  6 | 	File: %wordify.reb
  7 | 	Version: 0.1.1
  8 | 	Purpose: "Reduce a string to a few core ASCII characters"
  9 | 	Rights: http://opensource.org/licenses/Apache-2.0
 10 | 	Type: module
 11 | 	Name: rgchris.wordify
 12 | 	Exports: [wordify unwordify]
 13 | 	History: [
 14 | 		12-Mar-2018 0.1.1 "Version for Ren-C"
 15 | 		18-Oct-2011 0.1.0 "Original Version"
 16 | 	]
 17 | 	Usage: {
 18 | 		>> wordify "Testing Iñtërnâtiônàlizætiøn"
 19 | 		== "testing-internationalizaetion"
 20 | 	}
 21 | ]
 22 | 
 23 | wordify: use [out emit alphanum punct extras extras-loose extras-tight codes chars clean-up][
 24 | 	alphanum: charset [#"0" - #"9" #"a" - #"z" #"A" - #"Z"]
 25 | 	punct: charset "!()" ; "*!',()"
 26 | 
 27 | 	codes: [
 28 | 		  copy chars some alphanum (emit chars)
 29 | 		| [#" " | #"-" | #"/" | #"_" | #"‑" | #"–" | #"—" | #"⁻" | #"₋" | #" "] (emit "-")
 30 | 		| [#"⁰" | #"₀"] (emit "0")
 31 | 		| [#"¹" | #"₁"] (emit "1")
 32 | 		| [#"²" | #"₂"] (emit "2")
 33 | 		| [#"³" | #"₃"] (emit "3")
 34 | 		| [#"⁴" | #"₄"] (emit "4")
 35 | 		| [#"⁵" | #"₅"] (emit "5")
 36 | 		| [#"⁶" | #"₆"] (emit "6")
 37 | 		| [#"⁷" | #"₇"] (emit "7")
 38 | 		| [#"⁸" | #"₈"] (emit "8")
 39 | 		| [#"⁹" | #"₉"] (emit "9")
 40 | 		| [#"Ä"] (emit "Ae")
 41 | 		| [#"À" | #"Á" | #"Â" | #"Ã" | #"Å" | #"Ā"] (emit "A")
 42 | 		| [#"ä"] (emit "ae")
 43 | 		| [#"ₐ" | #"ª" | #"à" | #"á" | #"â" | #"ã" | #"å" | #"ā"] (emit "a")
 44 | 		| [#"Ç" | #"Ć"] (emit "C")
 45 | 		| [#"ç" | #"ć"] (emit "c")
 46 | 		| [#"Ð"] (emit "D")
 47 | 		| [#"đ"] (emit "d")
 48 | 		| [#"È" | #"É" | #"Ê" | #"Ë"] (emit "E")
 49 | 		| [#"ₑ" | #"è" | #"é" | #"ê" | #"ë"] (emit "e")
 50 | 		| [#"ƒ"] (emit "f")
 51 | 		| [#"ğ"] (emit "g")
 52 | 		| [#"Ğ"] (emit "G")
 53 | 		| [#"I" | #"Ì" | #"Í" | #"Î"] (emit "I")
 54 | 		| [#"ì" | #"í" | #"î" | #"ī" | #"ı"] (emit "i")
 55 | 		| [#"Ï"] (emit "Ii")
 56 | 		| [#"ï"] (emit "ii")
 57 | 		| [#"Ñ"] (emit "N")
 58 | 		| [#"ⁿ" | #"ñ"] (emit "n")
 59 | 		| [#"№"] (emit "Nr")
 60 | 		| [#"Ö" | #"Œ"] (emit "Oe")
 61 | 		| [#"Ò" | #"Ó" | #"Ô" | #"Õ" | #"Ø"] (emit "O")
 62 | 		| [#"ö" | #"œ"] (emit "oe")
 63 | 		| [#"ₒ" | #"ð" | #"ò" | #"ó" | #"ô" | #"õ" | #"ø"] (emit "o")
 64 | 		| [#"Ş" | #"Š"] (emit "S")
 65 | 		| [#"ş" | #"š"] (emit "s")
 66 | 		| [#"ß"] (emit "ss")
 67 | 		| [#"Ú" | #"Ù" | #"Û"] (emit "U")
 68 | 		| [#"ù" | #"ú" | #"û"] (emit "u")
 69 | 		| [#"Ü"] (emit "Ue")
 70 | 		| [#"ü"] (emit "ue")
 71 | 		| [#"×"] (emit "x")
 72 | 		| [#"Ý" | #"Ÿ"] (emit "Y")
 73 | 		| [#"ý" | #"ÿ"] (emit "y")
 74 | 		| [#"Ž"] (emit "Z")
 75 | 		| [#"ž"] (emit "z")
 76 | 		| extras
 77 | 		| skip
 78 | 	]
 79 | 
 80 | 	extras-loose: [
 81 | 		copy chars some punct (emit chars)
 82 | 		| #"." (emit "_")
 83 | 		| [#"⁰" | #"₀"] (emit "(0)")
 84 | 		| [#"¹" | #"₁"] (emit "(1)")
 85 | 		| [#"²" | #"₂"] (emit "(2)")
 86 | 		| [#"³" | #"₃"] (emit "(3)")
 87 | 		| [#"⁴" | #"₄"] (emit "(4)")
 88 | 		| [#"⁵" | #"₅"] (emit "(5)")
 89 | 		| [#"⁶" | #"₆"] (emit "(6)")
 90 | 		| [#"⁷" | #"₇"] (emit "(7)")
 91 | 		| [#"⁸" | #"₈"] (emit "(8)")
 92 | 		| [#"⁹" | #"₉"] (emit "(9)")
 93 | 		| #"¼" (emit "(1-4)")
 94 | 		| #"½" (emit "(1-2)")
 95 | 		| #"¾" (emit "(3-4)")
 96 | 		| #"Æ" (emit "(AE)")
 97 | 		| #"æ" (emit "(ae)")
 98 | 		| #"©" (emit "(c)")
 99 | 		| #"°" (emit "(deg)")
100 | 		| #"º" (emit "(o)")
101 | 		| #"®" (emit "(r)")
102 | 		| #"™" (emit "(tm)")
103 | 	]
104 | 
105 | 	extras-tight: [
106 | 		  [#"⁰" | #"₀"] (emit "0")
107 | 		| [#"¹" | #"₁"] (emit "1")
108 | 		| [#"²" | #"₂"] (emit "2")
109 | 		| [#"³" | #"₃"] (emit "3")
110 | 		| [#"⁴" | #"₄"] (emit "4")
111 | 		| [#"⁵" | #"₅"] (emit "5")
112 | 		| [#"⁶" | #"₆"] (emit "6")
113 | 		| [#"⁷" | #"₇"] (emit "7")
114 | 		| [#"⁸" | #"₈"] (emit "8")
115 | 		| [#"⁹" | #"₉"] (emit "9")
116 | 		| #"¼" (emit "1-4")
117 | 		| #"½" (emit "1-2")
118 | 		| #"¾" (emit "3-4")
119 | 		| #"Æ" (emit "AE")
120 | 		| #"æ" (emit "ae")
121 | 		| #"©" (emit "c")
122 | 		| #"º" (emit "o")
123 | 		| #"°" (emit "deg")
124 | 		| #"®" (emit "r")
125 | 		| #"™" (emit "tm")
126 | 	]
127 | 
128 | 	clean-up: use [mk ex tm][
129 | 		[
130 | 			(tm: [end skip])
131 | 			mk: any "-" ex: (remove/part mk ex) :mk
132 | 			some [
133 | 				  mk: some "-" end (clear mk) :mk
134 | 				| "-" mk: some "-" ex: (remove/part mk ex) :mk
135 | 				| skip tm:
136 | 			]
137 | 			:tm end
138 | 		]
139 | 	]
140 | 
141 | 	out: ""
142 | 	emit: func [data][append out data]
143 | 
144 | 	func [text [string!] /case /loose][
145 | 		out: make string! 10 + length-of text
146 | 		extras: either loose [:extras-loose][:extras-tight]
147 | 
148 | 		all [
149 | 			parse/case text [any codes]
150 | 			parse out [clean-up]
151 | 			either case [out][lowercase out]
152 | 		]
153 | 	]
154 | ]
155 | 
156 | unwordify: use [out emit alpha digit punct codes char in-word][
157 | 	digit: charset [#"0" - #"9"]
158 | 	alpha: charset [#"a" - #"z" #"A" - #"Z"]
159 | 	punct: charset ["*!',()"]
160 | 
161 | 	codes: [
162 | 		copy char some alpha (
163 | 			emit either in-word [char][uppercase/part char 1]
164 | 			in-word: true
165 | 		)
166 | 		| copy char some digit (emit char in-word: true)
167 | 		| (in-word: true) "(1)" (emit #"¹")
168 | 		| "(2)" (emit #"²")
169 | 		| "(3)" (emit #"³")
170 | 		| "(1-4)" (emit #"¼")
171 | 		| "(1-2)" (emit #"½")
172 | 		| "(3-4)" (emit #"¾")
173 | 		| "(AE)" (emit #"Æ")
174 | 		| "(ae)" (emit #"æ")
175 | 		| "(c)" (emit #"©")
176 | 		| "(deg)" (emit #"°")
177 | 		| "(o)" (emit #"º")
178 | 		| "(r)" (emit #"®")
179 | 		| "(tm)" (emit #"™")
180 | 		| (in-word: false) "_" (emit #".")
181 | 		| "-" (emit " ")
182 | 		| copy char some punct (emit char)
183 | 		| skip
184 | 	]
185 | 
186 | 	out: ""
187 | 	emit: func [data][append out data]
188 | 
189 | 	func [word [string!]][
190 | 		out: make string! length-of word
191 | 		in-word: false
192 | 
193 | 		parse/case word [any codes]
194 | 		out
195 | 	]
196 | ]
197 | 


--------------------------------------------------------------------------------