1# -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- 2# 3# $Id: Browser.tcl,v 1.25 2011-03-21 09:18:58 villate Exp $ 4# 5###### Browser.tcl ###### 6############################################################ 7# Netmath Copyright (C) 1998 William F. Schelter # 8# For distribution under GNU public License. See COPYING. # 9############################################################ 10 11## source keyb.tcl 12 13###### keyb.tcl ###### 14############################################################ 15# Netmath Copyright (C) 1998 William F. Schelter # 16# For distribution under GNU public License. See COPYING. # 17############################################################ 18 19proc peekLastCommand {win} { 20 global maxima_priv 21 if { [info exists maxima_priv(lastcom,$win)] } { 22 return $maxima_priv(lastcom,$win) 23 } 24} 25 26proc pushCommand { win command arglist } { 27 global maxima_priv 28 set maxima_priv(lastcom,$win) [list $command $arglist] 29} 30 31 32 33# 34#----------------------------------------------------------------- 35# 36# tkTextInsert -- we add some things to the default tkTextInsert 37# so that tags present before or after the insert, which are sticky 38# are added to the inserted string. As usual, ones on both sides 39# are added. 40# 41# Results: 42# 43# Side Effects: 44# 45#---------------------------------------------------------------- 46# 47 48proc tkTextInsert { w s } { 49 global maxima_priv 50 set after [$w tag names insert] 51 set before [$w tag names "insert-1char"] 52 set both [intersect $after $before] 53 # puts "after=$after" 54 # puts "before=$before" 55 56 foreach v [concat $after $before] { 57 if { [regexp -- $maxima_priv(sticky) $v] } { 58 lappend both $v 59 } 60 } 61 62 if { [info exists maxima_priv($w,inputTag) ] } { 63 lappend both $maxima_priv($w,inputTag) 64 } 65 66 if {($s == "") || ([$w cget -state] == "disabled")} { 67 return 68 } 69 catch { 70 if {[$w compare sel.first <= insert] 71 && [$w compare sel.last >= insert]} { 72 $w delete sel.first sel.last 73 } 74 } 75 $w insert insert $s $both 76 $w see insert 77 78} 79proc getRange { win a b } { 80 if { [$win compare $a < $b ] } { 81 return "$a $b" 82 } else { 83 return "$b $a" 84 } 85} 86 87 88# 89#----------------------------------------------------------------- 90# 91# tagRanges -- find ranges on WINDOW for TAG from FROMINDEX below TOINDEX 92# 93# Results: a list of ranges start1 stop1 start2 stop2 .. 94# which are contained in [fromindex,toindex] such that TAG is on from 95# start1 to stop1 etc. 96# 97# Side Effects: 98# 99#---------------------------------------------------------------- 100# 101proc tagRanges { win tag begin end } { 102 if { [$win compare $begin <= 1.0 ] && \ 103 [$win compare $end >= end ] } { 104 return [$win tag ranges $tag ] 105 } else { 106 set answer "" 107 set begin [$win index $begin] 108 set end [$win index $end] 109 if { [lsearch [$win tag names $begin] $tag ]>=0 } { 110 set prev [$win tag prevrange $tag $begin+1chars] 111 set to [lindex $prev 1] 112 if { [$win compare $to > $end ] } { 113 set to $end 114 } 115 append answer "$begin $to " 116 set begin $to 117 } 118 #puts "<$begin $end>" 119 while { [$win compare $begin < $end ] } { 120 set next [$win tag nextrange $tag $begin] 121 #puts "next=$next" 122 if { "$next" == "" } { return $answer } 123 if { [$win compare [lindex $next 1] <= $end]} { 124 append answer "$next " 125 set begin [lindex $next 1] 126 } elseif {[$win compare [lindex $next 0] < $end ]} { 127 append answer "[lindex $next 0] $end" 128 return $answer 129 } else { 130 return $answer 131 } 132 } 133 return $answer 134 135 } 136} 137 138 139# 140#----------------------------------------------------------------- 141# 142# quoteBraces -- given a STRING such that 143# puts $file "set new [quoteBraces $string]" 144# when re read by eval would make value of NEW identical to STRING 145# 146# Results: a string 147# 148# Side Effects: 149# 150#---------------------------------------------------------------- 151# 152proc quoteBraces {string } { 153 regsub -all {[{}]} $string {\\&} val 154 return [list $val] 155} 156 157proc thisRange { win tag index } { 158 set prev [$win tag prevrange $tag $index] 159 if { "$prev" != "" && [$win compare [lindex $prev 1] >= $index] } { 160 return $prev 161 } 162 set next [$win tag nextrange $tag $index] 163 if { "$next" != "" && [$win compare [lindex $next 0] <= $index] } { 164 return $next 165 } 166 return "" 167} 168 169 170 171 172# 173#----------------------------------------------------------------- 174# 175# insertRichText -- insert rich text in TEXTWINDOW at INDEX according 176# to commands and data in LIST. The latter must be of the form 177# command1 arg1 ..argn command2 arg1 ..argn2 .. 178# for example if `Tins' takes two args 179# and the commands must be in 180# since the rich text might come from a selection or some or an untrusted 181# file we want to be careful not to do any bad evals. 182# Results: none 183# 184# Side Effects: the rich text commands are invoked to do insertions 185# on the window. 186# 187#---------------------------------------------------------------- 188# 189proc insertRichText {win index list } { 190 global maxima_priv 191 set maxima_priv(currentwin) $win 192 set maxima_priv(point) $index 193 foreach v $maxima_priv(richTextCommands) { 194 set maxima_priv($v,richTextCommand) [llength [info args $v]] 195 } 196 set i 0 197 set ll [llength $list] 198 while { $i < $ll } { 199 set com [lindex $list $i] 200 incr i 201 if { [catch { set n $maxima_priv($com,richTextCommand)} ] } { 202 return -code error -errorinfo [concat [mc "illegal command in rich text:"] "$com"] 203 } 204 set form [concat $com [lrange $list $i [expr {$i +$n -1}]]] 205 if { [catch {eval $form } ] } { 206 return -code error -errorinfo [concat [mc "unable to evaluate command:"] "`$form'"] } 207 208 incr i $n 209 } 210} 211 212 213proc Tins { tags text } { 214 global maxima_priv 215 # foreach v $args { append text $v } 216 $maxima_priv(currentwin) insert $maxima_priv(point) $text $tags 217} 218 219proc TinsSlashEnd { tags text } { 220 global maxima_priv 221 # foreach v $args { append text $v } 222 $maxima_priv(currentwin) insert $maxima_priv(point) "$text\\" $tags 223} 224 225 226 227## endsource keyb.tcl 228 229proc underTop {top win} { 230 if { "$top" == "." } { 231 return $win 232 } else { 233 return $top$win 234 } 235} 236 237# now unused 238proc showHistory { window } { 239 set top [winfo toplevel $window] 240 set win [omPanel $window] 241 makeLocal $win history historyIndex 242 243 set w [underTop $top .historylist] 244 if {[winfo exists $w]} {catch {destroy $w}} 245 246 frame $w -borderwidth 2 -relief raised 247 label $w.title -text [mc "History List"] -relief raised 248 pack $w.title -side top -fill x 249 setHelp $w.title [mc "This window may be dragged elsewhere by grabbing this title bar with the mouse. Double clicking on a history item, moves to that page."] 250 251 button $w.dismiss -command "destroy $w" -text [mc "Close"] 252 pack $w.dismiss -side bottom -fill x 253 setHelp $w.dismiss [mc "Remove the history list"] 254 255 scrollbar $w.scrolly -command "$w.list yview" 256 scrollbar $w.scrollx -orient horizontal -command "$w.list xview" 257 pack $w.scrollx -side bottom -fill x -expand 1 258 pack $w.scrolly -side right -fill y -expand 1 259 listbox $w.list -yscroll "$w.scrolly set" \ 260 -width 35 -height 16 -setgrid 1 -xscroll "$w.scrollx set" 261 $w.title configure -font [$w.list cget -font] 262 set l $w.list 263 264 pack $w.list -side top -fill both -expand 1 265 resetHistory $win $w.list junk history 266 global [oarray $win] 267 268 #puts " trace variable [oloc $win history] w {resetHistory $win $w.list}" 269 trace vdelete [oloc $win history] w "resetHistory $win $w.list" 270 trace variable [oloc $win history] w "resetHistory $win $w.list" 271 trace vdelete [oloc $win historyIndex] w "resetHistory $win $w.list" 272 trace variable [oloc $win historyIndex] w "resetHistory $win $w.list" 273 bind $l <Double-1> {OpenMathMoveHistory [omPanel %W] [expr [%W index @%x,%y]-[oget [omPanel %W] historyIndex]]} 274 bind $w.title <B1-Motion> "dragPlacedWindow $w %W %X %Y" 275 bind $w.title <1> "startDragPlacedWindow $w %X %Y" 276 place $w -relx .4 -rely .8 -in $top 277 278 279} 280 281proc deleteAllTraces {var} { 282 foreach v [uplevel "#0" trace vinfo $var] { 283 uplevel "#0" trace vdelete $var [lindex $v 0] [list [lindex $v 1]] 284 } 285} 286 287# now unused 288proc resetHistory { win list args } { 289 set action [lindex $args 1] 290 if { [catch { 291 if { "$action" == "history" } { 292 $list delete 0 end 293 if { [winfo exists $list] } { 294 foreach v [oget $win history] { 295 $list insert end [oget $v location] 296 } 297 } 298 } 299 $list selection clear 0 end 300 $list selection set [oget $win historyIndex] 301 after 200 raise [winfo parent $list] 302 303 } ] } { 304 deleteAllTraces [oloc $win history] 305 deleteAllTraces [oloc $win historyIndex] 306 } 307} 308 309 310proc startDragPlacedWindow { win x y } { 311 oset $win placeinfo [list $x $y [place info $win]] 312} 313 314proc dragPlacedWindow { win w1 x y } { 315 global me recursive 316 makeLocal $win placeinfo 317 catch { after cancel [oget $win after]} 318 set me [oget $win placeinfo] 319 #puts "have=[oget $win placeinfo]" 320 desetq "px py pinfo" [oget $win placeinfo] 321 set dx [expr {$x - $px}] 322 set dy [expr {$y - $py}] 323 set nx [expr {$dx + [assoc -x $pinfo]}] 324 set ny [expr {$dy + [assoc -y $pinfo]}] 325 set new "-x $nx -y $ny" 326 eval place $win $new 327 oset $win placeinfo [list $x $y $new] 328} 329 330# now unused 331proc OpenMathMoveHistory { win n } { 332 makeLocal $win history historyIndex 333 incr historyIndex $n 334 if { $historyIndex >= [llength $history] } { 335 set historyIndex [expr {[llength $history] -1}] 336 } 337 if { $historyIndex < 0 } { set historyIndex 0} 338 if { "[lindex $history $historyIndex]" != ""} { 339 OpenMathGetWindow $win [lindex $history $historyIndex] 340 oset $win historyIndex $historyIndex 341 } 342} 343 344proc toLocalFilename { url } { 345 set type [assoc type $url] 346 switch -- $type { 347 http { 348 return [assoc filename $url] 349 } 350 file { 351 return [file join / [assoc dirname $url] [assoc filename $url] ] 352 353 } 354 default "unknown type: $type" 355 } 356 357} 358 359proc OpenMathGetWindow { commandPanel win } { 360 if { "[winfo parent [oget $commandPanel textwin]]" != "$win" } { 361 catch { pack forget [winfo parent [oget $commandPanel textwin]] } 362 pack $win -expand 1 -fill both 363 # pack $win 364 oset $commandPanel textwin $win.text 365 oset $commandPanel location [oget $win location] 366 set tem [toLocalFilename [decodeURL [oget $win location]]] 367 oset $commandPanel savefilename [file root $tem].txt 368 } 369} 370 371proc getw { s } { 372 eval pack forget [winfo children . ] ; pack $s 373} 374 375proc try1 { file } { 376 global ccc 377 eval pack forget [winfo children . ] 378 mkOpenMath [set w .t[incr ccc]] 379 uplevel "#0" source $file 380} 381 382proc filesplit { x } { 383 set l [split $x /] 384 set n [llength $l ] 385 set dir [lrange $l 0 [expr {$n - 2}]] 386 set file [lindex $l [expr {$n - 1}]] 387 return [list [join $dir /] $file] 388} 389 390 391 392proc decodeURL { name } { 393 set server "" 394 if { [regexp {([^#]*)#(.*)$} $name junk name anchor] } { 395 lappend answer anchor $anchor 396 # puts "answer=$answer" 397 } 398 399 400 if { [regexp {^([a-z]+)[(]?([0-9]*)[)]?:/(.+)$} $name all type port path ] } { 401 lappend answer type $type 402 } else { 403 set path $name ; set type "" 404 } 405 406 set path [removeDotDot $path] 407 #puts "path=$path" 408 desetq "dirname filename" [filesplit $path] 409 #puts "dirname=$dirname,path=$path,filename=$filename" 410 set po [assoc $type {http 80 nmtp 4443} ] 411 if { "$po" != "" } { 412 if { "$port" == "" } {set port $po } 413 414 if { [regexp {^/([^/:]*)(:([0-9]+))?(.*)$} $dirname all server \ 415 jun po dirname] } { 416 # puts "hi ther,server=$server" 417 if { "$po" != ""} {set port $po} 418 if { "$dirname" == "" } {set dirname / } 419 } elseif { "$server" == "" } { 420 set server $filename 421 set dirname / 422 set filename {} 423 } 424 lappend answer port $port server $server 425 } 426 lappend answer dirname $dirname filename $filename 427 return $answer 428} 429 430proc removeDotDot { path } { 431 while { [regsub {/[^/]+/[.][.](/|$)} $path "\\1" path] } {list} 432 return $path 433} 434 435proc appendSeparate { var before item separator } { 436 if { "$item" != "" } { 437 uplevel 1 append $var $before $item $separator 438 } 439} 440 441proc dirnamePlusFilename { lis } { 442 return [string trimright [assoc dirname $lis ""] /]/[assoc filename $lis ""] 443} 444proc encodeURL { lis } { 445 set type [assoc type $lis ""] 446 switch -- $type { 447 nmtp { 448 if { [ set port [assoc port $lis 4443]] != 4443 } { 449 append type "($port)" 450 } 451 appendSeparate ans "" $type ://[assoc server $lis ""] 452 append ans [dirnamePlusFilename $lis] 453 appendSeparate ans "#" [assoc anchor $lis ""] "" 454 } 455 http { 456 if { [ set port [assoc port $lis 80]] != 80 } { 457 append type "($port)" 458 } 459 appendSeparate ans "" $type ://[assoc server $lis ""] 460 append ans [dirnamePlusFilename $lis] 461 #appendSeparate ans "" [assoc dirname $lis ""] 462 #appendSeparate ans "/" [assoc filename $lis ""] "" 463 appendSeparate ans "#" [assoc anchor $lis ""] "" 464 } 465 file { 466 appendSeparate ans "" $type :/ 467 append ans [dirnamePlusFilename $lis] 468 # appendSeparate ans "" [assoc dirname $lis ""] "/" 469 # appendSeparate ans "" [assoc filename $lis ""] "" 470 appendSeparate ans "#" [assoc anchor $lis ""] "" 471 } 472 default "error unsupported url type: $type" 473 } 474 return $ans 475} 476 477proc resolveURL { name current {post ""} } { 478 set decode [decodeURL $name] 479 #puts "name=$name,current=$current" 480 set ans "" 481 set relative 0 482 if { "[assoc type $decode {} ]" == "" } {set relative 1} 483 if { $relative == 0 } { 484 set ans $decode 485 } else { 486 foreach {x y } $current { 487 switch -- $x { 488 dirname { 489 set ndir [assoc dirname $decode ""] 490 set cdir [assoc dirname $current ""] 491 if { [string match /* $ndir] } { 492 set new $ndir 493 } elseif { "$ndir" != "" } { 494 if { "$cdir" != "" } { 495 set new [string trimright $cdir /]/$ndir 496 } else { 497 set new $ndir 498 } 499 } else { 500 set new $cdir 501 } 502 lappend ans dirname [removeDotDot $new] 503 } 504 filename { 505 if { "[assoc filename $decode]" == "" && "[assoc anchor $decode]" != "" } { 506 lappend ans $x $y 507 } 508 } 509 post { 510 list 511 } 512 default { 513 lappend ans $x [assoc $x $decode $y] 514 } 515 } 516 } 517 foreach { key val } $decode { 518 if { "[assoc $key $ans --none--]" == "--none--" } { 519 lappend ans $key $val 520 } 521 } 522 523 524 } 525 if { "$post" != "" } { 526 set ans [putassoc post $ans $post] 527 } 528 return $ans 529} 530 531proc getURLrequest { path server port types {post ""} {meth ""} } { 532 global maxima_priv 533 534 if { "$meth" != "" } { 535 set method $meth 536 } else { 537 set method GET 538 if { "$post" != "" } {set method POST} 539 } 540 541 #puts "getURLrequest $path $server $port [list $types]" 542 foreach {v handler} $maxima_priv(urlHandlers) { 543 lappend types $v, 544 } 545 546 set ans "$method $path HTTP/1.0\nConnection: Keep-Alive\nUser-agent: netmath\nHost: $server:$port\nAccept: $types\n" 547 if { "$post" != "" } { 548 # append ans "Content-length: [string length $post]\n\n$post" 549 append ans "Content-type: application/x-www-form-urlencoded\nContent-length: [string length $post]\n\n$post" 550 } 551 552 return $ans 553 554} 555 556proc canonicalizeContentType { type } { 557 regexp -nocase {([---a-zA-Z]+)/([---a-zA-Z]+)} $type type 558 return [string tolower $type] 559} 560 561proc getURL { resolved type {mimeheader ""} {post ""} } { 562 global maxima_priv 563 set res $resolved 564 565 set ans "" 566 set method "" 567 if { "$mimeheader" != ""} { 568 uplevel 1 set $mimeheader \[list\] 569 } 570 uplevel 1 set $type "unknown" 571 572 573 #puts "getting $resolved,post=<$post>" 574 switch [assoc type $res] { 575 http { 576 #mike FIXME: replace with http get 577 # puts $res 578 # puts "socket [assoc server $res] [assoc port $res 80]" 579 if { [info exists maxima_priv(proxy,http) ] } { 580 set sock [eval socket $maxima_priv(proxy,http)] 581 # puts "opening proxy request socket $maxima_priv(proxy,http)" 582 } else { 583 set server [assoc server $res] 584 set port [assoc port $res 80] 585 #mike FIXME - use async sockets and dns 586 if {[catch {socket $server $port} sock]} { 587 global errorInfo 588 tide_failure [M [mc "Error connecting to %s on %s\n%s"] \ 589 $server $port $sock] 590 return 591 } 592 } 593 594 fconfigure $sock -blocking 0 595 ##DO NOT DELETE THE FOLLOWING !!!!!puts!!!!!!!! 596 #puts request=[getURLrequest [dirnamePlusFilename $res] [assoc server $res] [assoc port $res] image/gif $post] 597 # set path [dirnamePlusFilename $res] 598 set path [encodeURL $res] 599 set server [assoc server $res] 600 set port [assoc port $res] 601 puts $sock [getURLrequest $path $server $port image/gif $post] 602 if { "$post" == "" } { 603 oset $sock cachename "http://$server:$port$path" 604 } else { 605 oset $sock cachename "" 606 } 607 flush $sock 608 if { [readAllData $sock -tovar maxima_priv(url_result) \ 609 -translation binary -mimeheader maxima_priv(mimeheader) \ 610 -timeout 120000 -chunksize 2024] > 0 } { 611 612 #puts "length=[string length $maxima_priv(url_result)]" 613 # flush stdout 614 615 set contentType [canonicalizeContentType [assoc content-type $maxima_priv(mimeheader) text/plain]] 616 uplevel 1 set $type [list $contentType] 617 if { "$mimeheader" != "" } { 618 uplevel 1 set $mimeheader \[ uplevel "#0" set maxima_priv(mimeheader) \] 619 } 620 set ans $maxima_priv(url_result) 621 unset maxima_priv(url_result) 622 return $ans 623 } else { 624 return "had error" 625 } 626 } 627 file { 628 set name [toLocalFilename $res] 629 set fi [open $name r] 630 set answer [read $fi] 631 if { [regexp -nocase {[.]html?$} $name ] || [regexp -nocase "^(\[ \n\t\r\])*<html>" $answer] } { 632 set contentType text/html 633 } elseif { [regexp {[.]gif([^/]*)$} $name ] } { 634 set contentType image/gif 635 } elseif { [regexp {[.]png([^/]*)$} $name ] } { 636 set contentType image/png 637 } elseif { [regexp {[.]jpe?g([^/]*)$} $name ] } { 638 set contentType image/jpeg 639 } else { 640 set contentType text/plain 641 } 642 uplevel 1 set $type $contentType 643 644 close $fi 645 return $answer 646 } 647 default { 648 #mike dirpath? 649 error [concat [mc "not supported"] "[lindex $res 0]"] 650 } 651 } 652} 653 654 655 656 657proc getImage { resolved width height} { 658 global maxima_priv 659 set res $resolved 660 #puts [list getImage [list $resolved] $width $height] 661 set ans "" 662 catch { 663 if { "" != "[image type $maxima_priv(image,$res,$width,$height)]" } { 664 set ans $maxima_priv(image,$res,$width,$height) 665 } 666 } 667 if { "$ans" != "" } { return $ans } 668 669 set image [image create photo -width $width -height $height] 670 after 10 backgroundGetImage $image [list $resolved] $width $height 671 set maxima_priv(image,$res,$width,$height) $image 672 return $image 673} 674 675 676proc backgroundGetImage { image res width height } { 677 global maxima_priv 678 #puts [list backgroundGetImage $image $res $width $height ] 679 if { [catch { backgroundGetImage1 $image $res $width $height } err ] } { 680 set im ::img::brokenimage 681 $image config -width [image width $im] -height [image height $im] 682 $image copy $im 683 } 684} 685 686 687proc backgroundGetImage1 { image res width height } { 688 #puts "resolved=$res" 689 global maxima_priv 690 #puts [list backgroundGetImage $image $res $width $height] 691 switch [assoc type $res] { 692 http { 693 set server [assoc server $res] 694 set port [assoc port $res 80] 695 if { [info exists maxima_priv(proxy,http) ] } { 696 set s [eval socket $maxima_priv(proxy,http)] 697 # puts "opening proxy request socket $maxima_priv(proxy,http)" 698 } else { 699 set s [socket [assoc server $res] [assoc port $res 80]] 700 } 701 fconfigure $s -blocking 0 702 ##DO NOT DELETE THE FOLLOWING !!!!!puts!!!!!!!! 703 puts $s [getURLrequest [encodeURL $res] \ 704 $server $port {image/gif image/png image/jpeg image/x-bitmap}] 705 flush $s 706 707 708 if { [regexp -nocase $maxima_priv(imgregexp) [assoc filename $res] mm extension] } { 709 fconfigure $s -translation binary 710 set tmp xxtmp[incr maxima_priv(imagecounter)].$extension 711 712 if { [info exists maxima_priv(inbrowser)] || [catch {set out [open $tmp w] } ] } { 713 # if have binary.. 714 if { "[info command binary]" != "binary" } { 715 error [mc "need version of tk with 'binary' command for images"]} 716 #puts "hi binary" ; flush stdout 717 if { [readAllData $s -tovar \ 718 maxima_priv($s,url_result) -mimeheader \ 719 maxima_priv($s,mimeheader) 720 ] > 0 && [string match *$extension [assoc content-type $maxima_priv($s,mimeheader)]] } { 721 set ans $image 722 $image configure -data [tobase64 $maxima_priv($s,url_result)] 723 724 unset maxima_priv($s,mimeheader) 725 unset maxima_priv($s,url_result) 726 727 } else { 728 error [mc "could not get image"] 729 } 730 } else { 731 fconfigure $out -translation binary -blocking 0 732 if { [readAllData $s -tochannel $out \ 733 -translation binary \ 734 -mimeheader \ 735 maxima_priv($s,mimeheader) -timeout 15000 -chunksize 2024 ] > 0 } { 736 set ans $image 737 $image config -file \ 738 $tmp 739 unset maxima_priv($s,mimeheader) 740 } 741 742 743 744 # all the below just to try to remove the file.. 745 # depending on versions and in environments.. 746 747 } 748 } 749 } 750 file { 751 $image config -file [toLocalFilename $res] 752 set ans $image 753 # puts "$image config -file [toLocalFilename $res]" 754 #set ans [image create photo -file [toLocalFilename $res]] 755 756 757 } 758 default { error [mc "unknown type of image"] } 759 } 760 ## if we opened an out channel try hard to remove the tmp file. 761 if { [info exists out] && 762 [catch { file delete $tmp } ] && [catch { rm $tmp }] 763 && [catch { exec rm $tmp }] } { 764 puts [concat [mc "cant remove tmp file"] "$tmp"] 765 } 766 if { "$ans" == "" } { 767 error [concat [mc "Unable to open an image for"] "[encodeURL $res]"] 768 } 769 770} 771 772 773# 774#----------------------------------------------------------------- 775# 776# readData -- read data from S, storing the result 777# in maxima_priv($s,url_result). It times out after TIMEOUT without any data coming. 778# it can be aborted by setting set maxima_priv($s,done) -1 779# 780# 781# Results: -1 on failure and 1 on success. 782# 783# Side Effects: it initially empties maxima_priv($s,url_result) and then 784# adds data to it as read. maxima_priv($s,done) is initialized to 0 785# 786#---------------------------------------------------------------- 787# 788proc readData { s { timeout 10000 }} { 789 global maxima_priv 790 791 after $timeout "set maxima_priv($s,done) -1" 792 fconfigure $s -blocking 0 793 set maxima_priv($s,done) 0 794 set maxima_priv($s,url_result) "" 795 796 #mike FIXME: this is a wrong use of after cancel 797 fileevent $s readable \ 798 "after cancel {set maxima_priv($s,done) -1} ; after $timeout {set maxima_priv($s,done) -1} ; set da \[read $s 8000] ; append maxima_priv($s,url_result) \$da; if { \[string length \$da] < 8000 && \[eof $s] } {after cancel {set maxima_priv($s,done) -1} ; set maxima_priv($s,done) 1; fileevent $s readable {} ; }" 799 myVwait maxima_priv($s,done) 800 catch { close $s } 801 #mike FIXME: this is a wrong use of after cancel 802 after cancel "set maxima_priv($s,done) -1" 803 return $maxima_priv($s,done) 804} 805 806 807 808proc doRead { sock } { 809 global maxima_priv 810 811 #puts reading; flush stdout; 812 set tem [read $sock] 813 append maxima_priv(url_result) $tem 814 # puts read:<$tem> 815 # flush stdout 816 if { [eof $sock] } { 817 set maxima_priv(done) 1 818 close $sock 819 } 820} 821 822proc tempName { name extension } { 823 set count [pid] 824 while { [file exists $name[incr count].$extension] } { list } 825 return $name$count.$extension 826} 827 828proc ws_outputToTemp { string file ext encoding } { 829 upvar 1 $string result 830 set tmp [tempName $file $ext ] 831 set open $tmp 832 if { [lsearch {x-gzip x-compress} $encoding] >= 0 } { 833 # FIXME: Unix only 834 lappend dogzip |gzip -dc > $open ; set open $dogzip 835 } 836 set fi [open $open w] 837 fconfigure $fi -translation binary 838 puts -nonewline $fi $result 839 flush $fi 840 close $fi 841 return $tmp 842} 843 844proc OpenMathOpenUrl { name args} { 845 global maxima_priv 846 847 # Removes any white spaces at the end of the Url given 848 set name [string trimright $name] 849 850 gui status [concat [mc "Opening"] "$name"] 851 852 #puts "OpenMathOpenUrl $name $args " 853 set history "" ; set historyIndex -1 ; set currentUrl "" 854 set prevwindow "" 855 set commandPanel [assoc -commandpanel $args ] 856 if { "$commandPanel" == "" } { 857 linkLocal . omPanel 858 if { [info exists omPanel] } { 859 set commandPanel $omPanel 860 } 861 } 862 set toplevel [assoc -toplevel $args ""] 863 if { "$toplevel" == "" } {set toplevel ".browser"} 864 if { "$toplevel" == "." } {set toplevel ""} 865 set reload [assoc -reload $args 0] 866 set post [assoc -post $args ""] 867 #puts "post=$post" 868 if { [winfo exists $commandPanel ] } { 869 makeLocal $commandPanel history historyIndex textwin 870# set toplevel [winfo paren $commandPanel] 871# if { "$toplevel" == "." } {set toplevel ""} 872 # eval pack forget [winfo parent $textwin ] 873 set prevwin [winfo parent $textwin] 874 set currentUrl [oget $textwin currentUrl] 875 catch { set currentUrl [decodeURL [oget $textwin baseurl]] } 876 877 if { $reload == 0} { 878 879 set new [resolveURL $name $currentUrl $post] 880 if { [set anchor [assoc anchor $new]] != "" } { 881 set new [delassoc anchor $new] 882 } 883 set ii -1 884 foreach v $history { 885 incr ii 886 if { "[delassoc post $new]" == "[delassoc post [oget $v.text currentUrl]]" } { 887 # puts "new=$new\nold=[oget $v.text currentUrl]" 888 } 889 if { "$new" == "[delassoc anchor [oget $v.text currentUrl]]" } { 890 OpenMathMoveHistory $commandPanel [expr {$ii - $historyIndex }] 891 if { "$anchor" != "" } { 892 update 893 catch { $v.text yview anchor:$anchor } 894 } 895 896 # OpenMathGetWindow $commandPanel $v 897 # pushHistory $commandPanel $v 898 return 899 } 900 901 } 902 } else { 903 # reload=1 904 list 905 } 906 } 907 set count 5 908 while { [incr count -1] > 0 } { 909 set new [resolveURL $name $currentUrl $post] 910 set result [getURL $new contentType mimeheader $post] 911 if { [set tem [assoc location $mimeheader]] == "" } { 912 break 913 } 914 set name $tem 915 } 916 917 #puts "contentType defined:[info exists contentType]" 918 set handler [assoc $contentType $maxima_priv(urlHandlers)] 919 if { "$handler" != "netmath" && "$handler" != "" } { 920 set tmp [ws_outputToTemp result netmath ps "[assoc content-encoding $mimeheader]"] 921 # to do fix this for windows ##### 922 exec sh -c "[format $handler $tmp] ; rm -f $tmp" & 923 return 924 } 925 #puts contentType=$contentType 926 927 #puts "got [string length $result] bytes" 928 #puts ", result= [string range $result 0 70] .." 929 930 if { [catch { set baseprogram [oget $textwin baseprogram] }] } { 931 set baseprogram [decodeURL [getBaseprogram]] 932 } 933 # puts "using $baseprogram" 934 if { $reload } { forgetCurrent $commandPanel } 935 936 #puts "maxima_priv(counter)=$maxima_priv(counter)" 937 938 set win [mkOpenMath [set w $toplevel.t[incr maxima_priv(counter)]] ] 939 940 #puts "maxima_priv(counter)=$maxima_priv(counter)" 941 942 makeLocal $w commandPanel 943 #puts "resolveURL $name $currentUrl" 944 945 if { [set anchor [assoc anchor $new]] != "" } { 946 set new [delassoc anchor $new] 947 } 948 if { "[assoc filename $new]" == "" } { 949 set new [putassoc filename $new index.html] 950 } 951 # puts "...> $new" 952 oset $w.text currentUrl $new 953 oset $commandPanel location [encodeURL $new] 954 oset $commandPanel textwin $win 955 oset $w location [encodeURL $new] 956 # puts "new=$new" 957 oset $commandPanel savefilename [file root [toLocalFilename $new]].txt 958 959 set tem [assoc filename $new ""] 960 #puts $contentType 961 if { "$contentType" != "text/html" } { 962 if { [string match "image/*" $contentType] } { 963 set im [image create photo -data $result] 964 $win image create 0.0 -image $im 965 set err 0 966 } else { 967 set err [catch { $win insert 0.0 $result } ] 968 } 969 } elseif { 1 } { 970 xHMinit_win $win 971 xHMset_state $win url [encodeURL $new] 972 oset $win baseprogram $baseprogram 973 # puts win=$win,lengres=[string length $result] 974 set errmsg1 "" 975 set err 0 976 global debugParse 977 if { $debugParse } { 978 xHMparse_html $result "xHMrender $win" 979 set err 0 980 } else { 981 set err [catch { 982 xHMparse_html $result "xHMrender $win" 983 } errmsg1 ] 984 } 985 catch { 986 if { "$anchor" != "" } { 987 update 988 $win yview anchor:$anchor 989 } 990 } 991 992 # foreach v {Tresult Teval} { $win tag raise $v} 993 994 995 } else { 996 ###Never get here.. must change to make be the rich text case.. 997 # drop comment lines 998 regsub -all "(^|\n)#\[^\n\]*\n" $result \n result ; 999 #puts input=$result 1000 1001 # note netscape would just truncate the history 1002 # at historyIndex, and start to grow it there, 1003 # losing the record of all files you have visited after.. 1004 # maybe we should do this. 1005 #puts "history=$history" 1006 set err [catch { insertRichText $win insert $result }] 1007 } 1008 if { $err == 0 } { 1009 pushHistory $commandPanel $w 1010 } 1011 if { $err } { 1012 global errorInfo 1013 #puts "======begin======" 1014 #puts $result 1015 #puts "======end========" 1016 puts "$errmsg1" 1017 error [concat [mc "unable to evaluate"] "[encodeURL $new]\n$errmsg1\n$errorInfo"] 1018 } 1019 1020} 1021 1022 1023proc pushHistory { commandPanel win } { 1024 global [oarray $commandPanel] 1025 makeLocal $commandPanel history historyIndex 1026 1027 if { [llength $history] == 0 } { 1028 oset $commandPanel historyIndex -1 1029 } 1030 if { "[lindex $history $historyIndex ]" != "$win" } { 1031 oset $commandPanel history [linsert $history [incr [oloc $commandPanel historyIndex]] $win] 1032 } 1033} 1034 1035 1036# 1037#----------------------------------------------------------------- 1038# 1039# omScrollPage -- scroll the page by N pages, keeping the insert 1040# cursor visible. 1041# 1042# Results: none 1043# 1044# Side Effects: page scrolls 1045# 1046#---------------------------------------------------------------- 1047# 1048proc omScrollPage { win n } { 1049 tkTextScrollPages $win $n 1050 set bbox [$win bbox insert] 1051 if { "" == "$bbox" } { 1052 if { $n > 0 } { 1053 $win mark set insert @0,0 1054 } else {$win mark set insert @0,[$win cget -height]} 1055 } 1056} 1057 1058proc addTagSameRange { win oldtag newtag index } { 1059 if { [lsearch [$win tag names $index] $oldtag ] >= 0 } { 1060 set this [$win tag prevrange $oldtag $index+1char] 1061 if { "$this" != "" && [$win compare $index < [lindex $this 1]] } { 1062 $win tag remove $newtag 0.0 end 1063 $win tag add $newtag [lindex $this 0] [lindex $this 1] 1064 $win tag raise $newtag 1065 } 1066 } 1067} 1068 1069proc getBaseprogram { } { 1070 global maxima_default 1071 return [lindex $maxima_default(defaultservers) 0] 1072} 1073 1074#mike FIXME: This is an abomination 1075proc fileBaseprogram { textwin parent x y } { 1076 set e $textwin.e 1077 catch { destroy $e } 1078 set x [expr {[winfo rootx $parent] + $x +30 - [winfo rootx $textwin]} ] 1079 set x 30 1080 set y [expr {[winfo rooty $parent] + $y - [winfo rooty $textwin]} ] 1081 global xHMpriv 1082 set xHMpriv(baseprogram) [encodeURL [oget $textwin baseprogram]] 1083 entry $e -width 40 -textvariable xHMpriv(baseprogram) 1084 place $e -in $textwin -x $x -y $y 1085 raise $e 1086 set com "destroy $e ; oset $textwin baseprogram \[decodeURL \$xHMpriv(baseprogram)] " 1087 bind $e <Leave> $com 1088 bind $e <Return> $com 1089 1090} 1091 1092proc fontDialog { top } { 1093 global maxima_default 1094 1095 set font [xHMmapFont font:propor:normal:r:3] 1096 if {[winfo exists $top]} {catch { destroy $top }} 1097 1098 toplevel $top 1099 wm iconify $top 1100 1101 set win $top.text 1102 text $win -font [list [font config $font -family] [font config $font -size]] -height 20 1103 wm deiconify $top 1104 1105 foreach fam {propor fixed} { 1106 set lis "" 1107 set i 0 1108 while { $i <= 8 } { 1109 lappend lis [expr {$i - 3}] 1110 incr i 1111 } 1112 if { "$fam" == "fixed" } { set fixed 1 } else { 1113 set fixed 0 1114 } 1115 mkLabelListBoxChooser $win.size$fam "list $lis" maxima_default($fam,adjust) 1116 mkLabelListBoxChooser $win.family$fam "getFontFamilies $fixed " maxima_default($fam) 1117 set fo [xHMmapFont "font:$fam:normal:r:3"] 1118 catch { set maxima_default($fam) [assoc -family [font actual $fo]]} 1119 } 1120 $win insert insert [mc "Font Settings\nThe proportional font is "] 1121 $win window create insert -window $win.familypropor 1122 $win insert insert [mc "with a size adjustment of "] 1123 $win window create insert -window $win.sizepropor 1124 $win insert insert [mc "\nThe fixed font is "] 1125 $win window create insert -window $win.familyfixed 1126 $win insert insert [mc "with a size adjustment of "] 1127 $win window create insert -window $win.sizefixed 1128 $win insert insert "\n" 1129 $win insert insert [mc "Default nmtp servers "] 1130 global _servers 1131 set _servers $maxima_default(defaultservers) 1132 entry $win.entry -textvariable _servers -width 40 1133 $win window create insert -window $win.entry 1134 $win insert insert "\n\n" 1135 global maxima_priv 1136 $win insert insert [mc "http Proxy host and port:"] 1137 entry $win.entryproxy -width 40 1138 catch { $win.entryproxy insert 0 $maxima_priv(proxy,http) } 1139 $win window create insert -window $win.entryproxy 1140 $win insert insert [mc "\nIf you are behind a firewall enter the name of your http proxy host and port,\n eg: `foo.ma.utexas.edu 3128', otherwise leave this blank"] 1141 1142 set men [tk_optionMenu $win.plottype maxima_default(plotwindow) embedded separate multiple ] 1143 $win insert insert [mc "\nShould plot windows be "] 1144 $win window create insert -window $win.plottype 1145 $win insert insert "?" 1146 1147 1148 $win insert insert "\n\n\n" 1149 $win insert insert [mc " Apply and Quit "] "bye raised" 1150 $win insert insert " " 1151 $win insert insert [mc " Apply "] "click raised" 1152 $win insert insert " " 1153 $win insert insert [mc " Cancel "] "cancel raised" 1154 proc _FontDialogApply { win } { 1155 global maxima_default _servers maxima_priv 1156 set maxima_default(defaultservers) $_servers 1157 catch {xHMresetFonts .} 1158 if { [llength [$win.entryproxy get]] == 2 } { 1159 set maxima_priv(proxy,http) [$win.entryproxy get] 1160 } 1161 } 1162 $win tag bind click <1> "_FontDialogApply $win" 1163 $win tag bind bye <1> "_FontDialogApply $win ; destroy $top" 1164 $win tag bind cancel <1> "destroy $top" 1165 $win tag configure raised -relief raised -borderwidth 2 1166 $win insert insert " " 1167 $win insert insert [mc " Save Preferences "] "save raised" 1168 $win tag bind save <1> "_FontDialogApply $win ; savePreferences" 1169 1170 pack $win 1171 # place $win -in [oget [omPanel .] textwin] -x 10 -y 10 1172} 1173proc savePreferences {} { 1174 global maxima_default maxima_priv 1175 1176 # Save current console size in maxima_default 1177 set console [lindex [array get maxima_priv cConsoleText] end] 1178 set maxima_default(iConsoleWidth) [textWindowWidth $console] 1179 set maxima_default(iConsoleHeight) [textWindowHeight $console] 1180 1181 if {[catch {open "~/.xmaximarc" w} fi]} {return} 1182 1183 puts $fi "array set maxima_default {" 1184 foreach {k v} [array get maxima_default *] { 1185 lappend all [list $k $v] 1186 } 1187 set all [lsort $all] 1188 foreach v $all { puts $fi $v } 1189 puts $fi "}" 1190 1191 #mike FIXME: make this a _default 1192 if { [info exists maxima_priv(proxy,http)] && [llength $maxima_priv(proxy,http)] == 2 } { 1193 puts $fi [list array set maxima_priv [array get maxima_priv proxy,http] 1194 ] 1195 } 1196 close $fi 1197} 1198 1199 1200 1201 1202 1203 1204# 1205#----------------------------------------------------------------- 1206# 1207# mkLabelListBoxChooser -- creates a button called WIN with textvariable 1208# $TEXTVAR. When clicked on the WIN, brings down 1209# a list of items, and clicking on one of them selects that item. and 1210# resets $TEXTVAR 1211# 1212# Results: none 1213# 1214# Side Effects: the TEXTVAR value is changed, and so consequently the label. 1215# 1216#---------------------------------------------------------------- 1217# 1218proc mkLabelListBoxChooser { win items textvar} { 1219 button $win -textvariable $textvar -command "listBoxChoose $win [list $items] $textvar" 1220} 1221 1222proc listBoxChoose { win items textvar } { 1223 global maxima_default 1224 1225 set whei [winfo height $win] 1226 set items [eval $items] 1227 set hei [llength $items] 1228 set fr ${win}frame 1229 frame ${win}frame 1230 set list $fr.list 1231 set scroll $fr.scroll 1232 scrollbar $scroll -command "$list yview" 1233 listbox $list -yscroll "$scroll set" -setgrid 1 -height 8 1234 pack $scroll -side right -fill y 1235 pack $list -side left -expand 1 -fill both 1236 set wid 0 1237 foreach v $items { 1238 set xx [string length $v] ; 1239 set wid [expr {($xx > $wid ? $xx : $wid)}] 1240 } 1241 eval [concat $list insert 0 $items] 1242 catch { $list selection set [lsearch $items [set $textvar]] } 1243 bind $list <1> "set $textvar \[$list get \[$list nearest %y\]\]; destroy $fr" 1244 place $fr -in $win -x 0 -y 0 -anchor n 1245} 1246 1247 1248proc quoteForRegexp { s } { 1249 regsub -all {[\]\[$+()\\.?*]} $s {\\\0} ans 1250 return $ans 1251} 1252 1253 1254## endsource browser.tcl 1255