interfaces/xmaxima/Tkmaxima/Myhtml.tcl

   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
  17 proc 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
  56 proc xHMpushConstantTag { win tag } {
  57     upvar #0 xHMtaglist$win taglist
  58     if { [catch {incr taglist($tag) } ] } {
  59         set taglist($tag) 1 }
  60 }
  61
  62 proc 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
  70 proc 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
  78 proc 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
  87 proc 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
  94 proc 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
 103 proc 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 #
 144 proc 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
 177 proc 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.
 196 proc 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
 270 proc 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
 279 proc 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
 305 proc 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 "\x01\\1\x01\\6\\8\\9\x01"
 314     regsub -all $reg $param $sub  joe
 315     foreach { dummy key val } [lreplace [split $joe \x01] end end]  { lappend new [string tolower $key] $val}
 316     return $new
 317 }
 318
 319 proc 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
 330 global xHMtag
 331 if {[info exists xHMtag]} {catch {unset xHMtag}}
 332
 333 defTag a -alter {Cdoaref doaref} -body xHMdo_a  -sbody xHMdo_/a
 334 defTag b -alter {weight bold }
 335 defTag -body xHMdo_body
 336 defTag br -before "\n"
 337 defTag center -alter {Ccenter center}
 338 defTag cite -alter {style i}
 339 defTag code -alter {family fixed}
 340 defTag dd -before "\n" -after "\n"
 341 defTag dfn -alter {style i}
 342 defTag dt -before "\n"
 343 defTag em -alter {style i}
 344 defTag h1 -alter {size 7 weight bold} -body {xHMassureNewlines 1} -after "\n"
 345 defTag h2 -alter {size 6} -body {xHMassureNewlines 1} -after "\n"
 346 defTag h3 -alter {size 6} -body {xHMassureNewlines 1} -after "\n"
 347 defTag h4 -alter {size 5} -body {xHMassureNewlines 1} -after "\n"
 348 defTag h5 -alter {size 4} -before "\n" -after "\n"
 349 defTag h6 -alter {size 3 style i} -before "\n" -after "\n"
 350 defTag i -alter {style i}
 351 defTag img -body xHMdo_img
 352
 353 defTag kbd -alter {family fixed weight bold}
 354 defTag li -body xHMdo_li
 355
 356 defTag dl  -body xHMlistEnter -sbody xHMlistExit
 357 defTag dir  -body xHMlistEnter -sbody xHMlistExit
 358 defTag menu -body xHMlistEnter -sbody xHMlistExit
 359 defTag ol  -body {
 360     xHMlistEnter
 361     set wvar(listindex$wvar(indent)) 0} -sbody {
 362         xHMlistExit }
 363
 364 defTag title  -body {wm title [winfo toplevel $win] $text ; set text ""} -sbody {list }
 365 defTag 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 {}
 382 defTag p -before "\n" -body { xHMassureNewlines 1 } -sbody { xHMassureNewlines 1 }
 383 defTag blockquote -before "\n\n" -after "\n"
 384 defTag pre -alter {family fixed Cnowrap nowrap} -before "\n" /pre "\n"
 385 defTag samp -alter {family fixed}
 386 defTag strike -alter {Cstrike strike}
 387 defTag strong -alter {weight bold}
 388 defTag sup -alter {Csup sup}
 389 defTag sub -alter {Csub sub}
 390
 391 defTag tt -alter {family fixed}
 392 defTag u -alter {Cunderline underline}
 393
 394 defTag hrx  -body { $win insert $wvar(W_insert) "\n" ;
 395      $win insert $wvar(W_insert) "\n" hrule
 396     } -sbody {}
 397 defTag hr -before \n  -body {
 398      $win insert $wvar(W_insert) "                  " underline
 399     } -sbody {}
 400
 401 defTag var -alter {style i}
 402
 403 defTag hmstart -alter { family propor   weight normal   style r   size 3
 404         list list
 405         adjust 0 } -body { set wvar(counter) 0 }
 406
 407 defTag 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
 416 proc notyet { args } {
 417     puts [concat [mc "not yet"] "$args"]
 418 }
 419
 420 defTag isindex -body xHMdo_isindex -sbody {}
 421 defTag meta -body list -sbody list
 422 defTag 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     }
 448 defTag input -body xHMdo_input
 449 defTag 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
 481 proc   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
 493 defTag textarea -body "xHMdo_input textarea"
 494 proc 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
 504 defTag html -body "list " -sbody "list "
 505 defTag head -body "list " -sbody "list "
 506 defTag 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
 542 defTag 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
 552 defTag 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
 564 global xHMpriv
 565 set 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 #
 579 proc ldelete { item list } {
 580     while { [set i [lsearch $list $item]] >= 0} {
 581         set list [lreplace $list $i $i]
 582     }
 583     return $list
 584 }
 585 if { ![info exists _gensymCounter] } {set _gensymCounter  0}
 586 proc gensym { name } {
 587     global _gensymCounter
 588     incr _gensymCounter
 589     set var ${name}_${_gensymCounter}
 590     catch { uplevel "#0"  unset $var}
 591     return $var
 592 }
 593
 594 proc 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
 764 proc 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
 772 proc xHMdoReset { formVar } {
 773     upvar #0 $formVar form
 774     eval $form(f_reset)
 775 }
 776 proc 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
 825 proc 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
 836 proc xHMdeleteTooLong { win w } {
 837     upvar #0 xHMvar$win wvar
 838     catch { $w delete $wvar($w,maxlength) end }
 839     #puts $wvar($w,maxlength)
 840 }
 841
 842 proc 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
 848 proc 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
 865 proc 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
 887 proc 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
 904 defTag th -body list
 905 defTag td -body list -after "\t\t\t\t"
 906 defTag tr -body list -after "\n"
 907
 908
 909
 910
 911
 912 proc 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
 934 proc xHMdo_/a  {} {
 935     uplevel 1 {
 936         foreach v [array names taglist h:*] { unset taglist($v) }
 937         catch {unset taglist(href)}
 938     }
 939 }
 940
 941 proc 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
 952 proc 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..
1002 proc 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
1008 proc xHMget { url } {
1009 }
1010
1011 proc 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
1020 proc 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
1029 proc 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.
1037 proc 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
1054 proc 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
1087 xHMsetDefaultPreferences
1088 catch { source ~/.xmaximarc }
1089
1090 proc dputs {x} {
1091     puts $x ; flush stdout
1092 }
1093
1094 proc 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
1115 proc 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.
1152 proc xHMrender_orig [info args xHMrender] [info body xHMrender]
1153
1154
1155 proc 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
1175 proc xHMset_state { win args } {
1176     upvar #0 xHMvar$win wvar
1177
1178     array set wvar $args
1179
1180 }
1181
1182 proc 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
1189 proc 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
1221 global HMdefaultOptions
1222 set 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
1230 foreach v $HMdefaultOptions {set HMOption([lindex $v 0]) [lindex $v 1] }
1231
1232 proc 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
1241 proc 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
1280 proc 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.
1300 global xHMallchars
1301 set xHMallchars ""
1302 for { set i 1} { $i <256 } {incr i } { append xHMallchars [format %c $i] }
1303
1304 proc 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
1311 array 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
1340 proc 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
1346 proc 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
1356 proc 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 }
1365 proc 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 #
1399 proc 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          {\&lt;--\1--\2\&gt;} 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 "\\&#92;\\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
1427 proc 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