1# -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- 2# 3# $Id: Myhtml.tcl,v 1.15 2006-10-01 23:58:29 villate Exp $ 4# 5###### Myhtml.tcl ###### 6############################################################ 7# Netmath Copyright (C) 1998 William F. Schelter # 8# For distribution under GNU public License. See COPYING. # 9############################################################ 10 11# parsing routines for html 12# try to be compatible from calling level with the package by stephen uhler. 13# to use: 14# set html [exec cat /home/wfs/tclet/server/sample.html] ; xHMinit_win .t ; xHMset_state .t url sample.html ; xHMparse_html $html "xHMrender .t" ; array set wvar $args 15# source myhtml.tcl ; catch {destroy .t } ; text .t ; set html [exec cat /home/wfs/tclet/server/sample.html] ; xHMinit_win .t ; xHMset_state .t url sample.html ; xHMparse_html $html "xHMrender .t" 16 17proc testit { file } { 18 global xHMpriv 19 source myhtml.tcl 20 catch {destroy .t } 21 foreach {k val} [array get xHMpriv geom*] {unset xHMpriv($k) } 22 frame .t 23 text .t.text 24 set t .t.text 25 set html [exec cat $file] 26 xHMinit_win $t 27 xHMset_state $t url $file 28 xHMparse_html $html "xHMrender $t" 29 pack .t 30 pack $t 31 raise . 32} 33 34# 35# xHMparse_html $html "xHMrender .t" 36# you can change the state of the parse engine by using 37# xHMset_state .t key1 val1 key2 val2... 38 39######### 40 41# the HTML tags: 42 43# becomes 44 45# idea: some tags like font,indent,link have only one per but the tag 46# varies.. others have a constant tag... eg 'strike' 'underline' ... 47# or fill. You cant have 48# and are either on or off... 49# have pushConstantTag win tag 50# have popConstantTag win tag 51# have pushNamedTag win name tag 52# have popNamedTag win name tag :sets current to be this one and pushes previous.. 53# and these maintain things so that 54# [array names xHMtaglist$win] should provide the taglist to do 55 56proc xHMpushConstantTag { win tag } { 57 upvar #0 xHMtaglist$win taglist 58 if { [catch {incr taglist($tag) } ] } { 59 set taglist($tag) 1 } 60} 61 62proc xHMpopConstantTag {win tag} { 63 upvar #0 xHMtaglist$win taglist 64 catch { 65 set i [incr taglist($tag) -1] 66 if { $i <= 0 } {unset taglist($tag) } 67 } 68} 69 70proc xHMpushNamedTag {win name tag} { 71 upvar #0 xHMvar$win wvar 72 #puts "push $win <$name> <$tag>" 73 if { [catch { set now [lindex [set wvar($name)] end] }] } { 74 set now "" } 75 lappend wvar($name) $tag 76} 77 78proc xHMpopNamedTag {win name} { 79 upvar #0 xHMvar$win wvar 80 set v [set wvar($name)] 81 set now [lindex $v end] 82 catch { set v [lreplace $v end end] } 83 set wvar($name) $v 84 return $now 85} 86 87proc xHMgetNamedTag {win tag } { 88 upvar #0 xHMvar$win wvar 89 set res "" 90 catch { set res [lindex $win($tag) end] } 91 return $res 92} 93 94proc xHMpushAindent { win i } { 95 upvar #0 xHMvar$win wvar 96 upvar #0 xHMtaglist$win taglist 97 set n [incr wvar(indent) $i] 98 # puts "taglist:[array names taglist ]" 99 unset taglist(indent:[expr {$n - $i}]) 100 set taglist(indent:$n) 1 101} 102 103proc xHMpopAindent { win i } { 104 upvar #0 xHMtaglist$win taglist 105 upvar #0 xHMvar$win wvar 106 set n 0 107 set n [set wvar(indent)] 108 109 unset taglist(indent:$n) 110 set n [expr {$n - $i}] 111 if { $n < 0 } { set n 0 } 112 set wvar(indent) $n 113 set taglist(indent:$n) 1 114 115} 116 117# font and indent wil 118 119 120# 121 #----------------------------------------------------------------- 122 # 123 # defTag -- creates an executable scripts to invoke when the TAG 124 # or /TAG are encountered. 125 # -alter takes a list of key1 val1 key2 val2 126 # generally these are pushed onto stacks for TAG and popped for /TAG 127 # the value of xHMtaglist$win should get altered 128 # -before set the prefix for text inserted for TAG 129 # -after set the prefix for text inserted for /TAG 130 # -body additional body to use for TAG 131 # -sbody additional body to use for the /TAG 132 # The variables { tag params text } are bound when 133 # the BODY is evaluated. Thus for example $text would get the 134 # text following the tag, and 135 # set paramList [xHMsplitParams $params] 136 # could be used to decode the params. 137 # 138 # Results: none 139 # 140 # Side Effects: saves the script in xHMtag array under TAG and /TAG 141 # 142 #---------------------------------------------------------------- 143# 144proc defTag { htag args } { 145 global xHMtag 146 foreach {key val } $args { set $key $val } 147 if { [info exists -alter] } { 148 foreach { key tag } ${-alter} { 149 if { [string match A* $key] } { 150 append body "\nxHMpush$key \$win $tag" 151 append sbody "\nxHMpop$key \$win $tag" 152 } elseif { [string match C* $key] } { 153 append body "\nxHMpushConstantTag \$win $tag" 154 append sbody "\nxHMpopConstantTag \$win $tag" 155 } else { 156 append body "\nxHMpushNamedTag \$win $key $tag" 157 append sbody "\nxHMpopNamedTag \$win $key" 158 } 159 } 160 array set toalter ${-alter} 161 foreach prop { family size weight style} { 162 if { [info exists toalter($prop)] } { append fontprops " $prop"} 163 } 164 catch { 165 append body "\nxHMalterFont \$win $fontprops" 166 append sbody "\nxHMalterFont \$win $fontprops" 167 } 168 } 169 catch { append body \n${-body} } 170 catch { append sbody \n${-sbody} } 171 catch { append body "\nset prefix \"[slashNewline ${-before}]\"" } 172 catch {append sbody "\nset prefix \"[slashNewline ${-after}]\"" } 173 catch { set xHMtag($htag) $body } 174 catch { set xHMtag(/$htag) $sbody } 175} 176 177proc slashNewline { s } { 178 regsub -all "\n" $s "\\n" s 179 return $s 180} 181 182# netscape uses fonts in the following progression. 183# we will have the font labels looking like: 184# font:propor:normal:r:4 to indicate size 4 185# In an application if the user sets the default 186# nfont:nfamily:nweight:nstyle:nsize 187# where nfamily is in {propor,fixed} 188# where nweight is in {normal,bold} 189# where nstyle is in {i,r} 190# where nsize is in {1,2,3,4,5,6,7} 191# then we map the label to a particular font.... 192# propor-->times 193# fixed->courier 194 195# set the font to be what it would map to for X. 196proc xHMsetFont { win fonttag } { 197 upvar #0 xHMvar$win wvar 198 set fo [xHMmapFont $fonttag] 199 set wvar($fonttag) 1 200 $win tag config $fonttag -font $fo 201} 202 203 204#convert a fonttag into an actual font specifier, using preferences. 205# mapping propor,fixed to font families, and dobing size adjusting based 206# on font type. 207 proc xHMmapFont { fonttag } { 208 # font:family:weight:style:size 209 global maxima_default xHMfonts 210 if { [info exists xHMfonts($fonttag) ] } { 211 return $xHMfonts($fonttag) 212 } else { 213 set xHMfonts($fonttag) [set fo [font create]] 214 xHMconfigFont $fonttag 215 return $fo 216 217 } 218 } 219 220 proc xHMconfigFont { fonttag } { 221 # font:family:weight:style:size 222 global maxima_default xHMfonts 223 224 set font $xHMfonts($fonttag) 225 set s [split $fonttag :] 226 if {[llength $s] < "2"} { 227 error [concat [mc "Internal font error:"] "$fonttag '$xHMfonts($fonttag)'"] 228 } 229 set fam [lindex $s 1] 230 #puts "fam=$fam,fonttag=$fonttag,s=$s" 231 if { "$fam" == "" } { 232 set fam propor 233 } 234 set si [expr {$maxima_default($fam,adjust) + [lindex $s 4]}] 235 #set si [lindex $s 4] 236 set si [expr {($si < 1 ? 1 : ($si > 8 ? 8 : $si))}] 237 set elt [lindex $s 1] 238 if {![info exists maxima_default($fam)]} { 239 error [concat [mc "Internal font error:"] "'$fam'"] 240 } 241 set family $maxima_default($fam) 242 set weight [lindex $s 2] 243 set slant [lindex $s 3] 244 if { "$slant" == "i" } { 245 set slant italic 246 } else { 247 set slant roman 248 } 249 #puts "font config $font -family $family -size $maxima_default($fam,$si) -slant $slant -weight $weight" 250 global tcl_platform 251 if { "$tcl_platform(platform)" == "unix" } { 252 set usePixel "-" 253 } else { 254 set usePixel "" 255 } 256 font config $font -family $family -size $usePixel$maxima_default($fam,$si) -slant $slant -weight $weight 257 return 258 } 259 260 ### the following resets all the fonts 261 ### for any windows now that font objects are interned 262 263 proc xHMresetFonts { win } { 264 global xHMfonts 265 foreach v [array names xHMfonts] { 266 xHMconfigFont $v 267 } 268 } 269 270proc xHMfontPointSize { string } { 271 #mike FIXME: hard coded font name and $string is ignored 272 set si [font config $string -size] 273 return [expr { $si < 0 ? - $si : $si }] 274} 275 276 277 278 279proc xHMalterFont {win args } { 280 upvar #0 xHMvar$win wvar 281 upvar #0 xHMtaglist$win taglist 282 283# puts "font:$args,[array get wvar *]" 284 foreach v {family weight style size adjust} { 285 set $v [lindex $wvar($v) end] 286 } 287 288 set si $size 289 if { [catch { set si [expr {$si + $adjust}] }] } { 290 # puts "too many pops" 291 return 292 } 293 set font font:$family:$weight:$style:$si 294 if { ![catch { set fo $wvar(font) }] } { 295 catch { unset taglist($fo) } } 296# puts "font=$font, wvar=[array get wvar fon*]" 297 set wvar(font) $font 298 if { ![info exists wvar($font)] } { 299 xHMsetFont $win $font } 300 set taglist($font) 1 301 302 # return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*" 303} 304 305proc xHMsplitParams { param } { 306 if { "$param" == "" } { return ""} 307 set reg "(\[^= \t\n\]+)\[ \t\n]*((=\[ \t\n]*((\"(\[^\"\]*)\")|('(\[^'\]*)')|(\[^ \t\n\]*)))|(\[ \t\n\])|\$)" 308 309 # set sub "{1=\\1,2=\\2,3=\\3,4=\\4,5=\\5,6=\\6,7==\\7,8=\\8,9=\\9}" 310 # regsub -all $reg $param $sub joe 311 # puts joe=$joe 312 313 set sub "\\1\\6\\8\\9" 314 regsub -all $reg $param $sub joe 315 foreach { dummy key val } [lreplace [split $joe ] end end] { lappend new [string tolower $key] $val} 316 return $new 317} 318 319proc xHMextract_param {paramList key args} { 320 foreach { k val } $paramList { 321 if { "$k" == "$key" } { 322 uplevel 1 set $key [list $val] 323 return 1}} 324 if { "$args" != "" } { 325 uplevel 1 set $key [list [lindex $args 0] ] 326 } 327 return 0 328 } 329 330global xHMtag 331if {[info exists xHMtag]} {catch {unset xHMtag}} 332 333defTag a -alter {Cdoaref doaref} -body xHMdo_a -sbody xHMdo_/a 334defTag b -alter {weight bold } 335defTag -body xHMdo_body 336defTag br -before "\n" 337defTag center -alter {Ccenter center} 338defTag cite -alter {style i} 339defTag code -alter {family fixed} 340defTag dd -before "\n" -after "\n" 341defTag dfn -alter {style i} 342defTag dt -before "\n" 343defTag em -alter {style i} 344defTag h1 -alter {size 7 weight bold} -body {xHMassureNewlines 1} -after "\n" 345defTag h2 -alter {size 6} -body {xHMassureNewlines 1} -after "\n" 346defTag h3 -alter {size 6} -body {xHMassureNewlines 1} -after "\n" 347defTag h4 -alter {size 5} -body {xHMassureNewlines 1} -after "\n" 348defTag h5 -alter {size 4} -before "\n" -after "\n" 349defTag h6 -alter {size 3 style i} -before "\n" -after "\n" 350defTag i -alter {style i} 351defTag img -body xHMdo_img 352 353defTag kbd -alter {family fixed weight bold} 354defTag li -body xHMdo_li 355 356defTag dl -body xHMlistEnter -sbody xHMlistExit 357defTag dir -body xHMlistEnter -sbody xHMlistExit 358defTag menu -body xHMlistEnter -sbody xHMlistExit 359defTag ol -body { 360 xHMlistEnter 361 set wvar(listindex$wvar(indent)) 0} -sbody { 362 xHMlistExit } 363 364defTag title -body {wm title [winfo toplevel $win] $text ; set text ""} -sbody {list } 365defTag ul -alter {Aindent 1} -body { xHMlistEnter 366 set paramList [xHMsplitParams $params] 367 set _iii -1 368 if { [xHMextract_param $paramList type ""] } { 369 set _iii [lsearch {disc circle square} $type] 370 } 371 if { $_iii < 0 } { 372 set _iii [expr {($wvar(indent)/2 > 3 ? 3 : $wvar(indent)/2) -1 }] 373 if { $_iii < 0 } { set _iii 0} 374 } 375 # push an index which will say disc, circle or square. 376 xHMpushNamedTag $win ultype $_iii 377} -sbody { xHMlistExit ; catch { xHMpopNamedTag $win ultype }} 378 379 380#defTag p -before "\n\n" -sbody {} 381#defTag p -before "\n\n" -sbody {} 382defTag p -before "\n" -body { xHMassureNewlines 1 } -sbody { xHMassureNewlines 1 } 383defTag blockquote -before "\n\n" -after "\n" 384defTag pre -alter {family fixed Cnowrap nowrap} -before "\n" /pre "\n" 385defTag samp -alter {family fixed} 386defTag strike -alter {Cstrike strike} 387defTag strong -alter {weight bold} 388defTag sup -alter {Csup sup} 389defTag sub -alter {Csub sub} 390 391defTag tt -alter {family fixed} 392defTag u -alter {Cunderline underline} 393 394defTag hrx -body { $win insert $wvar(W_insert) "\n" ; 395 $win insert $wvar(W_insert) "\n" hrule 396 } -sbody {} 397defTag hr -before \n -body { 398 $win insert $wvar(W_insert) " " underline 399 } -sbody {} 400 401defTag var -alter {style i} 402 403defTag hmstart -alter { family propor weight normal style r size 3 404 list list 405 adjust 0 } -body { set wvar(counter) 0 } 406 407defTag font -body { 408 set paramList [xHMsplitParams $params] 409 xHMpushNamedTag $win adjust [assoc size $paramList 0] 410 xHMalterFont $win adjust 411 } -sbody { 412 xHMpopNamedTag $win adjust 413 xHMalterFont $win adjust 414 } 415 416proc notyet { args } { 417 puts [concat [mc "not yet"] "$args"] 418} 419 420defTag isindex -body xHMdo_isindex -sbody {} 421defTag meta -body list -sbody list 422defTag form -before "\n" -after "\n" -body { 423 global xHMpriv 424 set xHMpriv(form) [gensym form] 425 upvar #0 $xHMpriv(form) form 426 set paramList [xHMsplitParams $params] 427 #puts "paramList=$paramList" 428 if { [xHMextract_param $paramList action ""] } { 429 set form(action) $action 430 } 431 xHMextract_param $paramList method "get" 432 set form(method) $method 433 434 } -sbody { global xHMpriv ; 435 if { [info exists xHMpriv(form) ] } { 436 upvar #0 $xHMpriv(form) form 437 #puts form=$xHMpriv(form) 438 #puts "form values=[array get form]" 439 440 if { ![info exists form(f_has_submit)] } { 441 set params "" 442 xHMtextInsert $win "\n" 443 xHMdo_input submit 444 } 445 unset xHMpriv(form) 446 } 447 } 448defTag input -body xHMdo_input 449defTag select -body "xHMdo_input select" -sbody { 450# puts wvar=[array get wvar f_in_select] 451 #catch { 452 global xHMpriv 453 upvar #0 $xHMpriv(form) form 454 puts "\[array get wvar f_in_select*]=[array get wvar f_in_select*]" 455 set na [lindex $wvar(f_in_select) 0] 456 457 set w $form(f_select,$na) 458 foreach v [lrange $wvar(f_in_select) 1 end] { 459 $w.list insert end $v 460 } 461 xHMresetListbox $w $wvar(f_selected,$na) 462 append form(f_reset) " ; xHMresetListbox $w [list $wvar(f_selected,$na)]" 463 #puts $w 464 if { [winfo exists ${w}label] } { 465 #puts "have label $w and ${w}label" 466 bind ${w}label <1> "place $w -anchor center -relx 0 -rely 1.0 -bordermode outside -in ${w}label ; raise $w" 467 bind $w <Leave> "xHMresetListbox $w \[$w.list curselection\] ; place forget $w" 468 } 469 if { [$w.list cget -height] > 0 && [llength $wvar(f_select_values)] > [$w.list cget -height] } { 470 scrollbar $w.scroll -orient v -command "$w.list yview" -takefocus 0 471 $w.list configure -yscrollcommand "$w.scroll set" 472 pack $w.scroll -side right -fill y 473 } 474 475 set form(f_select_list,$na) $wvar(f_select_values) 476 if { [catch { unset wvar(f_selected,$na) }] } { puts "failed= unset wvar(f_selected,$na)"} 477 if { [catch { unset wvar(f_select_values) }] } { puts "failed=unset wvar(f_select_values)"} 478 #} 479} 480 481proc xHMresetListbox { w selected } { 482 $w.list selection clear 0 end 483 foreach v $selected { $w.list selection set $v} 484 set i 0 485 if { [llength $selected] > 0 } { 486 set i [lindex $selected 0] 487 } 488 if { [winfo exists ${w}label] } { 489 ${w}label configure -text [$w.list get $i] 490 } 491} 492 493defTag textarea -body "xHMdo_input textarea" 494proc configColor { args } { 495 set color [lindex $args end] 496 if { [catch { eval $args } ] } { 497 set color [lindex $args end] 498 set args [lreplace $args end end "#$color"] 499 catch { eval $args } 500 } 501} 502 503 504defTag html -body "list " -sbody "list " 505defTag head -body "list " -sbody "list " 506defTag body -body { 507 #puts "<body $params> $text" 508 set paramList [xHMsplitParams $params] 509 if { [xHMextract_param $paramList bgcolor ""] } { 510 configColor $win config -background $bgcolor 511 configColor $win tag config hrule -font {courier 2} -background $bgcolor 512 } 513 if { [xHMextract_param $paramList baseprogram ] } { 514 oset $win baseprogram [resolveURL $baseprogram [oget $win baseprogram]] 515 oset $win baseprogram [decodeURL $baseprogram] 516 } 517 518 519 set _text $text 520 if { [xHMextract_param $paramList text ""] } { 521 configColor $win config -foreground $text 522 } 523 set text ${_text} 524 foreach {ll tag} {evalrelief Teval resultrelief Tresult aevalrelief currenteval resultmodifiedrelief Tmodified } { 525 if { [xHMextract_param $paramList $ll ""] } { 526 $win tag configure $tag -relief [set $ll] 527 } 528 } 529 530 foreach {ll tag} {bgeval Teval bgresult Tresult bgresultmodified Tmodified bgaeval currenteval} { 531 if { [xHMextract_param $paramList $ll ""] } { 532 configColor $win tag configure $tag -background [set $ll] 533 } 534 } 535 foreach {ll tag} {link href alink currenthrefforeground eval Teval result Tresult resultmodified Tmodified aeval currenteval} { 536 if { [xHMextract_param $paramList $ll ""] } { 537 configColor $win tag configure $tag -foreground [set $ll] 538 } 539 } 540 } -sbody "list " 541 542defTag base -body { set paramList [xHMsplitParams $params] 543 if { [xHMextract_param $paramList href ""] } { 544 set wvar(baseurl) $href 545 #xHMset_state $win baseurl $href 546 oset $win baseurl $href 547 } 548 } 549 550 551 552defTag option -body { set text [string trimright $text] 553 set paramList [xHMsplitParams $params] 554 xHMextract_param $paramList value $text 555 lappend wvar(f_select_values) $value 556 lappend wvar(f_in_select) $text 557 if { [xHMextract_param $paramList selected] } { 558 #puts "hi==wvar(f_selected,[lindex $wvar(f_in_select) 0])" 559 lappend wvar(f_selected,[lindex $wvar(f_in_select) 0]) [expr {[llength $wvar(f_in_select)] -2}] 560 } 561 set text "" 562} 563 564global xHMpriv 565set xHMpriv(counter) 0 566 567 568# 569 #----------------------------------------------------------------- 570 # 571 # ldelete -- remove all copies of ITEM from LIST 572 # 573 # Results: new list without item 574 # 575 # Side Effects: 576 # 577 #---------------------------------------------------------------- 578# 579proc ldelete { item list } { 580 while { [set i [lsearch $list $item]] >= 0} { 581 set list [lreplace $list $i $i] 582 } 583 return $list 584} 585if { ![info exists _gensymCounter] } {set _gensymCounter 0} 586proc gensym { name } { 587 global _gensymCounter 588 incr _gensymCounter 589 set var ${name}_${_gensymCounter} 590 catch { uplevel "#0" unset $var} 591 return $var 592} 593 594proc xHMdo_input {{type ""}} { 595 global xHMpriv 596 if { ![info exists xHMpriv(form)] } { 597 set xHMpriv(form) [gensym form] 598 } 599 upvar 1 win win 600 upvar #0 $xHMpriv(form) form 601 upvar #0 xHMvar$win wvar 602 upvar 1 params params 603 set form(url) $wvar(url) 604 605 set paramList [xHMsplitParams $params] 606 607 set w $win.input[incr wvar(counter)] 608# bindtags $w [ldelete maxlength [bindtags $w]] 609 xHMextract_param $paramList name "" 610 if { "$type" == "" } { 611 xHMextract_param $paramList type text 612 } 613 xHMextract_param $paramList value "" 614 set value [xHMconvert_ampersand $value] 615 switch -regexp -- $type { 616 {text$|password|int$|string} { 617 xHMextract_param $paramList size 20 618 entry $w -width $size 619 if { "$type" == "password" } { $w config -show * } 620 if { [xHMextract_param $paramList maxlength] } { 621 bindtags $w [concat [bindtags $w] maxlength] 622 bind maxlength <KeyPress> "xHMdeleteTooLong $win %W" 623 624 set wvar($w,maxlength) $maxlength 625 } 626 627 $w insert end $value 628 629 append form(f_reset) " ; $w delete 0 end ; $w insert end [list $value] " 630 set form(f_submit,$name) "$w get" 631 } 632 select { 633 xHMextract_param $paramList size 1 634 xHMextract_param $paramList mode single 635 set lis $w 636 if { $size == 1 } { 637 set w ${w}label 638 label $w -relief raised 639 } 640 frame $lis 641 listbox $lis.list -selectmode $mode -width 0 -exportselection 0 -height [expr {$size > 1 ? $size : 0}] 642 pack $lis.list -side left 643 644 # will contain list "window value1 value2 value3 .." 645 # added to by <option> 646 set wvar(f_selected,$name) "" 647 set form(f_select,$name) $lis 648 set wvar(f_in_select) $name 649 set wvar(f_select_values) $name 650 # throw away any text after select 651 set text "" 652 653 } 654 textarea { 655 upvar 1 text text 656 xHMextract_param $paramList cols 30 657 xHMextract_param $paramList rows 5 658 catch { 659 frame $w 660 puts "w=$w" 661 scrollbar $w.yscroll -command "$w.text yview" -orient v 662 text $w.text -height $rows -width $cols -wrap none \ 663 -yscrollcommand "$w.yscroll set" -padx 2 -pady 2 664 $w.text insert 0.0 $text 665 666 set text "" 667 pack $w.text 668 set form(f_submit,$name) "$w.text get 0.0 end" 669 append form(f_reset) " ; $w.text delete 0.0 end ; $w.text insert end [list $text]" 670 } errm ; 671 puts errm=$errm; 672 673 } 674 image { 675 676 xHMextract_param $paramList width 0 677 xHMextract_param $paramList height 0 678 xHMextract_param $paramList src "broken.ppm" 679 set form(f_has_submit) 1 680 catch { set base $wvar(url) ; set base $wvar(baseurl) } 681 label $w -image [xHMgetImage $win $src $base $width $height] \ 682 -background [$win cget -background] 683 bind $w <ButtonRelease-1> "xHMdoSubmit $w $xHMpriv(form) {$name.x %x $name.y %y}" 684 bind $w <Return> "xHMdoSubmit $w $xHMpriv(form) {$name.x 0 $name.y 0}" 685 bind $w <Leave> "$w configure -relief raised" 686 687 } 688 radio { 689 690 if { [catch { set var $form(radio,$name) } ] } { 691 set var [set form(radio,$name) [gensym radio_value]] 692 } 693 radiobutton $w -variable $var -value $value -text " " 694 if { [xHMextract_param $paramList checked] } { 695 append form(f_reset) "; $w select" 696 $w select 697 698 } else { 699 append form(f_reset) "; $w deselect" 700 $w deselect 701 702 } 703 704 set form(f_submit,$name) "uplevel #0 set $var" 705 706 } 707 checkbox { 708 ######### to do fix this..failed: http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/Forms/example-4.html 709 if { [catch { set var $form(checkbox,$name) } ] } { 710 set var [set form(checkbox,$name) [gensym checkbox_value]] 711 } 712 xHMextract_param $paramList value on 713 checkbutton $w -on $value -variable $var -off _dontsubmit_ \ 714 -text " " 715 716 set form(f_submit,$name) "uplevel #0 set $var" 717 718 if { [xHMextract_param $paramList checked] } { 719 append form(f_reset) " ; $w select" 720 $w select; 721 } else { 722 $w deselect 723 append form(f_reset) " ; $w deselect" 724 } 725 726 } 727 hidden { 728 set form(f_submit,$name) "list [list $value]" 729 set w "" 730 } 731 reset { 732 if { "$value" == "" } {set value "Reset"} 733 button $w -text $value -command "xHMdoReset $xHMpriv(form)" 734 735 } 736 submit { 737 set form(f_has_submit) 1 738 if { "$value" == "" } { set value "Submit Query" } 739 if { "$name" != "" } { 740 button $w -text $value -command [list xHMdoSubmit $w $xHMpriv(form) [list $name $value]] 741 } else { 742 button $w -text $value -command "xHMdoSubmit $w $xHMpriv(form) [list {}]" 743 } 744 745 } 746 } 747# if { [info exists form(f_submit,$name)] } { 748# lappend form(f_tosubmit) $name 749# } 750 #dputs "type=$type,w=$w" 751 #dputs "form(reset)=$form(f_reset)" 752 if { "$w" != "" } { 753 #catch { puts "class=[winfo class $w]" } 754 if { [catch { $win window create $wvar(W_insert) -window $w -align bottom -padx 1 -pady 1 } ] } { 755 puts [concat "$w" [mc "bad window"] "?"] 756 } 757 758 ### todo handle focus of forms.. with tabbing. 759 760 } 761 762} 763 764proc xHMsetSubmitPosition { formvar name x y } { 765 upvar #0 $formvar form 766 set form(f_submit,$name.x) "list $x" 767 set form(f_submit,$name.y) "list $y" 768} 769 770 771 772proc xHMdoReset { formVar } { 773 upvar #0 $formVar form 774 eval $form(f_reset) 775} 776proc xHMdoSubmit { w formVar nameVals } { 777 upvar #0 $formVar form 778 set ans "" 779 set win [omPanel $w] 780 foreach { name value } $nameVals { 781 puts "value=$value--><[xHMencode_get $value]>" 782 if { "$name" != "" } { append ans "&$name=[xHMencode_get $value]"} 783 } 784 785# foreach name $form(f_tosubmit) { 786# set val [eval $form(f_submit,$name)] 787# if { "$val" != "_dontsubmit_" } { 788# append ans "&$name=[xHMencode_get $val]" 789# } 790# } 791 set n [string length f_submit,] 792 foreach {name value} [array get form f_submit,* ] { 793 puts "form submit:[array get form f_submit,*]" 794 set val [eval $value] 795 puts "name=$name,val=$val-->[xHMencode_get $val]" 796 if { "$val" != "_dontsubmit_" } { 797 append ans "&[string range $name $n end]=[xHMencode_get $val]" 798 } 799 } 800 # do the select listboxes: 801 802 foreach { name w } [array get form f_select,*] { 803 set name [string range $name [string length f_select,] end] 804 805 set values [lrange $form(f_select_list,$name) 1 end] 806 set ans1 "" 807 808 foreach v [$w.list curselection] { 809 lappend ans1 [lindex $values $v] 810 } 811 puts w=$w.list,name=$name,ans1=$ans1, 812 set ans1 [join $ans1 " "] 813 append ans "&$name=[xHMencode_get $ans1]" 814 } 815 #puts ans=$ans 816 #puts form=[array get form] 817 set action $form(action) 818 if { "[string tolower $form(method)]" == "get" } { 819 xHMfindUrl $win $form(method) $form(action)?[string range $ans 1 end] 820 } else { 821 xHMfindUrl $win $form(method) $form(action) [string range $ans 1 end] 822} 823 } 824 825proc xHMfindUrl { win method url { body "" }} { 826 #puts "$win,$method,$url,$body" 827 set method "[string tolower $method]" 828 if { "$method" == "get" } { 829 OpenMathOpenUrl $url -commandpanel $win 830 } elseif { "$method" == "post" } { 831 if { "$body" == "" } {set body " "} 832 OpenMathOpenUrl $url -commandpanel $win -post $body 833 } 834} 835 836proc xHMdeleteTooLong { win w } { 837 upvar #0 xHMvar$win wvar 838 catch { $w delete $wvar($w,maxlength) end } 839 #puts $wvar($w,maxlength) 840} 841 842proc xHMconvert_ampersand { text } { 843 if {![regexp & $text]} {return $text} 844 regsub -all {([[\\])|(&((#([0-9][0-9]?[0-9]?))|([a-zA-Z]+));?)} $text {[xHM_do1 \\\1 \5 : \6]} tmp 845 return [subst -novariables $tmp] 846} 847 848proc xHM_do1 { a b {c xx} } { 849 global isoLatin1 850 if { "$a" == " " } { 851 if { "$b" == ":" } { 852 #set result ? 853 if { [catch { set result $isoLatin1($c) }] } { 854 return "&$c" 855 } 856 return $result 857 } else { 858 return [format %c $b] 859 } 860 } else { 861 return [string index $a 0] 862 } 863} 864 865proc xHMdo_li {} { 866 uplevel 1 { 867 set i $wvar(indent) 868 set taglist(listindex) 1 869 set text [string trimleft $text] 870 if { ![catch { incr wvar(listindex$i) }] } { 871 xHMpopAindent $win 1 872 xHMtextInsert $win "\n\t$wvar(listindex$i).\t" 873 xHMpushAindent $win 1 874 } else { 875 set ii 0 876 catch { set ii [lindex $wvar(ultype) end] } 877 xHMpopAindent $win 1 878 xHMtextInsert $win "\n\t" 879 xHMinsertBullet $win $ii 880 xHMtextInsert $win "\t" 881 xHMpushAindent $win 1 882 } 883 unset taglist(listindex) 884 } 885} 886 887proc xHMinsertBullet { win i } { 888 global xHMulBMPdata xHMpriv 889 upvar #0 xHMvar$win wvar 890 set fg [$win cget -foreground] 891 set image "" 892 if {[catch { set image $xHMpriv(ul,$fg,$i) }] } { 893 catch { set image [set xHMpriv(ul,$fg,$i) [image create bitmap -data [lindex $xHMulBMPdata $i] -foreground $fg]] } 894 } 895 # if we cant get the image, or cant insert it fall back to 896 # inserting a simple character 897 if { "$image" == "" || [catch { $win image create $wvar(W_insert) -image $image } ] } { 898 if { $i > 2 } { set i 2} 899 $win tag configure listindex -foreground red 900 xHMtextInsert $win [string range "oo*" $i $i] 901 } 902} 903 904defTag th -body list 905defTag td -body list -after "\t\t\t\t" 906defTag tr -body list -after "\n" 907 908 909 910 911 912proc xHMdo_a {} { 913 uplevel 1 { 914 set paramList [xHMsplitParams $params] 915 if { [xHMextract_param $paramList href] } { 916 # in case they forget </a> 917 foreach v [array names taglist h:*] { 918 unset taglist($v) 919 } 920 $win tag bind h:$href <Enter> "HMdoaref enter $win %x %y" 921 $win tag bind h:$href <Leave> "HMdoaref leave $win %x %y" 922 $win tag bind h:$href <1> "HMdoaref click $win %x %y" 923 set taglist(h:$href) 1 924 set taglist(href) 1 925 926 } 927 if { [xHMextract_param $paramList name] } { 928 $win mark set anchor:$name "$wvar(W_insert) -1 chars" 929 $win mark gravity anchor:$name left 930 } 931 } 932} 933 934proc xHMdo_/a {} { 935 uplevel 1 { 936 foreach v [array names taglist h:*] { unset taglist($v) } 937 catch {unset taglist(href)} 938 } 939} 940 941proc xHMdo_body { win } { 942 global xHMOptions 943 upvar 1 params params 944 upvar #0 xHMvar$win wvar 945 set paramList [xHMsplitParams $params] 946 foreach {key val } $paramList { 947 catch { $win config -$key $val } 948 set wvar(option,$key) $val 949 } 950} 951 952proc xHMdo_img {} { 953 upvar 1 params params 954 upvar 1 wvar wvar 955 upvar 1 taglist taglist 956 upvar 1 win win 957 set paramList [xHMsplitParams $params] 958 959 xHMextract_param $paramList align bottom 960 xHMextract_param $paramList border 1 961 xHMextract_param $paramList width 0 962 xHMextract_param $paramList height 0 963 xHMextract_param $paramList src "" 964# xHMextract_param $paramList alt <image:[file tail $src]> 965 xHMextract_param $paramList alt <image:$src> 966 #puts "img:$src,$alt,$width,$height" 967 if { [lsearch {bottom top center} $align ] < 0 } { set align bottom} 968 set w $win.fr[incr wvar(counter)] 969 set base "" 970 set bg [$win cget -background] 971 972 catch { set base $wvar(url) ; set base $wvar(baseurl) } 973 if { [catch { set im [xHMgetImage $win $src $base $width $height] }] } { 974 error "dont get here now" 975 frame $w -width $width -height $height -background $bg 976 label $w.label -text $alt -background $bg 977 if { $width && $height } { pack propagate $w 0 } 978 pack $w.label -fill both -expand 1 979 } else { 980 if { $wvar(measure) >= 0 } { 981 incr wvar(measure) [image width $image] 982 } 983 label $w -image $im -background $bg 984 bind $w <Enter> [list set maxima_priv(load_rate) "$alt" ] 985 bind $w <Leave> [list set maxima_priv(load_rate) "" ] 986 987 } 988 catch { $w configure -border $border} 989 set href [lindex [array names taglist h:*] 0] 990 if { "$href" != "" } { 991 bind $w <1> "OpenMathOpenUrl [string range $href 2 end] \ 992 -commandpanel [omPanel $win]" 993 } 994 foreach v [array names taglist] { $win tag add $v $wvar(W_insert)} 995 $win window create $wvar(W_insert) -window $w -align $align -padx 1 -pady 1 996 997 998## to do add links for call backs 999} 1000 1001# return an image object.. 1002proc xHMgetImage {win src baseurl width height } { 1003# puts "$win,$src,$baseurl,$width,$height" 1004# puts "getImage [resolveURL $src [decodeURL $baseurl]] $width $height" 1005 return [getImage [resolveURL $src [decodeURL $baseurl]] $width $height] 1006} 1007 1008proc xHMget { url } { 1009} 1010 1011proc xHMlistEnter {} { 1012 uplevel 1 { 1013 xHMassureNewlines [expr {($wvar(indent) < 2 ? 1 : 0)}] 1014 set _ii [expr {(($wvar(indent) <= 0 ) ? 2 : 1)}] 1015 xHMpushAindent $win $_ii 1016 catch { unset wvar(listindex$wvar(indent))} 1017 } 1018} 1019 1020proc xHMlistExit {} { 1021 uplevel 1 { 1022 set _ii [expr {($wvar(indent) <= 2) ? 2 : 1}] 1023 xHMpopAindent $win $_ii 1024 xHMassureNewlines [expr {($wvar(indent) < 2 ? 1 : 0)}] 1025 1026 } 1027} 1028 1029proc dupString { s n } { 1030 set ans "" 1031 while { [incr n -1] >= 0 } { append ans $s } 1032 return $ans 1033} 1034 1035### to do fix this to see how many blank lines there are at our insert 1036### point and to insert ones to make up. 1037proc xHMassureNewlines { n } { 1038 1039 uplevel 1 set _n $n 1040 uplevel 1 { 1041 set _have 0 1042 foreach _v [lrange [split [$win get "$wvar(W_insert)-4char" $wvar(W_insert)] \n] 1 end] { 1043 if { [string trim "$_v" " "] == "" } { 1044 incr _have 1045 } else { 1046 set _have 0 1047 } 1048 } 1049# set _have [$win compare $wvar(W_insert) == "$wvar(W_insert) linestart"] 1050 xHMtextInsert $win [dupString "\n" [expr {$_n - $_have}]] 1051 } 1052} 1053 1054proc xHMsetDefaultPreferences {} { 1055 global maxima_default tcl_platform 1056 1057 if { "$tcl_platform(platform)" == "unix" } { 1058 set pairs { 1 8 1059 2 10 1060 3 12 1061 4 14 1062 5 18 1063 6 24 1064 7 24 1065 8 34 1066 } 1067 } else { 1068 set pairs { 1 6 1069 2 8 1070 3 8 1071 4 10 1072 5 12 1073 6 14 1074 7 16 1075 8 18 1076 } 1077 } 1078 1079 foreach fam {propor fixed} { 1080 foreach {n si} $pairs { set maxima_default($fam,$n) $si} 1081 } 1082 set maxima_default(propor,adjust) [expr {$maxima_default(adjust) + 0}] 1083 set maxima_default(fixed,adjust) [expr {$maxima_default(adjust) + 0}] 1084 array set maxima_default { propor arial fixed courier indentwidth .7 } 1085} 1086 1087xHMsetDefaultPreferences 1088catch { source ~/.xmaximarc } 1089 1090proc dputs {x} { 1091 puts $x ; flush stdout 1092} 1093 1094proc xHMinit_state { win args } { 1095 upvar #0 xHMvar$win wvar 1096 upvar #0 xHMtaglist$win taglist 1097 global maxima_default 1098 array set saveme [array get wvar W_*] 1099 catch { unset wvar} 1100 catch { unset taglist} 1101 array set wvar { 1102 family propor weight normal style r size 3 1103 list list 1104 indent 0 1105 adjust 0 1106 measure -1 1107 W_insert insert 1108 W_update 15 1109 } 1110 array set wvar [array get saveme] 1111 array set taglist {indent:0 1} 1112 1113} 1114 1115proc xHMrender { win tag params text } { 1116 global xHMtag 1117 upvar #0 xHMtaglist$win taglist 1118 upvar #0 xHMvar$win wvar 1119 set prefix "" 1120 1121 set tag [string tolower $tag] 1122 # the following will go in a catch after debugging: 1123 #dputs "doing <$tag>" 1124 #dputs text=<<$text>> 1125 # puts "xHMtag($tag)=[set xHMtag($tag)]" 1126 1127 1128 # eval [set xHMtag($tag)] 1129 if { [info exists xHMtag($tag)] } { 1130 # if { [catch { eval [set xHMtag($tag)] }] } { puts [concat [mc "error evaling tag:"] "$tag"] } 1131 eval [set xHMtag($tag)] 1132 } else { 1133 if { [string match "!--*" $tag] } { list} else { 1134 #puts "undefined $tag: puts comment:$text" 1135 } 1136 } 1137 1138 1139 if { [regexp & $text] } { 1140 set text [xHMconvert_ampersand $text] 1141 } 1142 1143 #dputs "nowrap=[info exists taglist(nowrap)]" 1144 if { ![info exists taglist(nowrap)] } { 1145 regsub -all "\[ \t\r\n\]+" $text " " text 1146 if { "$prefix" != "" } { set text [string trimleft $text] } 1147 } 1148 xHMtextInsert $win $prefix$text 1149} 1150 1151# make a copy of it. 1152proc xHMrender_orig [info args xHMrender] [info body xHMrender] 1153 1154 1155proc xHMtextInsert { win text } { 1156 global xHMtaglist$win 1157 upvar #0 xHMvar$win wvar 1158 # dputs "$win insert $wvar(W_insert) [list $text] [list [array names xHMtaglist$win ]]" 1159 # we calculate the longest unbroken line... 1160 if { 0 && $wvar(measure) >= 0 } { 1161 # puts "hi" 1162 set fo [xHMmapFont $wvar(font)] 1163 set lis [split $text \n] 1164 set ll [font measure $fo [lindex $lis 0]] 1165 incr wvar(measure) $ll 1166 foreach vv [lrange $lis 1 end] { 1167 maxIn wvar(maxwidth) $wvar(measure) 1168 set wvar(measure) [font measure $fo $vv] 1169 } 1170 maxIn wvar(maxwidth) $wvar(measure) 1171 } 1172 $win insert $wvar(W_insert) $text [array names xHMtaglist$win ] 1173} 1174 1175proc xHMset_state { win args } { 1176 upvar #0 xHMvar$win wvar 1177 1178 array set wvar $args 1179 1180} 1181 1182proc toPixelWidth { dim win } { 1183 if { [regexp {([.0-9]+)c} $dim junk d] } { 1184 return [expr {round($d*[winfo screenwidth $win] /(.1*[winfo screenmmwidth $win]))}] } else { 1185 return $dim} 1186 } 1187 1188 1189proc xHMinit_win { win } { 1190 upvar #0 xHMvar$win wvar 1191 global maxima_default 1192 # global xHMvar$win 1193 # catch { unset xHMvar$win } 1194 xHMinit_state $win 1195 $win config -font [xHMmapFont font:fixed:normal:r:3] 1196 catch { eval destroy [winfo children $win] } 1197 set iwidth [toPixelWidth [set maxima_default(indentwidth)]c $win] 1198 # puts iwidth=$iwidth 1199 for { set i 0 } { $i < 12 } { incr i } { 1200 set half [expr {$iwidth/2.0 }] 1201 set w [expr {$i * $iwidth}] 1202 $win tag configure indent:$i -lmargin1 ${w} -lmargin2 ${w} -tabs \ 1203 "[expr {$w + $half}] [expr {$w + 2*$half}]" 1204 } 1205 # $win tag bind doaref <Enter> "HMdoaref enter $win %x %y" 1206 # $win tag bind doaref <Leave> "HMdoaref leave $win %x %y" 1207 # $win tag bind doaref <1> "HMdoaref click $win %x %y" 1208 1209 $win tag configure indent:0 -lmargin1 ${half} -lmargin2 ${half} -tabs "${half} [expr {2 * $half}]" 1210 $win tag configure href -borderwidth 2 -foreground blue -underline 1 1211 1212 $win tag configure nowrap -wrap none 1213 $win tag configure rindent -rmargin $iwidth 1214 $win tag configure strike -overstrike 1 1215 1216 $win tag configure underline -underline 1 1217 $win tag configure center -justify center 1218 $win configure -wrap word 1219} 1220 1221global HMdefaultOptions 1222set HMdefaultOptions { 1223 {atagforeground blue "foreground for <a href=...> tags"} 1224 {currenthrefforeground red "foreground of current <a href=..> tags"} 1225 {foreground black "foreground"} 1226 {background white "background "} 1227 {atagbackground blue "background for <a href=...> tags" } 1228} 1229 1230foreach v $HMdefaultOptions {set HMOption([lindex $v 0]) [lindex $v 1] } 1231 1232proc xHMwget { win key dflt } { 1233 upvar #0 xHMvar$win wvar 1234 if { [info exists wvar($key)] } { 1235 return $wvar($key) 1236 } else { 1237 return $dflt 1238} 1239 } 1240 1241proc HMdoaref { action win x y } { 1242 global HMOption 1243 set tags [$win tag names @$x,$y ] 1244 set i [lsearch $tags h:*] 1245 set tag [lindex $tags $i] 1246 set reference [string range [lindex $tags $i] 2 end] 1247 # puts "$action $x $y"do_a 1248 switch -- $action { 1249 enter { 1250 if { $i >= 0 } { 1251 set ranges [$win tag ranges $tag] 1252 eval $win tag add currenthref $ranges 1253 textShowHelp $win currenthref @$x,$y [concat [mc "Click to follow link to"] "$reference"] 1254 1255 $win tag bind $tag <Leave> "deleteHelp $win ;$win tag remove currenthref $ranges" 1256 $win tag config currenthref -foreground [xHMwget $win option,atagforeground $HMOption(currenthrefforeground)] } 1257 } 1258 click { 1259 if { $i>= 0 } { 1260 global [oarray $win] 1261 if { [info exists [oloc $win dontopen]] } { 1262 unset [oloc $win dontopen] 1263 } else { 1264 oset $win dontopen 1 1265 OpenMathOpenUrl $reference \ 1266 -commandpanel [omPanel $win] 1267 catch { unset [oloc $win dontopen] } 1268 } 1269 return 1270 } 1271 1272 } 1273 leave { 1274 1275 $win tag delete currenthref 1276 } 1277 } 1278 } 1279 1280proc xHMdo_isindex {} { 1281 uplevel 1 { 1282 set paramList [xHMsplitParams $params] 1283 xHMextract_param $paramList prompt [mc " Enter search keywords: "] 1284 xHMtextInsert $win $prompt 1285 set w $win.entry[incr wvar(counter)] 1286 entry $w 1287 # puts "wvar=[array get wvar]" 1288 $win window create $wvar(W_insert) -window $w -padx 1 -pady 1 1289 bind $w <Return> "xHMget $wvar(url)?\[xHMencode_get \[$w get\]\]" 1290 } 1291} 1292 1293# encode a string where 1294# " " --> "+" 1295# "\n" --> "%0d%0a" 1296# [a-zA-Z0-9] --> self 1297# c --> [format %.2x $c] 1298 1299# make a list of all characters, to get char code from char. 1300global xHMallchars 1301set xHMallchars "" 1302for { set i 1} { $i <256 } {incr i } { append xHMallchars [format %c $i] } 1303 1304proc xHMhexChar { c } { 1305 global xHMallchars 1306 set i [string first $c $xHMallchars] 1307 return %[format %.2x [expr {$i + 1}]] 1308} 1309 1310# "ISO 8879-1986//ENTITIES Added Latin 1 substitutions 1311array set isoLatin1 { 1312 AElig \xc6 Aacute \xc1 Acirc \xc2 Agrave \xc0 1313 Aring \xc5 Atilde \xc3 Auml \xc4 Ccedil \xc7 1314 ETH \xd0 Eacute \xc9 Ecirc \xca Egrave \xc8 1315 Euml \xcb Iacute \xcd Icirc \xce Igrave \xcc 1316 Iuml \xcf Ntilde \xd1 Oacute \xd3 Ocirc \xd4 1317 Ograve \xd2 Oslash \xd8 Otilde \xd5 Ouml \xd6 1318 THORN \xde Uacute \xda Ucirc \xdb Ugrave \xd9 1319 Uuml \xdc Yacute \xdd aacute \xe1 acirc \xe2 1320 acute \xb4 aelig \xe6 agrave \xe0 amp \x26 1321 aring \xe5 atilde \xe3 auml \xe4 brvbar \xa6 1322 cb \x7d ccedil \xe7 cedil \xb8 cent \xa2 1323 copy \xa9 curren \xa4 deg \xb0 divide \xf7 1324 eacute \xe9 ecirc \xea egrave \xe8 eth \xf0 1325 euml \xeb frac12 \xbd frac14 \xbc frac34 \xbe 1326 gt \x3e hibar \xaf iacute \xed icirc \xee 1327 iexcl \xa1 igrave \xec iquest \xbf iuml \xef 1328 laquo \xab lt \x3c micro \xb5 middot \xb7 1329 nbsp \xa0 not \xac ntilde \xf1 oacute \xf3 1330 ob \x7b ocirc \xf4 ograve \xf2 ordf \xaa 1331 ordm \xba oslash \xf8 otilde \xf5 ouml \xf6 1332 para \xb6 plusmn \xb1 pound \xa3 quot \x22 1333 raquo \xbb reg \xae sect \xa7 shy \xad 1334 sup1 \xb9 sup2 \xb2 sup3 \xb3 szlig \xdf 1335 thorn \xfe times \xd7 uacute \xfa ucirc \xfb 1336 ugrave \xf9 uml \xa8 uuml \xfc yacute \xfd 1337 yen \xa5 yuml \xff 1338} 1339 1340proc xHMencode_get { str } { 1341 regsub -all "\[^a-zA-Z0-9\]" $str "\[xHMencode_get1 {x&x}]" str 1342 regsub -all "{x(\[{}\])x}" $str \{\\\\\\1x\} str 1343 return [subst -novariables -nobackslashes $str ] 1344} 1345 1346proc xHMencode_get1 { s } { 1347 set c [string index $s 1] 1348 switch -- $c { 1349 \n { return %0d%0a } 1350 " " { return + } 1351 default { return [xHMhexChar $c ]} 1352 } 1353} 1354 1355 1356proc HexDecode { me } { 1357 regsub -all {\+} $me " " me 1358 if { [regexp % $me] } { 1359 regsub -all {\[} $me {[dec1 5b]} me 1360 regsub -all {%([0-9A-Fa-f][0-9A-Fa-f])} $me {[dec1 \1]} me 1361 subst -nobackslashes -novariables $me 1362 } else { 1363 return $me } 1364} 1365proc dec1 { s } { 1366 if { [scan $s %x d] } { 1367 format %c $d 1368 } else { 1369 error [concat [mc "cant decode hex"] "$s"] 1370 } 1371} 1372 1373 1374 1375 1376# 1377 #----------------------------------------------------------------- 1378 # 1379 # xHMparse_html -- takes HTML containing valid html code, and 1380 # converts it into a sequence of calls to CMD. These 1381 # CMD should take 4 arguments: 1382 # tagname slash tagArguments followingText 1383 # where slash is {} or {/} depending on whether the TAGNAME was 1384 # prefixed with a '/'. The tagAguments are not parsed: eg 1385 # <foo bil=good joe> hi there <next> this is 1386 # would turn into 1387 # $CMD {foo} {} {bil=good joe} {hi there} 1388 # $CMD {next} {} {} {this is..} 1389 # We have tried to stay call compatible with a similar command 1390 # written by Stephen Uhler. Our handling of all the tags is different 1391 # however. 1392 # 1393 # Results: none 1394 # 1395 # Side Effects: the sequence of $CMD is evald. 1396 # 1397 #---------------------------------------------------------------- 1398# 1399proc xHMparse_html {html {cmd HMtest_parse} {firstTag hmstart}} { 1400 #dputs "beginning parse" 1401 1402 global meee ; set meee $html; 1403 regsub -all {(['\"])\./\.\.} $html {\1..} html 1404 regsub -- "^.*<!DOCTYPE\[^>\]*>" $html {} html 1405 regsub -all -- "--(\[ \t\n\]*)>" $html "\001\\1\002" html 1406 regsub -all -- "<--(\[^\001\]*)\001(\[^\002\]*)\002" $html \ 1407 {\<--\1--\2\>} html 1408 regsub -all -- "<!--\[^\001\]*\001(\[^\002\]*)\002" $html {} html 1409 1410 regsub -all \} <$firstTag>\n$html\n</$firstTag> {\&cb;} html 1411 #dputs "beginning parse1" 1412 regsub -all \{ $html {\&ob;} html 1413 # prevent getting \} \{ or \\n in a braces expression. 1414 regsub -all "\\\\(\[\n<>])" $html "\\\\\1" html 1415 #regsub -all "<(/?)(\[^ \t\n\r>]+)\[ \t\n\r\]*(\[^>]*)>" $html \ 1416 "\}\n$cmd {\\2} {\\1} {\\3} \{" html 1417 regsub -all "<(\[^ \t\n\r>]+)\[ \t\n\r\]*(\[^>]*)>" $html \ 1418 "\}\n$cmd {\\1} {\\2} \{" html 1419 # puts "<html=$html>" 1420 #dputs "beginning end splitparse1" 1421 1422 #dputs "list {$html}" 1423 eval "list {$html}" 1424 1425} 1426 1427proc myPost { win menu } { 1428 bind $menu <Leave> "place forget $menu" 1429 place $menu -anchor center -relx 0 -rely 1.0 -bordermode outside -in $win 1430 raise $menu 1431} 1432## endsource myhtml.tcl 1433