diff options
Diffstat (limited to 'ds9/library/hv.tcl')
| -rw-r--r-- | ds9/library/hv.tcl | 931 |
1 files changed, 931 insertions, 0 deletions
diff --git a/ds9/library/hv.tcl b/ds9/library/hv.tcl new file mode 100644 index 0000000..b4d5307 --- /dev/null +++ b/ds9/library/hv.tcl @@ -0,0 +1,931 @@ +# Copyright (C) 1999-2016 +# Smithsonian Astrophysical Observatory, Cambridge, MA, USA +# For conditions of distribution and use, see copyright notice in "copyright" + +package provide DS9 1.0 + +proc HVDef {} { + global ihv + + set ihv(unique) 0 + set ihv(windows) {} +} + +# Public + +proc HV {varname title url {init {}} {sync 0}} { + upvar #0 $varname var + global $varname + + global ds9 + global ihv + + global debug + if {$debug(tcl,hv)} { + puts stderr "HV $varname $title $url $init $sync" + } + + set var(top) ".${varname}" + set var(mb) ".${varname}mb" + + set w $var(top) + set mb $var(mb) + + # see if we already have a window visible + + if {[winfo exists $w]} { + raise $w + } else { + # add it to our xpa list + lappend ihv(windows) $varname + + set var(widget) {} + set var(status) {} + set var(sync) $sync + set var(frame) new + set var(save) 0 + set var(title) "$title" + set var(copy) {} + set var(search) {} + set var(search,start) 0 + + set var(active) 0 + set var(index) 0 + set var(font) $ds9(times) + switch $ds9(wm) { + x11 {set var(font,size) 10} + aqua {set var(font,size) 16} + win32 {set var(font,size) 14} + } + set var(font,weight) normal + set var(font,slant) roman + set var(init) $init + set var(cookies) {} + + set var(images,forward) ${varname}forward + set var(images,back) ${varname}back + set var(images,reload) ${varname}reload + set var(images,stop) ${varname}stop + set var(images,gray) ${varname}gray + + # init some vars + HVClearAll $varname + set var(delete) 0 + + # create window + Toplevel $w $mb 7 $title "HVDestroy $varname" + + $mb add cascade -label [msgcat::mc {File}] -menu $mb.file + $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit + $mb add cascade -label [msgcat::mc {View}] -menu $mb.view + $mb add cascade -label [msgcat::mc {Frame}] -menu $mb.frame + + menu $mb.file + $mb.file add command -label [msgcat::mc {Open URL}] \ + -command "HVURLDialogCmd $varname" + $mb.file add command -label [msgcat::mc {Open File}] \ + -command "HVFileDialogCmd $varname" + $mb.file add separator + $mb.file add command -label [msgcat::mc {Clear}] \ + -command "HVClearCmd $varname" + $mb.file add separator + $mb.file add command -label [msgcat::mc {Close}] \ + -command "HVDestroy $varname" + + menu $mb.edit + $mb.edit add command -label [msgcat::mc {Cut}] \ + -state disabled -accelerator "${ds9(ctrl)}X" + $mb.edit add command -label [msgcat::mc {Copy}] \ + -command "HVCopyCmd $varname" -accelerator "${ds9(ctrl)}C" + $mb.edit add command -label [msgcat::mc {Paste}] \ + -state disabled -accelerator "${ds9(ctrl)}V" + $mb.edit add separator + switch $ds9(wm) { + x11 - + win32 { + $mb.edit add command -label "[msgcat::mc {Find}]..." \ + -command "HVFindCmd $varname" -accelerator "${ds9(ctrl)}F" + } + aqua { + # Known bug in Tk, can't have dialogs invoked by accelerator + $mb.edit add command -label "[msgcat::mc {Find}]..." \ + -command "HVFindCmd $varname" + } + } + $mb.edit add command -label [msgcat::mc {Find Next}] \ + -command "HVFindNextCmd $varname" -accelerator "${ds9(ctrl)}G" + $mb.edit add separator + $mb.edit add command -label [msgcat::mc {Clear Cache}] \ + -command "HVClearCache $varname" + + menu $mb.view + $mb.view add command -label [msgcat::mc {Back}] \ + -command "HVBackCmd $varname" + $mb.view add command -label [msgcat::mc {Forward}] \ + -command "HVForwardCmd $varname" + $mb.view add separator + $mb.view add command -label [msgcat::mc {Stop}] \ + -command "HVStopCmd $varname" + $mb.view add command -label [msgcat::mc {Reload}] \ + -command "HVReloadCmd $varname" + $mb.view add separator + $mb.view add command -label [msgcat::mc {Page Source}] \ + -command "HVPageSourceCmd $varname" + + menu $mb.frame + $mb.frame add checkbutton \ + -label [msgcat::mc {Save Image on Download}] \ + -variable ${varname}(save) + $mb.frame add separator + $mb.frame add radiobutton \ + -label [msgcat::mc {Create New Frame on Download}] \ + -variable ${varname}(frame) -value new + $mb.frame add radiobutton \ + -label [msgcat::mc {Use Current Frame on Download}] \ + -variable ${varname}(frame) -value current + + image create photo $var(images,back) -data {R0lGODlhDwANAKL/AM///8DAwJD//y/I/y+X/y9n/wAAAAAAACH5BAEAAAEALAAAAAAPAA0AAAM0GLq2/qE0+AqYVFmB6eZFKEoRIAyCaaYCYWxDLM9uYBAxoe/7dA8ug3AoZOg6mRsyuUxmEgA7} + image create photo $var(images,forward) -data {R0lGODlhDwANAKL/AM///8DAwJD//y/I/y+X/y9n/wAAAAAAACH5BAEAAAEALAAAAAAPAA0AAAM3GLpa/K8YSMuYlBVwV/kgCAhdsAFoig7ktA1wLA9SQdw4DkuB4f8/Ag2TMRB4GYUBmewRm09FAgA7} + image create photo $var(images,stop) -data {R0lGODlhDQANALP/AP///1Lq81I5Of+EhCEAAHsAAMYAAP+UQv9zCHuMjP8AMf8AKf+MnK1CSv8QIQAAACH5BAEAAAEALAAAAAANAA0AAARWMMjUTC1J6ubOQYdiCBuIIMuiiCT1OWu6Ys05AMPC4ItBGB8dYMdI+RoHR4qY6v1CwlvRcEQ4brndwFAgJAwIRdPIzVTEYiqXJBEU1FQCW5Mg2O0ZSQQAOw==} + image create photo $var(images,reload) -data {R0lGODlhDAANALP/AP///zk5OVJSUoSEhKWlpcDAwP//1v//xr3erZTOezGcEFKtSimce3NzezkxOQAAACH5BAEAAAUALAAAAAAMAA0AAARRcJBJyRilEMC5AcjQaB1wHMYkCFuXLKDQONsBLIuynEBAGAcJAnYy0AyGBOLENPg4qGUISTMdEIoEg4A6ohK6BND4YyqBqCdyve453vB44BEBADs=} + + image create photo $var(images,gray) -data {R0lGODdhPAA+APAAALi4uAAAACwAAAAAPAA+AAACQISPqcvtD6OctNqLs968+w+G4kiW5omm6sq27gvH8kzX9o3n+s73/g8MCofEovGITCqXzKbzCY1Kp9Sq9YrNFgsAO} + + # Buttons + set f [ttk::frame $w.buttons] + ttk::button $f.back -image $var(images,back) -takefocus 0 \ + -command "HVBackCmd $varname" + ttk::button $f.forward -image $var(images,forward) -takefocus 0 \ + -command "HVForwardCmd $varname" + ttk::button $f.stop -image $var(images,stop) -takefocus 0 \ + -command "HVStopCmd $varname" + ttk::button $f.reload -image $var(images,reload) -takefocus 0 \ + -command "HVReloadCmd $varname" + pack $f.back $f.forward $f.stop $f.reload -side left + + # Param + set f [ttk::frame $w.param] + + set var(widget) [html $f.html \ + -yscrollcommand "$f.yscroll set" \ + -xscrollcommand "$f.xscroll set" \ + -padx 5 \ + -pady 9 \ + -formcommand "HVFormCB $varname" \ + -imagecommand "HVImageCB $varname" \ + -scriptcommand "HVScriptCB $varname"\ + -appletcommand "HVAppletCB $varname" \ + -framecommand "HVFrameCB $varname" \ + -underlinehyperlinks 1 \ + -bg white \ + -width 640 \ + -height 512 \ + -fontcommand "HVFontCB $varname" \ + -tablerelief raised \ + ] + + $var(widget) token handler {NOSCRIPT} "HVNoScriptCB $varname" + $var(widget) token handler {/NOSCRIPT} "HVNoScriptCB $varname" + + ttk::scrollbar $f.yscroll -orient vertical \ + -command "$f.html yview" + ttk::scrollbar $f.xscroll -orient horizontal \ + -command "$f.html xview" + + grid $f.html $f.yscroll -sticky news + grid $f.xscroll -stick news + grid rowconfigure $f 0 -weight 1 + grid columnconfigure $f 0 -weight 1 + + bind $var(widget).x <Motion> "HVMotion $varname %x %y" + bind $var(widget).x <Button-1> "HVButton1 $varname %x %y" + bind $var(widget).x <B1-Motion> "HVMotion1 $varname %x %y" + bind $var(widget).x <ButtonRelease-1> "HVRelease1 $varname %x %y" + + bind $w <Up> "$f.html yview scroll -1 units" + bind $w <Down> "$f.html yview scroll 1 units" + bind $w <Right> "$f.html xview scroll 1 units" + bind $w <Left> "$f.html xview scroll -1 units" + bind $w <<Copy>> "HVCopyCmd $varname" + switch $ds9(wm) { + x11 { + bind $w <Button-4> "HVMouseWheel $varname 1" + bind $w <Button-5> "HVMouseWheel $varname -1" + bind $w <<Find>> [list HVFindCmd $varname] + } + aqua { + bind $w <MouseWheel> "HVMouseWheel $varname %D" + # Known bug in Tk, can't have dialogs invoked by accelerator + } + win32 { + bind $w <MouseWheel> "HVMouseWheel $varname %D" + bind $w <<Find>> [list HVFindCmd $varname] + } + } + bind $w <<FindNext>> [list HVFindNextCmd $varname] + + # Status + set f [ttk::frame $w.status] + ttk::label $f.status -textvariable ${varname}(status) \ + -width 120 -anchor w + pack $f.status -side left + + # Fini + ttk::separator $w.sep -orient horizontal + pack $w.status $w.sep -side bottom -fill x + pack $w.buttons -side top -fill x + pack $w.param -side top -fill both -expand true + + # we have a problem with the html widget. first time thur, some + # structures are not allocated/initialized. if we first display + # a blank page, all seems ok + $var(widget) clear + $var(widget) parse "<html>\n<body>\n<form method=\"get\" action=\"foo\">\n</form>\n</body>\n</html>" + + global debug + if {$debug(tcl,idletasks)} { + puts stderr "HV" + } + update idletasks + } + + selection handle $w [list HVExportSelection $varname] + + if {$url != {}} { + # no need to resolve + HVLoadURL $varname $url {} $var(sync) + } +} + +# Bindings + +proc HVMotion {varname x y} { + upvar #0 $varname var + global $varname + + global ds9 + + set url [$var(widget) href $x $y] + + if {[string length $url] > 0} { + switch $ds9(wm) { + x11 - + win32 {$var(widget) configure -cursor hand2} + aqua {$var(widget) configure -cursor pointinghand} + } + } else { + $var(widget) configure -cursor {} + } + + HVStatus $varname $url +} + +proc HVButton1 {varname x y} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVButton1" + } + + $var(widget) selection clear + set var(sel,x) -1 + set var(sel,y) -1 + + HVClearIndex $varname $var(index) + + set url [$var(widget) href $x $y] + if {[string length $url] != 0} { + HVResolveURL $varname $url + } else { + set var(sel,x) $x + set var(sel,y) $y + } +} + +proc HVMotion1 {varname x y} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVMotion1" + } + + if {$var(sel,x) != -1 && $var(sel,y) != -1} { + $var(widget) selection set @$var(sel,x),$var(sel,y) @$x,$y + } +} + +proc HVRelease1 {varname x y} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVRelease1" + } + + if {$var(sel,x) != -1 && $var(sel,y) != -1} { + set var(copy) [$var(widget) text ascii @$var(sel,x),$var(sel,y) @$x,$y] + selection own -command [list HVLostSelection $varname] $var(top) + } +} + +proc HVMouseWheel {varname cnt} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVMouseWheel" + } + + $var(widget) yview scroll [expr -$cnt] units +} + +# Commands + +proc HVClearCmd {varname} { + upvar #0 $varname var + global $varname + + # clear the widge and all images + $var(widget) clear + + HVClearCache $varname + HVClearAll $varname +} + +proc HVCopyCmd {varname} { + upvar #0 $varname var + global $varname + + clipboard clear -displayof $var(top) + clipboard append -displayof $var(top) $var(copy) +} + +proc HVExportSelection {varname offset bytes} { + upvar #0 $varname var + global $varname + + if {$var(copy) != {}} { + return [string range $var(copy) $offset [expr $offset+$bytes]] + } +} + +proc HVLostSelection {varname} { + upvar #0 $varname var + global $varname + + $var(widget) selection clear + set var(copy) {} +} + +proc HVURLDialogCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + + set url "$var(url)" + if {[EntryDialog [msgcat::mc {URL}] [msgcat::mc {Enter URL}] 80 url]} { + if {[string length $url] == 0} { + return + } + + ParseURL $url r + switch -- $r(scheme) { + {} { + # append 'http://' if needed + if {[string range $r(path) 0 0] == "/"} { + set url "http:/$url" + } else { + set url "http://$url" + } + + if {$debug(tcl,hv)} { + puts stderr "HVURLDialogCmd new $url" + } + } + } + + # clear the base + $var(widget) config -base {} + + HVClearIndex $varname 0 + HVClearAll $varname + # no need to resolve + HVLoadURL $varname $url {} + } +} + +proc HVFileDialogCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + + set fn [OpenFileDialog hvhtmlfbox] + if {"$fn" != {}} { + HVFileDialog $varname "$fn" + } +} + +proc HVFileDialog {varname fn} { + upvar #0 $varname var + global $varname + + global debug + + # clear the base + $var(widget) config -base {} + + HVClearIndex $varname 0 + HVClearAll $varname + # no need to resolve + HVLoadURL $varname "$fn" {} +} + +proc HVBackCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVBackCmd index $var(index)" + } + + incr ${varname}(index) -1 + if {[info exists ${varname}(index,$var(index))]} { + set url [lindex $var(index,$var(index)) 0] + set query [lindex $var(index,$var(index)) 1] + if {$debug(tcl,hv)} { + puts stderr "HVBackCmd :$var(index):$url:$query:" + } + # clear the base + $var(widget) config -base {} + + # HVGotoHTML will incr the index again + incr ${varname}(index) -1 + # no need to resolve + HVLoadURL $varname $url $query $var(sync) + } else { + incr ${varname}(index) + } +} + +proc HVFind {varname} { + upvar #0 $varname var + global $varname + + set toks [$var(widget) token list 1.0 end] + + set aa -1 + set bb 0 + set cc -1 + set dd 0 + set id -1 + set ss $var(search,start) + + while {$ss<[llength $toks] && $cc==-1} { + set pat [lindex $var(search) 0] + set id [lsearch -glob -start $ss $toks "Text *$pat*"] + + if {$id != -1} { + set ok 1 + + set aa $id + set ss $id + set tt [string first $pat [lindex [lindex $toks $aa] 1]] + if {$tt != -1} { + set bb $tt + } + + for {set ii 1} {$ii<[llength $var(search)]} {incr ii} { + set pat [lindex $var(search) $ii] + set str [lindex [lindex $toks [expr $id+$ii*2]] 1] + if {[string compare -length [string length $pat] $pat $str]} { + incr ss + set ok 0 + break + } + } + + if {$ok} { + set cc [expr $aa+([llength $var(search)]-1)*2] + set tt [string last $pat [lindex [lindex $toks $cc] 1]] + if {$tt != -1} { + set dd [expr $tt+[string length $pat]] + } + } + } else { + break + } + } + + if {$aa == -1 || $cc == -1} { + return 0 + } else { + set var(search,start) [expr $cc+1] + $var(widget) selection set "[expr $aa+1].$bb" "[expr $cc+1].$dd" + $var(widget) yview text "[expr $aa+1].$bb" + return 1 + } +} + +proc HVFindCmd {varname} { + upvar #0 $varname var + global $varname + + set result "$var(search)" + if {[EntryDialog [msgcat::mc {Search}] [msgcat::mc {Enter Search Expression}] 40 result]} { + set var(search) "$result" + set var(search,start) 0 + $var(widget) selection clear + + if {![HVFind $varname]} { + Error "$var(search) [msgcat::mc {Not Found}]" + } + } +} + +proc HVFindNextCmd {varname} { + upvar #0 $varname var + global $varname + + if {$var(search,start) == 0} { + HVFindCmd $varname + } else { + if {![HVFind $varname]} { + # wrap + set var(search,start) 0 + if {![HVFind $varname]} { + Error "$var(search) [msgcat::mc {Not Found}]" + } + } + } +} + +proc HVForwardCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVForwardCmd $var(index)" + } + + incr ${varname}(index) + if {[info exists ${varname}(index,$var(index))]} { + set url [lindex $var(index,$var(index)) 0] + set query [lindex $var(index,$var(index)) 1] + if {$debug(tcl,hv)} { + puts stderr "HVForwardCmd :$var(index):$url:$query:" + } + # clear the base + $var(widget) config -base {} + + # HVGotoHTML will incr the index again + incr ${varname}(index) -1 + # no need to resolve + HVLoadURL $varname $url $query $var(sync) + } else { + incr ${varname}(index) -1 + } +} + +proc HVGotoCmd {varname nn} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVGotoCmd $nn" + } + + set var(index) $nn + if {[info exists ${varname}(index,$var(index))]} { + set url [lindex $var(index,$var(index)) 0] + set query [lindex $var(index,$var(index)) 1] + if {$debug(tcl,hv)} { + puts stderr "HVGotoCmd :$var(index):$url:$query:" + } + # clear the base + $var(widget) config -base {} + + # HVGotoHTML will incr the index again + incr ${varname}(index) -1 + # no need to resolve + HVLoadURL $varname $url $query $var(sync) + } else { + incr ${varname}(index) + } +} + +proc HVReloadCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVReloadCmd" + } + + # clear the base + $var(widget) config -base {} + + # HVGotoHTML will incr the index again + incr ${varname}(index) -1 + # no need to resolve + HVLoadURL $varname $var(url) $var(query) $var(sync) +} + +proc HVStopCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "\n*** HVStopCmd ***\n" + } + + HVCancel $varname +} + +proc HVPageSourceCmd {varname} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVPageSourceCmd" + } + + SimpleTextDialog ${varname}txt $var(url) 80 20 insert top $var(data) +} + +proc HVArchUserCmd {varname title url} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVArchUserCmd" + } + + if {[string length $url] == 0} { + return + } + + ParseURL $url r + switch -- $r(scheme) { + {} { + # append 'http://' if needed + if {[string range $r(path) 0 0] == "/"} { + set url "http:/$url" + } else { + set url "http://$url" + } + + if {$debug(tcl,hv)} { + puts stderr "HVArchUserCmd new $url" + } + } + } + HV $varname $title $url +} + +proc HVAnalysisCmd {varname title url sync} { + upvar #0 $varname var + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVAnalysisCmd $varname $title $url $sync" + } + + if {[string length $url] == 0} { + HV $varname "$title" {} {} $sync + } else { + ParseURL $url r + switch -- $r(scheme) { + {} { + # append 'http://' if needed + if {[string range $r(path) 0 0] == "/"} { + set url "http:/$url" + } else { + set url "http://$url" + } + + if {$debug(tcl,hv)} { + puts stderr "HVAnalysisCmd new $url" + } + } + } + HV $varname "$title" $url {} $sync + } +} + +proc HVAnalysisURL {which i url sync} { + set varname "at${which}${i}" + global $varname + + global debug + if {$debug(tcl,hv)} { + puts stderr "HVAnalysisURL $which $i $url" + } + + set ${varname}(cookies) {} + set ${varname}(sync) $sync + HVClearAll $varname + HVSetAnalysis $varname 1 $which $i + HVLoadURL $varname $url {} $sync +} + +proc HVAnalysisCancel {which i} { + set varname "at${which}${i}" + global $varname + + HVCancel $varname +} + +# Archive Servers + +proc HVArchChandraChaser {} { + global current + + set coord {} + if {$current(frame) != {}} { + if {[$current(frame) has wcs equatorial wcs]} { + set coord [$current(frame) get fits center wcs fk5 degrees] + set size \ + [expr [lindex [$current(frame) get fits size wcs fk5 arcmin] 0]/2.] + } + } + + set l {} + if {[string length $coord] != 0} { + lappend l "1 lon [lindex $coord 0]" + lappend l "1 lat [lindex $coord 1]" + lappend l "1 radius $size" + } + + global hvchandrachaser + HV hvchandrachaser {Chandra Chaser} http://cda.harvard.edu/chaser/mainEntry.do $l +} + +proc HVArchChandraPop {} { + global current + + set coord {} + if {$current(frame) != {}} { + if {[$current(frame) has wcs equatorial wcs]} { + set coord [$current(frame) get fits center wcs fk5 degrees] + set size \ + [expr [lindex [$current(frame) get fits size wcs fk5 arcmin] 0]/2.] + } + } + + set l {} + if {[string length $coord] != 0} { + lappend l "1 lon [lindex $coord 0]" + lappend l "1 lat [lindex $coord 1]" + lappend l "1 radius $size" + lappend l "1 searchBy position" + } + + global hvchandrapop + HV hvchandrapop {Chandra Popular} http://cda.harvard.edu/pop/mainEntry.do $l +} + +proc HVArchChandraFTP {} { + global current + + set ra {} + set dec {} + set wid {} + + if {$current(frame) != {}} { + if {[$current(frame) has wcs equatorial wcs]} { + set coord [$current(frame) get fits center wcs fk5 sexagesimal] + set ra [lindex $coord 0] + set dec [lindex $coord 1] + + set wid [lindex [$current(frame) get fits size wcs fk5 degrees] 0] + } + } + + set l {} + if {[string length $ra] != 0} { + lappend l "1 ra \{$ra\}" + lappend l "1 dec \{$dec\}" + lappend l "1 wid \{$wid\}" + } + + global hvchandraftp + HV hvchandraftp {Chandra FTP} \ + http://www.cfa.harvard.edu/archive/chandra/search $l +} + +# Other + +# Process Cmds + +proc ProcessWebCmd {varname iname} { + global ihv + + set w {hvweb} + + upvar $varname var + upvar $iname i + + # determine which web browser window + switch -- [string tolower [lindex $var $i]] { + new { + incr i + set ii [lsearch $ihv(windows) $w] + if {$ii>=0} { + append w $ihv(unique) + incr ihv(unique) + } + } + close - + clear - + click {set w [lindex $ihv(windows) end]} + + default { + set ii [lsearch $ihv(windows) [lindex $var $i]] + if {$ii>=0} { + set w [lindex $var $i] + incr i + } + } + } + + switch -- [string tolower [lindex $var $i]] { + close {HVDestroy $w} + clear {HVClearCmd $w} + click { + set vvarname $w + upvar #0 $vvarname vvar + global $vvarname + + incr i + switch -- [string tolower [lindex $var $i]] { + back {HVBackCmd $vvarname} + forward {HVForwardCmd $vvarname} + stop {HVStopCmd $vvarname} + reload {HVReloadCmd $vvarname} + default { + set id [lindex $var $i] + + if {![info exists vvar(widget)]} { + return + } + + set tokens [$vvar(widget) token list 1.0 end] + set cnt 0 + for {set ii 0} {$ii<[llength $tokens]} {incr ii} { + set tok [lindex $tokens $ii] + if {[string tolower [lindex $tok 0]] == "markup" && + [string tolower [lindex $tok 2]] == "href"} { + set url [lindex $tok 3] + incr cnt + if {$cnt == $id} { + HVResolveURL $vvarname [$vvar(widget) resolve $url] + break; + } + } + } + } + } + } + default { + set url [lindex $var $i] + if {[string length $url] == 0} { + HV $w Web {} {} 1 + } else { + ParseURL $url r + switch -- $r(scheme) { + {} { + # append 'http://' if needed + if {[string range $r(path) 0 0] == "/"} { + set url "http:/$url" + } else { + set url "http://$url" + } + } + } + HV $w Web $url {} 1 + } + } + } +} + +proc ProcessSendWebCmd {proc id param} { + global ihv + $proc $id "$ihv(windows)\n" +} + |