[ALLY] Re: No email from this list
From: allenk:powerup:au at: 15-Dec-2000 8:29
Since there hasn't been anything for a while here is a demo that create
hyperlinks in txt styles. I hope line the emailer line wrapping doesn't ruin
this too much. Unfortuanately I can't get in touch with my ISP at the moment
and I can't upload.
Cheers,
Allen K
REBOL [
Title: "HyperLink Demo"
Author: "Allen Kamp"
Email: [allen--rebolforces--com]
Date: 15-Dec-2000
History: {
Modified and adapted for demo. Hyperlink code
by Allen Kamp and Gabriele Santilli.
}
]
msg: trim/auto {
This is a demo creates hyperlinks for the contents of the above txt
style.
Enter your text here and press the "show links" button to see it in
action.
Links in the format of http://www.rebol.com will be found and linked,
as will
this www.rebolforces.com
You can also launch web scripts with it in the format of
do http://www.rebol.com/feedback.r
or local files like so do %localfile.r
It also allows code to be evaluated like so do [request/ok "Hello
World"]
Many thanks to Gabriele (pictured)
do [inform layout [image http://web.tiscalinet.it/rebol/photo.jpg]]
who cleaned/improved up my initial parse code.
Note: For best results, text wrapping is turned off. Enjoy, Allen K}
; Hyperlinks
web: stylize [
link: txt leaf 400x20 font-size 11 with [
para: [wrap?: false]
action: [
either url? self/data [
error? try [browse self/data]
] [
error? try [do self/data]
]
]
]
]
make-link: func [
offset {Offset to place link}
url {url to perform action on}
txt {display text}
col {set a color for this link}
/local f
] [
f: make-face web/link
f/data: url
f/text: txt
f/offset: offset - 4x2
f/size/x: 2 + first size-text f
if col [set-font f 'color col set-font f 'colors reduce [col
f/font/colors/2]]
f/saved-area: true
f
]
add-hyperlinks: none
parser: context [
non-white-space: complement white-space: charset reduce [#" "
newline tab cr #"<" #">"]
to-space: [some non-white-space | end]
skip-to-next-word: [some non-white-space some white-space]
msg-face: none
match-pattern: func [pattern url color] [
compose [
mark:
(pattern) (either string? pattern [[to-space end-mark:]] [])
(to-paren compose [
text: copy/part mark end-mark
offset: caret-to-offset msg-face mark
insert tail msg-face/pane
make-link offset (either url [url] [[load text]])
text (color)
])
any white-space
]
]
link-rule: clear []
foreach [pattern url color] reduce [
"http://" none none
"www." [join http:// text] none
"ftp://" none none
"ftp." [join ftp:// text] none
"do http://" none crimson
"do %" none crimson
["do [" (end-mark: second load/next skip mark 3) :end-mark]
[first reduce [load text text: copy/part text 2]]
crimson
] [
insert insert tail link-rule match-pattern pattern url color '|
]
insert tail link-rule 'skip-to-next-word
; GC bug fixed now!
use [mark end-mark text offset] [bind link-rule 'mark]
set 'add-hyperlinks func [face] [
msg-face: face
error? try [parse/all face/text [any link-rule]]
]
]
clear-all: does [
tx/text: copy ""
tx/line-list: none
clear tx/pane
ta/text: copy ""
ta/line-list: none
]
view layout [
tx: txt 420x200 black ivory font-size 11 with [pane: copy [] para:
[wrap?: false]]
ta: area copy msg 420x200 font-size 11 with [pane: copy [] para: [wrap?:
false]]
across
button "Show Links" [clear tx/pane tx/text: ta/text add-hyperlinks tx
show tx]
button "Clear Links" [clear tx/pane show tx]
button "Clear All" [clear-all show [tx ta]]
button "Reset Text" [clear-all ta/text: copy msg show [tx ta]]
]
; script end