| View documentation | View discussion [246 posts] | View script | License |
| Download script | History | Other scripts by: inetw3dm |
17-Jan 19:46 UTC
[0.071] 74.424k
[0.071] 74.424k
 | Archive version of: rebol-dom-mdlparser ... version: 1 ... inetw3dm 8-Mar-2021Amendment note: new script || Publicly available? Yes REBOL [
File: %rebol-dom-mdlparser
Date: 02-11-2020
Title: "Dialect Object Model"
Emai: inetw3.dm@gmail.com
author: daniel murrill
Purpose: {
%Rebol-DOM.r mdlparser.r to view DOM as VID.
The Rebol-dom code in the mdlparser has not
been updated yet because some things will
break and become un-View-able. Ill be updating
it until all needed changes are complete. I'll
improve the mdlparser if anyone seems to care.
This parser is not optimized and for now only
used for demonstrating the DOM and HTML Dsl
usage with the VID.
This code is for my own personal R&D use. It was
really not meant to be public, but oh well.}
]
library: [
author: daniel murrill
level: 'intermediate
platform: 'all
type: Dialect
domain: [DOM html vid css json js array]
tested-under: 'windows
support: "disscusions email me"
license: shareware
see-also: %HTML-view.r
]
markup: {<meta name="date" content="21-May-2013/19:52:10-7:00"><body background-color="Darkgoldenrod" text="Darkviolet">
<div><div width="770" bgcolor="Midnightblue" style="color:Saddlebrown;border:1x1 'solid rgb(200, 80, 70);">qwerty
<b color="Chocolate" bgcolor='yellow'>cause<i color="green">i</i>Chocolate</b>like you</div>
<p><p><p color='Blanchedalmond', bgcolor="black">The <b color="green">%Rebol-DOM.r</b> uses the <b color="white">%Markup-Dialect-parser</b>
<i>(Mdlparser.r)</i> to parse xml, xhtml, css, and html Domain Specific Languages in order for them to be viewable/scriptable in a VID.
The %Mdlparser.r is not intended to be or used as a Rebol browser, but to be more in the spirit
of the Webkit engine that was first used for the chrome browser. Its ability to view some web
pages are limited due to HTTPS, javascript calls, improper and non standard use of html tags in web
pages that only the browsers' quirks-mode can render. There's also the Rebol out of memeory crash thing that needs
to be work out.
So what can you do with<b color="red">a Rebol-DOM and its' mdlparser</b> you ask?. With a little more time
and patience i'll hopefully, at least create an XML, XHTML or HTML browser front end with a Dialect Object Model
server back end. Why? So the programing language can be any DSL transcoded through a DOM and executed/viewed
in Rebol.</p><br />
<hr size=%100 color="gray" bgcolor="white" />
<ul color="red" bgcolor="Beige">
<li color="red"><b color="blue">My First Item</b></li>
<li color="orange"><b>Second Item</b></li>
</ul><br /><area color="red" bgcolor="red"></area>
<div class="boiler"width="700">By Carl<strong>Sassenrath</strong>Revised: 1-Feb-2010 Original: 23-Oct-2005</div>
<table cell="0" cell="0" style=width:386;>
<TR color="orange" BGCOLOR="Mediumorchid">
<TD><TD width="4%"><b>0</b></TD>
<TD width="33%"><b><FONT COLOR="white"><i>itselfproject</i></FONT></TD></TD><TD>
<TD width="22%"><b><FONT COLOR="white">skill level</FONT></b></TD>
<TD width="21%"><b><FONT COLOR="white">study time</FONT></b></TD>
<TD width="20%"><b><FONT COLOR="white">edit/test</FONT></b></TD>
</TR>
<TR COLOR="green" BGCOLOR="#CCFFFF">
<TD BGCOLOR="#666666" width="4%"><b><FONT COLOR="white">1</FONT></b></TD>
<TD BGCOLOR="#CCFFFF" width="33%">create a single-page reblet</TD>
<TD width="20%">novice</TD>
<TD width="22%">5 m</TD>
<TD width="21%">5 m</TD>
</TR><TR BGCOLOR="#CCFFFF">
<TD BGCOLOR="#666666" width="4%"><b><FONT COLOR="white">2</FONT></b></TD>
<TD width="33%">create a multi-paged reblet</TD>
<TD width="22%">novice</TD>
<TD width="21%">10 m</TD>
<TD width="20%"><button value="Hi" color="Orchid" bgcolor="Teal" size=" " onclick="goo" />Click on Hi</TD>
</TR></table><br />
<b color="yellow" bgcolor="orange">language<a href="http://www.rebol.com/what-rebol.html"><i color="green">itself</i></a></b>
<input type="submit" value="ClickMe!" onclick="gogo" /><br /><br /><input type="button" value="checkbox this" style="color:yellow;bgcolor:Teal;border:4x2 solid rgb(100, 10, 10);" /><br /><p color="Indianred">Good by</p><br>Mediumpurple
<input type="search" bgcolor="YellowGreen" value="peanut butter"/>
<br /><p width="240" height="40px" style="color:Saddlebrown;bgcolor:red;border:1x1 solid rgb(20, 80, 10);">Hello with<b color="yellow">one more time<i color="#00ff00">value</i></b>Saddle</p>
<br /><button value="hello" color="green" />
<input type="button" value="Good button" color="Mediumpurple"/>
<br /><p color="Indianred">Good by</p><br /><input type="field" value="hello" /><input type="checkbox">
<br /><p color="#ff0000">Hello<span color="Chocolate">middle with</span><i color="#00ff00">every</i>
<b color="#0000ff">one</b></p><br /><button value="hello" color="Sienna" />
<input type="button" value=" " color="purple" />
<br /><p color="Indianred">Good by</p><br /><input type="field" value="hello"/>
<br /><p color="#ff0000">Hello with<i color="#00ff00">every</i><b color="#0000ff">one</b></p><span color="red">should be red</span>
<br /><button value="hello" color="Peachpuff" /><input type="button" value="Good by" color="Mediumpurple" />
<br /><p color="orange">Good by</p><br /><input type="field" value="hello" /> </body>}
bold: 'bold
macros:[
"&" "&"
"<" "<"
">" ">"
""" {"}
"ä" "ä"
"Ä" "Ä"
"ö" "ö"
"Ö" "Ö"
"ü" "ü"
"Ü" "Ü"
"ß" "ß"
]
histobj: []
markup-hexcolors: func [Dialect-colors] [
foreach [word-color with-hexcolor] incolor-series [replace/all Dialect-colors word-color :with-hexcolor]
]
incolor-series: to-hash [
"Aliceblue" "#F0F8FF"
"Antiquewhite" "#FAEBD7"
"Aqua" "#00FFFF"
"Aquamarine" "#7FFFD4"
"Azure" "#F0FFFF"
"Base-color" "#8F7F6F"
"Beige" "#FFE4C4"
"Bisque" "#FFE4C4"
"Black" "#000000"
"Blueviolet" "#8A2BE2"
"Blanchedalmond" "#FFEBCD"
"Brown" "#A52A2A"
"Brick" "#B22222"
"Burlywood" "#DEB887"
"Cadetblue" "#5F9EA0"
"Chartreuse" "#7FFF00"
"Coal" "#404040"
"Coffee" "#4C1A00"
"Chocolate" "#D2691E"
"Coral" "#FF7F50"
"Cornflowerblue" "#6495ED"
"Cornsilk" "#FFF8DC"
"Crimson" "#DC143C"
"Cyan" "#00FFFF"
"Darkblue" "#00008B"
"Darkcyan" "#008B8B"
"Darkgoldenrod" "#B8860B"
"Darkgray" "#A9A9A9"
"Darkgreen" "#006400"
"Darkkhaki" "#BDB76B"
"Darkmagenta" "#8B008B"
"Darkolivegreen" "#556B2F"
"Darkorange" "#FF8C00"
"Darkorchid" "#9932CC"
"Darkred" "#8B0000"
"Darksalmon" "#E9967A"
"Darkseagreen" "#8FBC8F"
"Darkturquoise" "#00CED1"
"Darkslateblue" "#483D8B"
"Darkslategray" "#2F4F4F"
"Darkviolet" "#9400D3"
"Deepskyblue" "#00BFFF"
"Dimgray" "#696969"
"Firebrick" "#B22222"
"Floralwhite" "#FFFAF0"
"Forest" "#003000"
"Forestgreen" "#228B22"
"Fuchsia" "#FF00FF"
"Gainsboro" "#DCDCDC"
"Ghostwhite" "#F8F8FF"
"Gold" "#FFCD28"
"Goldenrod" "#DAA520"
"Gray" "#808080"
"Green" "#00FF00"
"Greenyellow" "#ADFF2F"
"Honeydew" "#F0FFF0"
"Hotpink" "#FF69B4"
"Indianred" "#CD5C5C"
"Indigo" "#4B0082"
"Ivory" "#FFFFF0"
"Khaki" "#F0E68C"
"Lavender" "#E6E6FA"
"Lavenderblush" "#FFF0F5"
"Lawngreen" "#7CFC00"
"Lemonchiffon" "#FFFACD"
"Lightblue" "#ADD8E6"
"Lightcoral" "#F08080"
"Lightcyan" "#E0FFFF"
"Lightgoldenrodyellow" "#FAFAD2"
"Lightgreen" "#90EE90"
"Lightgrey" "#D3D3D3"
"Lightpink" "#FFB6C1"
"Lightsalmon" "#FFA07A"
"Lightseagreen" "#20B2AA"
"Lightskyblue" "#87CEFA"
"Lightslategray" "#778899"
"Lightyellow" "#FFFFE0"
"Lime" "#00CD00"
"Limegreen" "#32CD32"
"Linen" "#FAF0E6"
"Leaf" "#008000"
"Magenta" "#FF00FF"
"Maroon" "#800000"
"Mint" "#648874"
"Mediumauqamarine" "#66CDAA"
"Mediumblue" "#0000CD"
"Mediumorchid" "#BA55D3"
"Mediumpurple" "#9370D8"
"Mediumseagreen" "#3CB371"
"Mediumslateblue" "#7B68EE"
"Mediumspringgreen" "#00FA9A"
"Mediumturquoise" "#48D1CC"
"Mediumvioletred" "#C71585"
"Midnightblue" "#191970"
"Mintcream" "#F5FFFA"
"Mistyrose" "#FFE4E1"
"Moccasin" "#FFE4B5"
"Navajowhite" "#FFDEAD"
"Navy" "#000080"
"Oldrab" "#484810"
"Olive" "#808000"
"Olivedrab" "#688E23"
"Orange" "#FFA500"
"Orangepumpkin" "#FFA500"
"Orangered" "#FF4500"
"Orchid" "#DA70D6"
"Papaya" "#FF5025"
"Palegoldenrod" "#EEE8AA"
"Palegreen" "#98FB98"
"Paleturquoise" "#AFEEEE"
"Palevioletred" "#D87093"
"Papayawhip" "#FFEFD5"
"Peachpuff" "#FFDAB9"
"Peru" "#CD853F"
"Pewter" "#AAAAAA"
"Pink" "#FFC0CB"
"Palepink" "#FFC0CB"
"Plum" "#DDA0DD"
"Powderblue" "#B0E0E6"
"Purple" "#800080"
"Rebolor" "#8E806E"
"red" "#FF0000"
"Rosybrown" "#BC8F8F"
"Royalblue" "#4169E1"
"Saddlebrown" "#8B4513"
"Salmon" "#FA8072"
"Sandybrown" "#F4A460"
"Seagreen" "#2E8B57"
"Seashell" "#FFF5EE"
"Sienna" "#A0522D"
"Silver" "#C0C0C0"
"Sky" "#A4C8FF"
"Skyblue" "#87CEEB"
"Slateblue" "#6A5ACD"
"Slategray" "#708090"
"Snow" "#FFFAFA"
"Springgreen" "#00FF7F"
"Steelblue" "#4682B4"
"Tan" "#D2B48C"
"Teal" "#008080"
"Thistle" "#D8BFD8"
"Tomato" "#FF6347"
"Turquoise" "#40E0D0"
"Violet" "#EE82EE"
"Water" "#506C8E"
"Wheat" "#F5DEB3"
"White" "#FFFFFF"
"Whightsmoke" "#F5F5F5"
"Yellow" "#FFFF00"
"YellowGreen" "#9ACD32"
"Blue" "#0000ff"
"&" "&"
"<" "<"
">" ">"
""" {"}
"ä" "ä"
"Ä" "Ä"
"ö" "ö"
"Ö" "Ö"
"ü" "ü"
"Ü" "Ü"
"ß" "ß"
"!--" ""
"%100" "%99"
"100%" "99%"
<head> <body background-color="#FFFFFF" text="#000000">
"backdrop-color" "bgcolor"
"background-color" "bgcolor"
{a# } <a > { #a} </a>
]
center: 'center
markup-DTD: func [DTD] [
foreach [doc-tag with-definition] in-dtd [replace/all DTD doc-tag with-definition]
]
in-dtd: [
"!--" ""
" " {""}
"64-" "64 "
"&#" " "
"%100" "%99"
"100%" "99%"
<body> <body background-color="#FFFFFF" text="#000000">
"body bgcolor" "body background-color"
]
get-color: does [either error? try [
baseclr: to-tuple debase/base baseclr 16] [this-color?] [this-color: any [baseclr this-color]]
]
color=: func [this-color][
parse/all to-string this-color [(baseclr: "") to "#"
copy baseclr to end]
this-color?: txt-clr
either find baseclr "#" [baseclr: to-issue next baseclr get-color][this-color: txt-clr]
]
bgcolor=: func [this-color][
parse/all to-string this-color [(baseclr: "") to "#"
copy baseclr to end]
this-color?: bkclr
either find baseclr "#" [baseclr: to-issue next baseclr get-color][this-color: bgclr]
]
quote-node-attributes: does [with-these-attributes: copy ""
trim/tail in-node-element
if #"/" = last in-node-element [remove back tail in-node-element]
this-node: form find/match in-node-element node-name: first parse/all in-node-element { =">}
foreach [-char +char][
#"^/" " " {:"} {"} ": {" "=true {"
{ ="" } {="" } { ="} " " {"=""} " " {="" } {" }][replace/all in-node-element -char +char]
parse in-node-element [some [to
"[" copy blk thru "," copy blk2 thru "]" (
replace in-node-element array: join blk blk2
replace/all trim/all copy array {","} "_")]skip
]
if find/any this-node "style=" [
parse/all this-node [[to {style="} | to "style="] copy style-obj [thru {;" } | thru {;">} | thru {;>} | thru {;"} | thru {" } | thru {>} | thru "}," | to end](*style.node: copy style-obj
foreach [style-chars found-with-in] tag-tokens/style-obj-chars [replace/all *style.node style-chars found-with-in]
replace this-node style-obj *style.node
)]
]
replace node-name "<" ""
;replace/all this-node {=""} {=null}
replace/all this-node "://" "&&"
foreach part replace/all this-node: parse/all this-node {<{} =":;[]>} [""] [] [
part: any [if find/match part "'" [
replace/all part "'" ""
]
part
]
replace/all part {,} " "
replace/all part {__} " "
replace/all part "&&" "://"
replace part {=null} {=""}
append with-these-attributes mold part
]
]
create-tag-element: func [these-attr][
in-attribute-blk: to-block these-attr
foreach [attr-name attr-value] in-attribute-blk [
replace in-attribute-blk attr-name to-word attr-name
attempt [trim attr-value]
]
attempt [insert in-attribute-blk to-word node-name]
data-node: build-tag in-attribute-blk
]
this-width: 100
div: prg: tbl: tds: hd: lst: ul: spn: fnt: 0
img: hrl: fld: btn: txt-btn: hdn: chk: rdo: txt-sz: width=: 0
Dialect: ""
div-x: tbl-x: para-x: hr-x: face-x: tdx: x-size: gt-str-sz: 0x0
slf: child: as-methods: last-node: with-these-attributes: ""
styles: .style: ""
imgurl: go-here: copy []
parent-sz: font-size=: str-sz: 0
DOM: face-styles: " " fnt-styles: [] fnt-style: ""
data-node: face-node: node-name: node-type: tag-node: tag-head: text-node:
in-parent?: in-parent-node: in-node?: end-tag-token?: slf*: none
div_clr: p_clr: tb_clr: tr_clr: td_clr: ul_clr: li_clr: f_clr: b_clr: i_clr: clr: txt-clr: border=: none
div_bgclr: p_bgclr: tb_bgclr: tr_bgclr: td_bgclr: ul_bgclr: li_bgclr: f_bgclr: b_bgclr: i_bgclr: bgclr: bkclr: none
fnt-nm: ""
.border?: border?: does [if not none = border= [
border: to-block foreach [a b]["(" "" ". " "." ")" ""] [replace/all border= a b]
append face-styles to-string reduce [
to-path reduce [slf 'edge 'size] ": " either attempt [pair: first find border pair!][pair][0x0] " "
to-path reduce [slf 'edge 'color] ": " clr: first any [find border tuple! 0.0.0] " show " slf " "] ]
]
.color?: color?: does [append face-styles to-string reduce ["foreach fclr " to-path reduce [slf 'pane] " [if clr != fclr/effect/draw/pen [fclr/effect/draw/pen: " clr " show fclr]] "]]
]
.bgcolor?: bgcolor?: does [append face-styles to-string reduce ["foreach clr " this: to-path reduce [slf 'pane] " [if bgclr != " to-path reduce [slf 'color] " [clr/color: " bgclr " ] show clr] " slf "/color: " bgclr " show " slf " "]
]
.font-size?: font-size?: does [if none != font-size= [append face-styles to-string reduce [
" foreach fnt " to-path reduce [slf 'pane] { [ if error? try [fnt-style: to-word fnt/effect/draw/font][][fnt-style: font_] }
join fnt-style font-size= {: make face/font any [attempt [font_]attempt[b.]] fnt/effect/draw/font: } join fnt-style font-size= " "
join fnt-style font-size= {/size: }
font-size= " show fnt ]" ] ]
]
.font-style?: font-style?: does [if font-style= [append face-styles to-string reduce [" foreach fnt " to-path reduce [slf 'pane] " [fnt-style: font_ *fnt: fnt/effect/draw replace *fnt select *fnt fnt-style/style " font-style= " show fnt ]"]]font_/style: none]
.width?: width?: does [attempt [append face-styles to-string reduce [" " width=: to-path reduce [slf 'size 'x] ": " face-x/x: any [face-x width=] " show " slf " "]]]
`
select-this: func [this-token][
do select tag-tokens reduce this-token
]
tag-tokens: to-hash [
body [bgclr: clr: none clear-colors in-parent?: false][{ backcolor } bkclr { backdrop } imgurl " effect [merge] " {below across } ]
/body [][{}]
div [parent-sz: div-x: face-x div_clr div_clr: clr div_bgclr: bgclr divs: divs + 1][{ below across space 10 }]
/div [face-x: div_clr: div_bgclr: none ][{ close. } div-x " " div_bgclr { edge [] below }]
area [ar-x: any [face-x 100x50]][{ below across area #text } ar-x " "]
/area [ar-x: face-x: none][{ close. } bgclr " "]
textarea [ar-x: any [face-x 100x50]][{ below across area #text } ar-x " "]
/textarea [ar-x: face-x: none][]
p [parent-sz: para-x: face-x p_bgclr: bgclr p_clr: clr append main { below across } prg: prg + 1][{ below across } ]
/p [p_bgclr: p_clr: face-x: none border?][{ close. } para-x " " p_bgclr { edge [] }]
li [face-x: any [size= none] li_clr: any [clr ul_clr] li_bgclr: any [bgclr ul_bgclr txt-clr] lst: lst + 1][{ space 0 across box 16x20 } li_bgclr { effect [draw [fill-pen } li_clr { pen } li_clr { circle 3x8 2]] }]
/li [face-x: li_clr: li_bgclr: bgclr: clr: none ][{ close. below across }]
ul [in-parent?: false ul_bgclr: bgclr ul_clr: clr bgclr: clr: none ul: ul + 1][" across "]
/ul [ul_bgclr: ul_clr: bgclr: clr: none clear-colors][{ close. }]
tbody [tbl: tbl + 1][]
/tbody [][{}]
/table [parent-sz: tbl-x: tb_clr: tb_bgclr: none][{ close. } " " tb_bgclr " edge [] "]
table [parent-sz: tbl-x: face-x face-x: none get-colors tb_clr: clr tb_bgclr: bgclr tbl: tbl + 1][{ guide }]
td [parent-sz: tdx: any [face-x tbl-x] td_bgclr: bgclr td_clr: clr get-colors tds: tds + 1][{ across }]
/td [td_bgclr: td_clr: parent-sz: tdx: none][{] } tdx " " td_bgclr { edge [color: silver size: 1x1 effect [ibezel]] }]
tr [tr_bgclr: bgclr tr_clr: clr get-colors][{ across space 0 }]
/tr [tdx: tb_clr: td_clr: tr_clr: clr: none][{ return }]
b [to-font 'b. get-colors b_bgclr: bgclr b_clr: clr][face-node: { space 0 box #bgclr #string-size effect [draw [pen #clr font #font text #text ]] }]
i [to-font 'i. get-colors i_bgclr: bgclr i_clr: clr][face-node: { space 0 box #bgclr #string-size effect [draw [pen #clr font #font text #text ]] }]
a [to-font 'u. get-colors attempt [go-here: to-url styles/href=]][]
/b [remove-font 'b. b_clr: b_bgclr: none][]
/i [remove-font 'i. i_clr: i_bgclr: none][]
/a [remove-font 'u. remove-style ][{ [attempt [markup: read } go-here { update clear Dialect html/text: } go-here { show html] ] }]
font [f_bgclr: bgclr f_clr: clr get-colors][{ space 0 box #bgclr #string-size effect [draw [pen #clr font #font text #text ]] }]
/font [f_clr: f_bgclr: none remove-style][{ }]
span [f_clr: any [clr txt-clr]bgclr: any [bgclr bkclr]][{ space 0x20 box #bgclr #string-size effect [draw [pen #clr font #font text #text ]] }]
/span [face-x: f_clr: f_bgclr: none remove-style][]
br [face-x: none clear styles clear-colors ][{ below across }]
button [btn-sz: size= btn: btn + 1][{ button } btn-sz " " value= " font-color " clr " " bgclr " [" onclick= "] "]
btn [ btn-sz: size= btn: btn + 1][{ btn } btn-sz " " value= " font-color " clr " " bgclr " [" onclick= "] "]
text [txt-sz: size= fld: fld + 1][{ field } value= { edge [size: 1] effect [draw [pen silver line-width 1 box ]] font-color } clr " "]
field [fld: fld + 1][{ field } value= { edge [size: 1] effect [draw [pen silver line-width 1 box ]] font-color } clr " "]
search [btn-sz: size= ][{ field } value= " " btn-sz " edge [size: 1] effect [draw [pen silver line-width 1 box ]] font-color " clr " "]
select [btn-sz: size= in-parent?: false][{ choice }]
submit [btn-sz: size= btn: btn + 1][{ button } btn-sz " " value= " " clr " [" onclick= "] "]
password [btn-sz: size= fld: fld + 1][{ field } value= " " btn-sz " edge [size: 1] effect [draw [pen silver line-width 1 box ]] font-color " clr " "]
option [][{ #text }]
/option [][]
hidden [hdn: hdn + 1][""]
input [size=: any [size= []] fld: fld + 1]['field " " value= { font-color } clr " " ]
check [chk: chk + 1][{ space 12 check }]
checkbox [chk: chk + 1][{ space 12 check }]
radio [rdo: rdo + 1][{ radio space 12 } ]
H1 [in-parent?: false hd: hd + 1][{ below text }]
H2 [in-parent?: false hd: hd + 1][{ below text }]
H3 [in-parent?: false hd: hd + 1][{ below H2 }]
H4 [in-parent?: false hd: hd + 1][{ below H3 }]
H5 [in-parent?: false hd: hd + 1][{ below H4 }]
H6 [in-parent?: false hd: hd + 1]{ below text }
/H1 [ remove-style]{ font-size 32 below across }
/H2 [ remove-style]{ font-size 24 below across }
/H3 [ remove-style]{ below across }
/H4 [ remove-style]{ below across }
/H5 [ remove-style]{ below across }
/H6 [ remove-style]{ font-size 10 below across }
hr [ hrl: hrl + 1][{ panel [ box } clr " " (as-pair hr-x - .5 1) { bevel 2 pad 0x-11 box } bgclr " " (as-pair hr-x - .5 2){] below across }]
/hr [in-parent?: false ][{ close. below across } ]
strong [to-font 'b. get-colors b_clr: clr b_bgclr: bgclr][{ space 0 box #bgclr #string-size effect [draw [pen #clr font #font text #text ]] }]
/strong [remove-font 'b. b_clr: b_bgclr: none][]
img [img: img + 1][{ image } img-url " " face-x " "]
newline [""][{ below across }]
style-obj-chars ["<" "" {style="} " " {style=} " " " : " { "} ": " { "} ":" {*"} " " {__} {=""} { " " } "=" {*"} ";" {"*} {""} {"} { "} {"} {*"} { "} {"*} {" } " >" "" ">" "" "rgb" "" {__"} {"} {" "} {"} "," "."]
elemt-chars ["{" "}" {"} "(" ")" "/" "." "[" "]" "," ":" ";" "," "="]
obj-chars [":" " " ";" " " "," " " "=" " "]
]
parse-html: func [Dialect][
markup-DTD Dialect
bkclr: none
return-parent-width: does [
these-children: copy children
replace/all replace/all children "^/" "" <newline> " "
replace/all Dialect "> " ">"
in-parent-node: load/markup children str-sz: 0
foreach txt-node in-parent-node [
if string! = type? txt-node [str-sz: str-sz + string-size? txt-node
replace in-parent-node txt-node txt-node*: parse txt-node " "
]
]if str-sz = 0 [parent-width: 615]
quote-node-attributes
create-tag-element with-these-attributes
parent-width: get-size select in-attribute-blk 'width
if parent-width = 0 [switch node-name [
"div" [parent-width: 800]
"p" [parent-width: 800]
"p" [parent-width: 800]
"td" [replace/all in-parent-node "<br" "<span " parent-width: str-sz]
"li" [parent-width: 800]
]
if parent-width = 0 [parent-width: 800]
]
replace Dialect in-node-element data-node
txt-sz: 0
foreach child-element in-parent-node [
with-these-children: [] each-node: type? child-element
either string! = each-node [string-size? child-element face-x: face-x + 9
txt-sz: txt-sz + face-x
either txt-sz <= parent-width [append with-these-children child-element][
txt-sz: face-x append with-these-children reduce [<newline> child-element]]
][append with-these-children child-element if find child-element "br" [txt-sz: 0]]
]
size-x: txt-sz: 0
replace Dialect these-children form with-these-children
;replace/all replace/all Dialect "<<" "<" ">>" ">"
]
replace/all Dialect "> " ">"
validate-or-remove: func [with-end-tag][
either none = children [replace Dialect in-node-element " "][
if children [if not find children with-end-tag [replace Dialect children children: join children with-end-tag
] if </td> != end-tag [attempt [return-parent-width]]]
]
]
in?: ["<div" | "</div" | </body>]
parse/all Dialect [any[
[to "<div" copy in-node-element thru ">"
copy children [to "<div" | to </body>]
(validate-or-remove end-tag: </div>)
]|
[to "<div" copy in-node-element thru ">"
copy children thru </div>
(validate-or-remove end-tag: </div>)
]|
[to "<div" copy bad-node-element thru ">"
copy children [any in?]
(if none != children [replace Dialect bad-node-element ""])
]
]skip
]
in-node?: []
in-node?: [ "<table" | "</table" | "</body"]
parse/all Dialect [any[
[to "<table" copy in-node-element thru ">"
copy children to "<table"
(validate-or-remove end-tag: </table>)
]|
[to "<table" copy in-node-element thru ">"
copy children thru </table>
(validate-or-remove end-tag: </table>)
]
]skip
]
parse/all Dialect [some[to
"<table" copy bad-node-element thru ">"
copy children any in-node?
(if none != children [replace Dialect bad-node-element ""])
]skip
]
insert replace in?: copy in-parent_elem-type! [| "<ul" | "<li"] [] 'to
parse/all Dialect [some[
to "<ul" copy in-node-element thru ">"
copy children [thru "</ul>" | to "<ul" | in? | to "<br" | to "</body>"]
(validate-or-remove </ul> end-tag: </ul>)
]skip
]
parse/all Dialect [some[to
"<tr" thru ">"
copy children thru "</td>" copy ending to "<tr"
(append children ending validate-or-remove end-tag: </tr>)
]skip
]
in-node?: [] append append insert in-node? in-parent_elem-type! [| "<h" | "</" |] out-parent_elem-type!
in?: [] append append insert in? [to] in-node? [| "<fieldset"] replace/all in? [|] [| to]
replace/all Dialect "<p><p" "<p"
parse/all Dialect [some[to
"<p" copy bad-node-element thru ">"
copy invalid-node [any in-node?]
(if invalid-node [replace Dialect bad-node-element ""])
]skip
]
parse Dialect [some[to
"<p" copy in-node-element thru ">"
copy children to "<p"
(validate-or-remove end-tag: </p>)
]skip
]
parse Dialect [some[to
"<p" copy in-node-element thru ">"
copy children thru </p>
(validate-or-remove end-tag: </p>)
]skip
]
parse/all Dialect [any[to
"<li " copy in-node-element thru ">"
copy children thru "</li>"
(validate-or-remove end-tag: </li>)
]skip
]
parse/all Dialect [some[to
"<li" copy in-node-element thru ">"
copy children [thru "</li>" | "<li>" |"</UL>"]
(validate-or-remove end-tag: </li>)
]skip
]
parse/all Dialect [any[
[to "<td" copy bad-node-element thru ">"
copy children any ["</" | "<td" | "<table" | "<div"]
(if none != children [replace Dialect bad-node-element ""])
]|
[to "<td" copy in-node-element thru ">"
copy children to "<td"
(replace children "<br" "<span" validate-or-remove end-tag: </td>)
]|
["<td" copy in-node-element thru ">"
copy children [thru "</td>" | [any "</tr" | "<tr" | "<table"]]
(replace children "<br" "<span" validate-or-remove end-tag: </td>)
]
]skip
]
{parse/all Dialect [some[to
"<a " copy element thru ">"
(this: copy element
foreach [a b][
"?" {" } "-" "_" "=" {="} "&" { " } "+" "_" "%25" "_" ">" {">} {" ">} {">} {""} {"}][replace/all this a b
]
replace Dialect element this)
]skip
]}
]
;;;;;;;;;;not used: old reference code only;;;;;;;;;;;
{preformated: func[][parse markup [thru "<pre>" copy pretext to "</pre>" (
oldpretext: copy pretext
replace/all pretext ">" ">" replace/all pretext "<" "<"
parse/all markup [to oldpretext begin: thru oldpretext ending:(change/part begin pretext ending )]
foreach [old new] macros[
parse/all pretext [some[to old begin: thru old ending:(change/part begin new ending )]skip]
]
insert main reduce [pretext 'text ])]
]
};;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
make-face-obj: func [][
self: mold to set-word! to string! reduce [last-node: copy node-name select-this tag-token: to word! node-name]
face-obj: reduce first skip find tag-tokens tag-token 2
slf: to word! first slf: parse self ":"
foreach style-request [font-style? border?][attempt [do style-request]]
]
get-size: func [this.width][in-size: "" this.width: form this.width
*y: 20 attempt [*y: parent-sz/y]
attempt [parent-sz: parent-sz/x]
attempt [div-x: div-x/x]
attempt [hr-x: hr-x/x]
;attempt [para-x: para-x/x]
attempt [tbl-x: tbl-x/x]
parse this.width [[(unit-type: "none") to #"%" (unit-type: "%") | to "px" (unit-type: "px") | to "pt" (unit-type: "pt")]to end]
if error? try [to-integer replace this.width unit-type ""][this.width: 0 unit-type: "none"]
switch unit-type [
"%" [replace in-size: parse this.width "%" "" []
if empty? in-size [in-size: to-block mold form length? value=]
either 1 = length? in-size/1 [insert in-size/1 ".0" percent-size: to-decimal load in-size/1][insert in-size/1 "." percent-size: to-decimal load in-size/1]
this.width: as-pair to-integer percent-size * either find/any ["button" "submit"] node-name [any [parent-sz string-size? value=]][any [600 - 10]] *y]
"px" [replace/all in-size: parse this.width "px" "" [] this.width: attempt [to-integer in-size/1]]
"pt" [replace/all in-size: parse this.width "pt" "" [] this.width: attempt [to-integer in-size/1]]
"none" [if in-size: attempt [to-integer this.width] [this.width: in-size]]
]
]
get-attributes: func [element-node][
in-node-element: node-element: element-node
quote-node-attributes
create-tag-element with-these-attributes
markup-hexcolors styles: next node: to-block child: data-node
if all [as-methods not find child "." ][use-attr-as-methods yes]
slf: to-word any [slf* node/1]
bkclr: any [bkclr bkclr: bgcolor= any [select styles 'background-color= "#ffffff"]]
attempt [get-image styles/background-image= imgurl: img-url]
bgclr: bgcolor= any [select styles 'bgcolor= select styles '.bgcolor=]
txt-clr: any [ color= select styles 'text= txt-clr 0.0.0]
clr: color= any [select styles '.color= select styles 'color= ]
value=: form mold any [select styles 'value= ""]
either parent-sz [parent-sz][parent-sz: as-pair 10 / string-size? value= 0]
size=: any [hr-x: get-size select styles 'size= ]
border=: attempt [styles/border=]
font-size=: any [get-size select styles 'font-size= ]
font-style=: any [select styles 'font-style= ]
either 0 != size= [size= ][size=: none]
valign=: any [select styles 'valign= ""]
width=: any [get-size select styles 'width=]
height=: any [get-size select styles 'height= 20]
either not find reduce [width= height=] 0 [face-x: as-pair width= height= ][
either 0 != width= [face-x: width=][face-x: width=: none]]
alt=: any [select styles 'alt= ""]
onclick=: any [attempt [to-word select styles 'onclick= ]]
get-image select styles 'src= styles: head styles
]
set-attributes: does [
either empty? styles [
=: :equal?
remove replace .style: to-tag mold node-element last .style ""
get-attributes build-tag to-block .style
foreach [attr attrv] next styles [(attempt [do load replace form attr "=" "?"])]
do face-styles show page clear face-styles
][
parse styles [some[ to word! attr: to string! (attempt [do load replace form copy attr "=" "?"])]skip]
]
do face-styles show page clear face-styles
]
get-colors: does [
clr: any [clr f_clr i_clr b_clr div_clr p_clr td_clr tr_clr tb_clr li_clr ul_clr txt-clr]
bgclr: any [bgclr f_bgclr i_bgclr b_bgclr div_bgclr p_bgclr td_bgclr tr_bgclr tb_bgclr li_bgclr ul_bgclr bkclr]
]
clear-colors: does [
div_clr: p_clr: tb_clr: tr_clr: td_clr: ul_clr: li_clr: f_clr: b_clr: i_clr: clr: none
div_bgclr: p_bgclr: tb_bgclr: tr_bgclr: td_bgclr: ul_bgclr: li_bgclr: f_bgclr: b_bgclr: i_bgclr: bgclr: none
remove-font remove-style
]
get-input-type: func [in-form-element][
if "button" = node-name [node-name: 'btn]
if "input" = node-name [node-name: first to block! node-type: find/match in-form-element {input type=}]
if "" = node-name [node-name: "input"]
node-name: form any [node-name "input"]
]
to-font: func [style?][
insert fnt-styles style?
]
get-fnt-styles: func [][either not empty? fnt-styles [fnt-style: trim/all form sort unique fnt-styles][fnt-style: "font_"]
replace main "#font" fnt-style
]
string-size?: func [txt-string][text-face: layout/tight [text txt-string] face-x: text-face/size/x]
get-string-size: func [txt-string][txt-string: form txt-string
any [attempt [face-x: face-x/x] face-x face-x: none]
any [
if "b." = fnt-style [text-face: layout/tight [text txt-string bold font-size 16]
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
if "i." = fnt-style [text-face: layout/tight [text txt-string italic font-size 16]
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
if "u." = fnt-style [text-face: layout/tight [text txt-string underline font-size 16 ]
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
if "i.u." = fnt-style [text-face: layout/tight [text txt-string italic underline font-size 16]
i./valign: 'top
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
if "b.i." = fnt-style [text-face: layout/tight [text txt-string bold italic font-size 16 ]
b.i./valign: 'top
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
if "b.u." = fnt-style [text-face: layout/tight [text txt-string bold underline font-size 16 ]
b.i./valign: 'top
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
if "b.i.u." = fnt-style [text-face: layout/tight [text txt-string bold italic underline font-size 16]
b.i./valign: 'top
either face-x [replace main "#string-size" as-pair face-x 20][
replace main "#string-size" as-pair text-face/size/x - 18 20 text-face: ""]
]
]
any [attempt [face-x: face-x/x] face-x face-x: none]
if find main "#string-size" [text-face: layout/tight [text txt-string font-size 16]
replace main "#string-size" as-pair text-face/size/x - 12 20 text-face: ""]
face-x: none
]
remove-style: does [
border=: parent-sz: width=: height=: div-x: para-x: font-size=: face-x: none bgclr: any [i_bgclr b_bgclr li_bgclr ul_bgclr td_bgclr tr_bgclr tb_bgclr p_bgclr div_bgclr bkclr]
clr: any [b_clr i_clr li_clr ul_clr td_clr tr_clr tb_clr p_clr div_clr txt-clr]replace main "#text" ""
]
remove-font: func [style?][
replace/all fnt-styles style? []
]
url-address: "http://www.rebol.com"
get-image: func [img-src] [the.image: ""
img-src: any [img-src img-src: "image"]
switch img-src/1 [
#"h" [replace img-src "p/" "p:/" the.image: to string! reduce img-src]
#"/" [either img-src/2 = #"/" [the.image: to string! reduce ["http:" img-src]][the.image: to string! reduce [url-address img-src]]]
#"w" [the.image: to string! reduce ["http://" img-src]]
#"%" [the.image: to-file img-src ]
]
image-type: [".png" ".jpg" ".gif"]
either find the.image any image-type [img-url: load the.image] [img-url: the.image]
]
font_: make face/font [style: [] size: 16]
b.: make face/font [style: 'bold size: 16 align: 'center]
i.: make face/font [style: 'italic size: 16 align: 'center]
u.: make face/font [style: 'underline size: 16 valign: "top"]
b.i.u.: make face/font [style: [bold italic underline] size: 16 align: 'center valign: "top"]
b.i.: make face/font [style: [bold italic] size: 16 align: 'center]
b.u.: make face/font [style: [bold underline] size: 16 align: 'center valign: "top"]
i.u.: make face/font [style: [italic underline] size: 16 align: 'center valign: "top"]
back.: make face/font [ size: 25 align: 'top valign: 'top color: silver]
in-parent_elem-type!: make hash! ["<div" | "<p" | "<table" | "<ul" | "<li" | "<td" | "<area"]
out-parent_elem-type!: make hash! ["</div" | "</p" | "</table" | "</ul" | "</li" | "</td" | "</area"]
in-style_elem-type!: make hash! ["body" "tbody" "h1" "h2" "h3" "h4" "h5" "h6" "strong" "br" "span" "tr" "a" "font" "b" "i" "newline" "option"]
out-style_elem-type!: make hash! ["/h1" "/h2" "/h3" "/h4" "/h5" "/h6" "/strong" "/body" "/tbody" "/span" "/tr" "/a" "/font" "/b" "/i"]
input_elem-type!: make hash! ["button" | "input" | "img" | "hr" | "select"]
as-block_elem-type!: make hash! [ "address" "article" "aside" "blockquote" "canvas" "dd" "div" "dl" "dt"
"fieldset" "figcaption" "figure" "footer" "form" "h1" "h2" "h3" "h4" "h5" "h6"
"header" "hr" "li" "main" "nav" "noscript" "ol" "p" "pre" "section"
"table" "tfoot" "ul" "video"]
input-as: func [DSL Dialect][
;replace/all Dialect #"^/" ""
replace/all Dialect { <} "<"
replace/all Dialect {> } ">"
switch DSL [html [markup-DOM Dialect parse-html markup layout-html markup
replace html-markup? "}" "}]"
markup-DOM load join "[" html-markup?] clear html-markup?
]
]
update: does [
html/text: "http://www.rebol.com"
url-address: url: ""
main: ""
url-type: ["com" "net" "org"]
foreach url.type url-type [
if find html/text url.type [
parse/all html/text [to "h" copy url-address thru url.type ]]
]
divs: prg: tbl: td: hd: lst: ul: spn: fnt:
img: hrl: fld: btn: txt-btn: hdn: chk: rdo: 0
width=: txt-sz: x-size: 0x0
clear main
clear face-styles
input-as 'html markup
replace/all main "none" ""
replace/all main "font #font" " "
window: load main
doc: ""
doc: layout/offset/size window 0x0 800x2000 attempt [clear do face-styles]
page/pane: doc page/pane/size/x: 1000
update-panel page s1 s2
page/color: bkclr show page
editor/text: markup show editor
{pagetitle: getnodename "title"
either find histobj pagetitle [][
append histobj reduce [pagetitle url]
]
}
]
layout-html: func [Dialect][
markup-DTD Dialect
replace/all in-html-markup: to-hash load/markup trim/lines Dialect [" "] []
foreach data-node in-html-markup [of-data-node: data-node
if string! = type? of-data-node [
foreach [old new]["," "_." ";" "._" ][replace/all data-node old new]
text-node: mold form trim data-node bgclr: clr: none
foreach part-of-node node: parse/all of-data-node " " [
either none = attempt [load part-of-node][append html-markup? to-word rejoin ["<" part-of-node ">"]
][append html-markup? rejoin [" " part-of-node " "]]
]
foreach [old new]["_." "," "._" ";" ][replace/all text-node old new]
get-colors
either true = in-parent? [
either find main "#text" [
replace main "#text" text-node replace replace main "#bgclr" bgclr "#clr" clr
get-fnt-styles gt-str-sz: get-string-size text-node
][
append main reduce [" space 0 box " bgclr " " "#string-size effect[draw[pen " clr " font #font text " text-node "]] "]
face-x: none get-fnt-styles get-string-size text-node text-node: none
]
][
if find main "#text" [replace main "#text" reduce [" " text-node " "]
get-fnt-styles get-string-size text-node text-node: none
]
if all [text-node fnt-styles] [append main reduce [" box " bgclr " " "#string-size effect[draw[pen " clr " font #font text " text-node "]] "]
get-fnt-styles get-string-size text-node text-node: none
]
if text-node [append main reduce [" " text-node " font-size 16 " clr " " bgclr " "]]
replace/all replace/all main "#bgclr" bgclr "#clr" clr
face-x: text-node: node: none
]
]
out-parent?: []
out-style?: []
html-markup?: {}
close-parent: func [][close-parent: reduce first skip find tag-tokens end-tag-token? 2
insert tail main close-parent ]
make-dom-element: does [append html-markup? reduce [" "
mold to-set-word node-name { [}]
if find data-node " " [
attributes: find data-node select data-node node-name
append html-markup? reduce [mold to-string attributes " "]
]
]
close-dom-element: does [append html-markup? reduce [mold end-tag-token? {] }]]
if tag! = type? of-data-node [
either (length? parse/all of-data-node " ") > 1 [
get-attributes of-data-node
get-colors][node-name: to string! data-node]
if find in-parent_elem-type! join "<" node-name [
make-dom-element
insert out-parent? to-refinement copy node-name
in-parent?: true make-face-obj
insert tail main reduce [" " self " panel [ pad 1 " face-obj " "]
]
]
if find input_elem-type! node-name [
make-dom-element
get-input-type of-data-node
{if found? this-parent: find/any [/p /li /ul] out-parent? [
close-parent
select-this end-tag-token?: this-parent
replace out-parent? first this-parent []
replace main "close." {] }
remove-style in-parent?: false
]}
in-parent?: false make-face-obj
insert tail main reduce [ 'space " " 12 " " self " " face-obj]
append html-markup? {] }
remove-style
token?: end-tag-token?: none
]
if find out-parent_elem-type! join "<" node-name [
in-parent?: false
clear fnt-styles
either find out-parent? end-tag-token?: load node-name [
close-dom-element
close-parent
select-this end-tag-token?
replace/all main "close." {] }
remove-style replace out-parent? end-tag-token? []
]["replace in-html-markup pick in-html-markup node []"]
if find as-block_elem-type! form end-tag-token? [insert tail main { below across }]
end-tag-token?: none
]
if find in-style_elem-type! node-name [
either any ["br" = node-name "newline" = node-name][][make-dom-element]
insert out-style? to-refinement node-name
select-this style-token?: to word! node-name
either find main "#font" [][
insert tail main reduce first skip find tag-tokens style-token? 2
]
replace replace out-style? /br [] /newline []
node-name: ""
]
if find out-style_elem-type! node-name [
in-style?: false
if find out-style? style-token?: load node-name [
select-this style-token?
insert tail main reduce first skip find tag-tokens style-token? 2
replace out-style? style-token? []
append html-markup? reduce [" " mold style-token? {] }]
style-token?: []
]
]
] replace html-markup? "}]" "}"
replace/all main "none" ""
replace/all main " " " "
clear in-html-markup
]
{face-text: foreach face p1/pane [either face/text [print face/text] [print face/effect/draw/text]]
face-length: foreach face p1/pane [if face [faces: 0 do faces: faces + 1] ]
}
use*=*to-set-values: does [=: func [value][any [value]]]
document.: func [request-as][
attempt [
DOM: head DOM
if block! != type? data-node [this: copy data-node insert data-node: [] this]
if data-node/1 [
data: type? data-node/1 replace/all data-node/1 "=" " "
either equal? data tag!
[node-element: data-node/1: style: .style: to-block first parent-node: data-node use*=*to-set-values styles: ""]
[node-element: data-node/1: build-tag to-block first parent-node: data-node]
]
]
]
return-tag-node: does [=: :equal?
if block! != type? data-node [this: copy data-node insert data-node: [] this]
if type? block! = node-element: data-node/1 [
replace/all node-element [=] []
node-element: data-node/1: build-tag to-block node-element
]
]
.style: []
equal?: :=
window: end-tag: ""
data-node: parent-node: node: none
.body: .hr: .p: .b: .i: .tr: .ul: .li: .table: .area: .td: .button: .input: .div: .font: .span: 0
node-obj: node-element: node-name: *name: attr-name: attr-value: none
check: func [select-this][node-name: select-this
any [
if block! = type? select-this [ select-this: first parse/all node-name " "]
if string! = type? select-this [select-this: first parse/all node-name " "]
if tag! = type? select-this [select-this: first parse/all node-name " "]
]
]
strip-chars-from: func [node-name][
foreach char select tag-tokens 'elemt-chars [
replace/all node-name char " "]
]
strip-obj-chars-from: func [node-name][
foreach [-char +char] select tag-tokens 'obj-chars [
replace/all node-name -char +char]
]
getnodename: func [node-name][count: [] DOM: head DOM clear face-styles
=: :equal?
if block! = type? node-name [data-node: :node-name if error? try [
node-element: data-node/1: build-tag data-node/1][
node-element: mold node-name]
]
node-name: to block! strip-chars-from mold node-name
if error? try [count: pick find node-name integer! 1][count: 1]
if error? try [nodename: to-word join "." node-name/1
repeat ? count [data-node: first DOM: next node: find DOM nodename node: index? node]
][print reduce ["node-name:" mold form node-name/1 "not found"]
]
return-tag-node
slf*: join node-name/1 count
]
setnodename: func [old-name new-name][
this-name: check strip-chars-from old-name node-element-name: check node-element
same: this-name = node-element-name
if false = same [getnodename old-name]
if not find node-element new-name [
replace node-element to string! this-name new-name
replace data-node to-tag join "/" this-name to-tag join "/" new-name
]
]
getattribute: func [attr-name][
attr-name: trim/all form attr-name
this-attr: attempt [to-block find/any node-element join attr-name "?"]
either this-attr [print reduce [attr-name attr-value: mold form this-attr/2]
][print reduce ["node-attribute:" mold form attr-name "not found"]
]
]
setattribute: func [attr-name new-attr][return-tag-node
either attempt [find/any node-element to-string reduce [attr-name "="]] [
replace node-element attr-name new-attr
get-attributes node-element attempt [set-attributes]
][
either node-element [insert tail node-element reduce [" " new-attr {="null"}]
][
print reduce ["Must get a parent-node with this attribute: " attr-name]
]
]
]
setattributevalue: func [attr-name attr-value][return-tag-node
either find/any node-element any [to-string reduce [attr-name "="] form attr-name] [
document.(window) any [attempt [.style/:attr-name: = attr-value] attempt [.style/(to-word join "." :attr-name): attr-value]]
return-tag-node get-attributes node-element attempt [set-attributes]
][
either node-element [insert tail node-element reduce [" " attr-name {="} attr-value {"}]
get-attributes node-element attempt [set-attributes]
][
print reduce ["node-attribute:" mold form attr-name "not found"]
]
] slf*: none
]
markup-DOM: func [Dialect][
use-attr-as-methods: func [maybe [logic!]][
if maybe [foreach [-char +char][" " " ."][replace/all child -char +char]as-methods: yes]
]
either block! = type? Dialect [
either find Dialect <rebol-DOM type="text/html"> [
][
insert Dialect <rebol-DOM type="text/html">
]
DOM: Dialect: load replace/all mold Dialect "__" " "
get-data: func [data][
end-tag: none
any [
if end-tag: find data refinement! [
end-tag/1: to-tag join "/" end-tag/1
]
if end-tag: find data get-word! [
end-tag/1: to-tag join "/" end-tag/1
]
insert tail data to-tag join "/" any [*name *node-name]
]
if string! != type? data/1 [insert data to-tag node-name]
repeat in-data data [
if set-word! = type? in-data [
replace data in-data node-name: to-word join "." *node-name: form in-data
]
if string! = type? in-data [
in-node-element: rejoin [remove form node-name " " in-data]
quote-node-attributes create-tag-element with-these-attributes
;foreach [a b][" " " ."][replace/all child a b]
replace data in-data data-node
]
if block! = type? in-data [get-next in-data]
]
]
get-next: func [in-data][
end-tag: none
any [
if end-tag: find in-data refinement! [
end-tag/1: to-tag join "/" end-tag/1
]
if end-tag: find in-data get-word! [
end-tag/1: to-tag join "/" end-tag/1
]
insert tail in-data to-tag join "/" any [*node-name *name]
]
if string! != type? in-data/1 [insert in-data to-tag node-name]
repeat data in-data [
if set-word! = type? data [
replace in-data data node-name: to-word join "." *name: form data
]
if string! = type? data [
in-node-element: rejoin [remove form node-name " " data]
quote-node-attributes create-tag-element with-these-attributes
;foreach [a b][" " " ."][replace/all child a b]
replace in-data data data-node
]
if block! = type? data [get-data data]
]
]
repeat with-this-data Dialect [
if set-word! = type? with-this-data [
replace Dialect with-this-data node-name: to-word join "." *name: form with-this-data
]
if word! = type? with-this-data [*names: copy form with-this-data
either '= = with-this-data [string-is-data: yes replace Dialect with-this-data ""
][
*name: copy form with-this-data
replace Dialect with-this-data node-name: to-word join "." with-this-data]
replace Dialect reduce [node-name node-name] node-name
]
if string! = type? with-this-data [
either string-is-data [replace Dialect with-this-data remove mold join node-name with-this-data][
quote-node-attributes create-tag-element with-these-attributes
;foreach [a b][" " " ."][replace/all child a b]
replace Dialect with-this-data data-node
]
]
if block! = type? with-this-data [
get-data with-this-data
]
if get-word! = type? with-this-data [
replace Dialect with-this-data end-block: to-tag join "/" *name
]
]
replace/all Dialect "" []
protect DOM: copy Dialect
markup: form Dialect
foreach [-char +char]["{" "<" "}" ">" "<." "<" "_. " ","][replace/all markup -char +char]
foreach n-name [
"[" "]" ".body " ".hr " ".p " ".b " ".i " ".? "
".tr " ".table " ".td " ".button " ".input "
".div " ".ul " ".li " ".font " ".span "
".area " ".img " ".a " ".strong " " ."
][replace/all markup n-name " "
]
append replace/all markup </body> "" </body>
markup: any [find markup "<body" markup]][markup: any [find markup "<body" Dialect]]
]
old-mrkp: none
view-port: layout [ID: bck: backdrop 241.241.241
across at 0x0
box black 805x40
pad -805x10
text 240x50 black "Click to load demo page" left font-size 12 241.241.241 effect [draw [pen black line-width 4.5
fill-pen 241.241.241 box -3x-2 240x50 7]][editor/text: any [old-mrkp markup]
show html markup: editor/text
clear face-styles
update
old-mrkp: copy markup
recycle/on recycle/off
] pad -250x30 box 700x50 241.241.241
below across
pad -4x-56
box 241.241.241 30x31 effect [draw[fill-pen 245.245.245 pen white circle 14x16 pen gray line-width 3 line 6x16 22x16 pen gray font back. text "<" 4x0]]
space 10
box 241.241.241 30x31 effect [draw[fill-pen 245.245.245 pen white circle 14x16 pen gray font back. text ">" 10x0 pen gray line-width 3 line 5x16 20x16]]
pad 0x6
Go: button "Go" white 30x24 [
txt-clr: none attempt [
case [
if find/match html/text "www" [insert html/text "http://" markup: read to-url html/text update]
if find/match html/text "http://" [markup: read to-url html/text update]
if find html/text {/rebol } [attempt [do html/text]]
;markup: mold any [attempt [load html/text] {<h6>404</h6>}]
]]
]
edge [size: 0x0 effect: 'none ]
html: field 500 edge [size: 1x1 color: blue ]
below
pad -20x28 box 805x1 gray /20 edge: ['none]
across pad -20x-10 page: box 241.241.241 edge[size: 0x0 effect: 'none ] 783x508
pad -10 s1: scroller 241.241.241 16x494 [attempt[scroll-panel-vert page s1]]
below pad -20x-24 s2: scroller 241.241.241 788x16 [attempt [scroll-panel-horz page s2]]
pad -10 editor: area white 805x130 wrap
pad 7
below across
pad -10x-10
btn "Up" 55 [if error? try [page/pane/offset/y: page/pane/offset/y + 100 show page
page/pane/offset/y: page/pane/offset/y - 2 show page][]]
btn "Down" 55 [if error? try [page/pane/offset/y: page/pane/offset/y - 100 show page
page/pane/offset/y: page/pane/offset/y + 1 show page][]]
btn "View code" 85 [markup: copy editor/text update
]
]
page/pane: ""
scroll-panel-vert: func [pnl bar][
pnl/pane/offset/y: negate bar/data *
(max 0 pnl/pane/size/y - pnl/size/y)
show pnl pnl/pane/size/y - 1 show pnl
]
scroll-panel-horz: func [pnl bar][
pnl/pane/offset/x: negate bar/data *
(max 0 pnl/pane/size/x - pnl/size/x)
show pnl
]
update-panel: func [pnl vbar hbar] [
pnl/pane/offset: 0x0
s1/data: s2/data: 0
vbar/redrag pnl/size/y / pnl/pane/size/y
hbar/redrag pnl/size/x / pnl/pane/size/x
show [pnl vbar hbar]
]
goo: does [get-attributes {p1 font-size "15" color "pink" bgcolor "blue"} set-attributes]
gogo: does [document.(getnodename{p.1})style/color: = "purple" ()setattributevalue 'bgcolor "black" set-attributes]
view-port/size: 805x800
view center-face view-portNotes
|