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