1#!/opt/tcl/bin/wish
2#----------------------------------------------------------------------------
3#   Copyright (c) 1999 - 2000  Jochen C. Loewer (loewerj@hotmail.com)
4#----------------------------------------------------------------------------
5#
6#   A XML/DOM/XPath evaluator/viewer... featuring the Tk text widget.
7#
8#
9#   The contents of this file are subject to the Mozilla Public License
10#   Version 1.1 (the "License"); you may not use this file except in
11#   compliance with the License. You may obtain a copy of the License at
12#   http://www.mozilla.org/MPL/
13#
14#   Software distributed under the License is distributed on an "AS IS"
15#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
16#   License for the specific language governing rights and limitations
17#   under the License.
18#
19#   The Original Code is tDOM.
20#
21#   The Initial Developer of the Original Code is Jochen Loewer
22#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
23#   Jochen Loewer. All Rights Reserved. 
24#
25#   Contributor(s):
26#
27#
28#
29#   $Log: xe,v $
30#   Revision 1.1.1.1  2002/02/22 01:05:35  rolf
31#   tDOM0.7test with Jochens first set of patches
32#
33#
34#
35#
36#   written by Jochen Loewer
37#   December, 1999
38#
39#
40#
41#   Contains emacsbinds.tcl:
42#
43#     Copyright 1993 by Paul Raines (raines@bohr.physics.upenn.edu)
44#
45#     Permission to use, copy, modify, and distribute this
46#     software and its documentation for any purpose and without
47#     fee is hereby granted, provided that the above copyright
48#     notice appear in all copies.  The University of Pennsylvania
49#     makes no representations about the suitability of this
50#     software for any purpose.  It is provided "as is" without
51#     express or implied warranty.
52#
53#----------------------------------------------------------------------------
54
55
56
57# ! All that needs some code cleanup! The code should be more readable!
58# ! Currently just use xe!
59
60
61
62#----------------------------------------------------------------------------
63#   Package/Includes
64#----------------------------------------------------------------------------
65package require http 2
66
67if {[catch { load ../unix/tdom0.6[info shared] }]} {
68     catch { load ../win/tdom0.6.dll           }
69}
70catch { package require tdom 0.6            }
71catch { source ../lib/tdom.tcl              }
72
73
74
75
76#----------------------------------------------------------------------------
77#   Globals
78#----------------------------------------------------------------------------
79set HttpProxyHost ""
80set HttpProxyPort ""
81
82
83
84
85
86#----------------------------------------------------------------------------
87#   $Header: /usr/local/pubcvs/tdom/xe/xe,v 1.1.1.1 2002/02/22 01:05:35 rolf Exp $
88#
89# 
90#   p a n e   implements the new widget 'pane' to realize a
91#             resizing of the space between two sub windows
92#             in fixed size outer window, the pane window.
93#             Uses plain tcl/tk code
94#
95#
96#   $Log: xe,v $
97#   Revision 1.1.1.1  2002/02/22 01:05:35  rolf
98#   tDOM0.7test with Jochens first set of patches
99#
100#   Revision 1.1  96/12/06  15:59:14  15:59:14  jolo (#Jochen Loewer)
101#   Initial revision
102#   
103#
104#
105#   written by Jochen Loewer
106#   July, 1996
107#
108#----------------------------------------------------------------------------
109
110
111
112#----------------------------------------------------------------------pane--
113proc pane { path type width height } {
114    global _pane_Priv
115
116    set _pane_Priv(moving) no
117
118    frame $path  -height $height -width $width -relief flat
119    frame $path.separator -height 7 -relief flat
120    frame $path.separator.line -height 4 -relief ridge -borderwidth 1
121    frame $path.separator.handle -width 8 -height 8 -relief raised -borderwidth 1
122    place $path.separator.line -anchor nw -x 0  -rely 0.4 -relwidth 1.0 
123    place $path.separator.handle -anchor center -relx 1.0 -rely 0.5 -x -8
124
125
126    place $path.separator -anchor nw -x 0 -y 0 -relwidth 1.0 
127
128    $path.separator.handle config -cursor sb_v_double_arrow
129    
130    set _pane_Priv(maxy)   $height
131    set _pane_Priv(moving) no
132}
133
134
135#----------------------------------------------------------------------pane--
136proc pane_place { path type ratio win1 win2 } {
137    global _pane_Priv
138
139    set _pane_Priv(moving) no
140    update
141    scan  [winfo geometry $path]  "%dx%d+%d+%d"   w h x y
142    set middley [expr $h*$ratio]
143    place $path.separator -anchor nw -x 0 -y $middley -relwidth 1.0 
144    update
145    pane_partionize $path $win1 $win2
146 
147    $path.separator.handle config -cursor sb_v_double_arrow
148    
149    bind $path.separator.handle <ButtonPress-1>   "pane_down    $path"
150    bind $path.separator.handle <B1-Motion>       "pane_motion  $path"
151    bind $path.separator.handle <ButtonRelease-1> "pane_release $path $win1 $win2"
152
153    bind $path  <Configure>     "pane_resize $path $win1 $win2 %w %h"
154
155    set _pane_Priv(maxy)   $h
156    set _pane_Priv(moving) no
157}
158
159#-----------------------------------------------------------------pane_down--
160proc pane_down { pane } {
161    global _pane_Priv
162
163    $pane.separator.handle configure -relief sunken
164    raise $pane.separator
165    set _pane_Priv(rooty) [winfo pointery $pane]
166
167    scan  [winfo geometry $pane]  "%dx%d+%d+%d"   w h x y
168    set _pane_Priv(maxy)  $h
169
170    scan  [winfo geometry $pane.separator]  "%dx%d+%d+%d"   w h x y
171    set _pane_Priv(oldy)  $y 
172
173    set _pane_Priv(moving) yes    
174}
175
176
177#---------------------------------------------------------------pane_motion--
178proc pane_motion { pane } {
179    global _pane_Priv
180
181    set y [winfo pointery $pane]
182    set delta [expr $y-$_pane_Priv(rooty)]
183
184    set newy [expr $_pane_Priv(oldy)+$delta]
185    if { ($newy > 8) && ([expr $newy+16] <$_pane_Priv(maxy)) } {
186        place $pane.separator -anchor nw -x 0 -y $newy -relwidth 1.0 
187    }
188}
189
190
191#--------------------------------------------------------------pane_release--
192proc pane_partionize { pane win1 win2 } {
193
194    scan  [winfo geometry $pane.separator]  "%dx%d+%d+%d"   w h x y
195    place $win1 -anchor nw -x 0 -y 0 -relwidth 1.0 -height $y -relheight {}
196
197    set ywin2  [expr $y+$h]
198    scan  [winfo geometry $pane]  "%dx%d+%d+%d"   w h x y
199    set hwin2  [expr $h-$ywin2-1]   
200    place $win2 -anchor se -relx 1.0  -rely 1.0  -relwidth 1.0 -height $hwin2
201}
202
203
204#--------------------------------------------------------------pane_release--
205proc pane_release { pane win1 win2 } {
206    global _pane_Priv
207
208    $pane.separator.handle configure -relief raised
209   
210    pane_partionize $pane $win1 $win2
211    set _pane_Priv(moving)  no 
212}
213
214
215#---------------------------------------------------------------pane_resize--
216proc pane_resize { pane win1 win2 neww newh} {
217    global _pane_Priv
218    if { $_pane_Priv(moving) != "yes" } {
219
220        scan  [winfo geometry $pane.separator]    "%dx%d+%d+%d"   w h xp y
221        set newy [expr ($y*$newh)/$_pane_Priv(maxy)]
222        place $pane.separator -anchor nw -x 0 -y $newy -relwidth 1.0 
223        update
224        pane_partionize $pane $win1 $win2
225
226    }
227    set _pane_Priv(maxy)  $newh
228}
229
230
231############################################################################
232# include bindings.tk from TkMail (Thanks Paul!)
233############################################################################
234#
235# COPYRIGHT:
236#     Copyright 1993 by Paul Raines (raines@bohr.physics.upenn.edu)
237#
238#     Permission to use, copy, modify, and distribute this
239#     software and its documentation for any purpose and without
240#     fee is hereby granted, provided that the above copyright
241#     notice appear in all copies.  The University of Pennsylvania
242#     makes no representations about the suitability of this
243#     software for any purpose.  It is provided "as is" without
244#     express or implied warranty.
245#
246
247
248global bind_xnd btp
249
250# USER SETTINGS
251
252set btp(prevcmd) "begin-line"
253
254# maximum number of kills to save in ring
255set btp(maxkill) 10
256# maximum number of marks to save in ring
257set btp(maxmark) 10
258# syntax for letter not part of a "word"
259set btp(not-word) {[^a-zA-Z_0-9]}
260# procedure to use for errors
261set btp(error) error
262# procedure to use for beeping
263set btp(beep) ""
264# whether to bind Escape prefix commands also to the Meta modifier
265set btp(use-meta) 1
266# column at which to line wrap
267set btp(fillcol) 0
268# prefix for line wrapping (NOT REALLY WORKING YET)
269set btp(fillprefix) ""
270
271# PRIVATE SETTINGS
272
273set btp(lastkill) 0.0
274set btp(killring) ""
275set btp(killptr) 0
276set btp(killlen) 0
277set btp(arg) def
278
279proc tk_entryForwspace w {
280     set x [expr [$w index insert] - 1]
281     catch {$w delete $x}
282}
283
284# selection_if_any - return selection if it exists, else {}
285#   this is from kjx@comp.vuw.ac.nz (R. James Noble)
286proc selection_if_any {} {
287  if {[catch {selection get} s]} {return ""} {return $s}
288}
289
290proc bind_cleanup { w } {
291    global btp
292    catch {unset btp($w,markring)}
293}
294
295proc bt:current-line { w } {
296    return [lindex [split [$w index insert] .] 0]
297}
298
299proc bt:current-col { w } {
300    return [lindex [split [$w index insert] .] 1]
301}
302
303proc bt:move-line { w {num 1} } {
304    global btp
305    set btp(lastkill) 0.0
306    if {$btp(arg) != "def"} {
307	set num [expr $num*$btp(arg)]
308	set btp(arg) def
309    }
310    if {$btp(prevcmd) != "move-line"} {
311        set btp(goalcol) [lindex [split [$w index insert] .] 1]
312    }
313    if {$num > -1} {set num "+$num"}
314    $w tag remove sel 1.0 end
315    set ndx [$w index "insert $num line lineend"]
316    set goalndx [lindex [split $ndx .] 0].$btp(goalcol)
317    if {$btp(goalcol) < [lindex [split $ndx .] 1]} {
318        $w mark set insert $goalndx
319    } else {
320        $w mark set insert $ndx
321    }
322    $w yview -pickplace insert
323    set btp(prevcmd) move-line
324}
325
326proc bt:move-char { w {num 1} } {
327    global btp
328    set btp(lastkill) 0.0
329    if {$btp(arg) != "def"} {
330	set num [expr $num*$btp(arg)]
331	set btp(arg) def
332    }
333    if {$num > -1} {set num "+$num"}
334    $w tag remove sel 1.0 end
335    $w mark set insert "insert $num char"
336    $w yview -pickplace insert
337    set btp(prevcmd) "move-char"
338}
339
340proc bt:move-word {w {num 1}} {
341    global btp
342    set btp(lastkill) 0.0
343    $w tag remove sel 1.0 end
344    if {$btp(arg) != "def"} {
345	set num [expr $num*$btp(arg)]
346	set btp(arg) def
347    }
348    if {$num > 0} {
349        for {set i 0} {$i < $num } {incr i} {
350	    while {[regexp $btp(not-word) [$w get insert]]} {
351	        $w mark set insert insert+1c
352	    } 
353	    $w mark set insert {insert wordend}
354	}
355    } else {
356        for {set i 0} {$i > $num } {incr i -1} {
357	    $w mark set insert insert-1c
358	    while {[regexp $btp(not-word) [$w get insert]]} {
359	        $w mark set insert insert-1c
360	    } 
361	    $w mark set insert {insert wordstart}
362	}
363    }
364    $w yview -pickplace insert
365    set btp(prevcmd) "move-word"
366}
367
368proc bt:begin-line { w {num 0}} {
369    global btp
370    set btp(lastkill) 0.0
371    if {$btp(arg) != "def"} {
372	set num $btp(arg)
373	set btp(arg) def
374    }
375    if {$num != 0} {set num [expr $num-1]}
376    bt:move-line $w $num
377    $w mark set insert {insert linestart}
378    $w tag remove sel 1.0 end
379    $w yview -pickplace insert
380    set btp(prevcmd) "begin-line"
381}
382
383proc bt:end-line { w {num 0}} {
384    global btp
385    set btp(lastkill) 0.0
386    if {$btp(arg) != "def"} {
387	set num $btp(arg)
388	set btp(arg) def
389    }
390    if {$num != 0} {set num [expr $num-1]}
391    bt:move-line $w $num
392    $w mark set insert {insert lineend}
393    $w tag remove sel 1.0 end
394    $w yview -pickplace insert
395    set btp(prevcmd) end-line
396}
397
398proc bt:begin-buffer { w {num 0}} {
399    global btp
400    set btp(lastkill) 0.0
401    if {$btp(arg) != "def"} {
402	set num $btp(arg)
403	set btp(arg) def
404    }
405    bt:set-mark $w
406    set ndx [expr 1+[lindex [split [$w index end] .] 0]*$num/10]
407    $w mark set insert $ndx.0
408    $w tag remove sel 1.0 end
409    $w yview -pickplace insert
410    set btp(prevcmd) begin-buffer
411}
412
413proc bt:end-buffer { w {num 0}} {
414    global btp
415    set btp(lastkill) 0.0
416    if {$btp(arg) != "def"} {
417	set num $btp(arg)
418	set btp(arg) def
419    }
420    bt:set-mark $w
421    set ndx [expr [lindex [split [$w index end] .] 0]*$num/10]
422    $w mark set insert "end - $ndx lines"
423    $w tag remove sel 1.0 end
424    $w yview -pickplace insert
425    set btp(prevcmd) end-buffer
426}
427
428proc bt:scroll-next { w {num 1}} {
429    global  btp
430    set btp(lastkill) 0.0
431    if {$btp(arg) != "def"} {
432	set num $btp(arg)
433	set btp(arg) def
434    }
435    $w tag remove sel 1.0 end
436    set scr [lindex [lindex [$w configure -yscroll] 4] 0]
437    $w mark set insert [lindex [$scr get] 3].0
438    $w yview insert-1l
439    set btp(prevcmd) scroll-next
440}
441
442proc bt:scroll-prior { w {num 1}} {
443    global btp
444    set btp(lastkill) 0.0
445    if {$btp(arg) != "def"} {
446	set num $btp(arg)
447	set btp(arg) def
448    }
449    $w tag remove sel 1.0 end
450    set scr [lindex [lindex [$w configure -yscroll] 4] 0]
451    set tndx [expr [lindex [$scr get] 2]-[lindex [$scr get] 1]+5].0
452    if {$tndx < 1.0} {set tndx 1.0}
453    $w mark set insert $tndx
454    $w yview insert-1l
455    set btp(prevcmd) scroll-prior
456}
457
458proc bt:delete-word { w {num 1}} {
459    global btp
460    $w tag remove sel 1.0 end
461    if {[$w compare $btp(lastkill) == insert]} {
462	set lastcut [bt:pop-cut]
463    } else { set lastcut "" }
464    set beg [$w index insert]
465    if {$btp(arg) != "def"} {
466	set num $btp(arg)
467	set btp(arg) def
468    }
469    bt:move-word $w $num
470    #puts "$num : $beg [$w index insert]"
471    if {$beg < [$w index insert]} {
472        bt:push-cut "$lastcut[$w get $beg insert]"
473        $w delete $beg insert
474    } else {
475        bt:push-cut "[$w get insert $beg]$lastcut"
476        $w delete insert $beg
477    }
478    set btp(lastkill) [$w index insert]
479    $w yview -pickplace insert
480    set btp(prevcmd) delete-word
481}
482
483proc bt:delete-line { w {num 0}} {
484    global btp
485    $w tag remove sel 1.0 end
486    if {$btp(arg) != "def"} {
487	set num $btp(arg)
488	set btp(arg) def
489    }
490    if {[$w compare $btp(lastkill) == insert]} {
491	set lastcut [bt:pop-cut]
492    } else { set lastcut ""}
493    #    while {[$w get insert] == " "} {
494    #	$w mark set insert insert+1c
495    #    } 
496    if {[$w compare insert == "insert lineend"] && $num == 0} { set num 1 }
497    set beg [$w index insert]
498    if {$num != 0} {
499	bt:move-line $w $num
500	bt:begin-line $w
501	if {$beg < [$w index insert]} {
502	    bt:push-cut "$lastcut[$w get $beg insert]"
503	    $w delete $beg insert
504	} else {
505	    bt:push-cut "[$w get insert $beg]$lastcut"
506	    $w delete insert $beg
507	}
508    } else {
509      bt:push-cut "$lastcut[$w get insert {insert lineend}]"
510      $w delete insert {insert lineend};
511      $w yview -pickplace insert
512    }
513    $w yview -pickplace insert
514    set btp(lastkill) [$w index insert]
515    set btp(prevcmd) delete-line
516}
517
518proc bt:delete-back-char-or-sel { w {num 1} } {
519    global btp
520    if {$btp(arg) != "def"} {
521        set num $btp(arg)
522    } else {set btp(lastkill) 0.0}
523    set num [expr -1*$num]
524    if {$num > -1} {set num "+$num"}
525    if {[$w compare $btp(lastkill) == insert]} {
526	set lastcut [bt:pop-cut]
527    } else { set lastcut ""}
528    if [catch {set tmp [$w get sel.first sel.last]}] {
529        if {$btp(arg) != "def"} {
530	    if {$num < 0} {
531		bt:push-cut "[$w get "insert $num char" insert]$lastcut"
532	        $w delete "insert $num char" insert
533	    } else {
534		bt:push-cut "$lastcut[$w get insert "insert $num char"]"
535	        $w delete insert "insert $num char"
536	    }
537	    set btp(lastkill) [$w index insert]
538        } else {
539	    if {$num < 0} {
540	        $w delete "insert $num char" insert
541	    } else {
542	        $w delete insert "insert $num char"
543	    }
544	    set btp(lastkill) 0.0
545        }
546    } else {
547	$w delete sel.first sel.last
548	bt:push-cut $tmp
549        set btp(lastkill) 0.0
550    }
551    set btp(arg) def
552    $w yview -pickplace insert
553    set btp(prevcmd) delete-back-char-or-sel
554}
555
556proc bt:delete-region-or-sel { w } {
557    global btp
558
559    if {[catch {set tmp [$w get sel.first sel.last]}]} {
560	if {[catch "$w index emacs"]} {
561	    $btp(error) "No emacs mark has been set yet!"
562	}
563        if {[$w compare $btp(lastkill) == insert]} {
564	    set lastcut [bt:pop-cut]
565        } else { set lastcut ""}
566	if {[$w compare emacs < insert]} {
567	    bt:push-cut "$lastcut[$w get emacs insert]"
568	    $w delete emacs insert
569	} else {
570	    bt:push-cut "[$w get insert emacs]$lastcut"
571	    $w delete insert emacs
572	}
573        set btp(lastkill) [$w index insert]
574    } else {
575	$w delete sel.first sel.last
576	bt:push-cut $tmp
577        set btp(lastkill) 0.0
578    }
579    set btp(arg) def
580    set btp(prevcmd) delete-region-or-sel
581}
582
583proc bt:copy-region-or-sel { w } {
584    global btp
585
586    if {[catch {set tmp [$w get sel.first sel.last]}]} {
587	if {[catch "$w index emacs"]} {
588	    $btp(error) "No emacs mark has been set yet!"
589	}
590        if {[$w compare $btp(lastkill) == insert]} {
591	    set lastcut [bt:pop-cut]
592        } else { set lastcut ""}
593	if {[$w compare emacs < insert]} {
594	    bt:push-cut "$lastcut[$w get emacs insert]"
595	} else {
596	    bt:push-cut "[$w get insert emacs]$lastcut"
597	}
598	bt:exchange-point-and-mark $w
599	after 200 bt:exchange-point-and-mark $w
600    } else {
601	bt:push-cut $tmp
602    }
603    set btp(arg) def
604    set btp(lastkill) 0.0
605    set btp(prevcmd) copy-region-or-sel
606}
607
608proc bt:append-next-kill { w } {
609    global btp
610    set btp(lastkill) [$w index insert]
611}
612
613proc bt:push-cut { txt } {
614    global btp
615
616    set btp(killlen) [llength [lappend btp(killring) $txt]]
617    if { $btp(killlen) > $btp(maxkill)} {
618	set btp(killring) [lreplace $btp(killring) 0 0]
619	incr btp(killlen) -1    }
620    set btp(killptr) 0
621}
622
623proc bt:pop-cut { } {
624    global btp
625
626    if {$btp(killlen) == 0} {return ""}
627    set txt [bt:get-cut 1]
628    set ndx [expr $btp(killlen)-1]
629    set btp(killring) [lreplace $btp(killring) $ndx $ndx ]
630    incr btp(killlen) -1
631    set btp(killptr) 0
632    return $txt
633}
634
635proc bt:get-cut { {ndx 1} } {
636    global btp
637
638    set ndx [expr $ndx+$btp(killptr)]
639    set btp(killptr) [expr $ndx-1]
640    set ndx [expr $ndx%$btp(killlen)]
641    if {$ndx == 0} {set ndx $btp(killlen)}
642    return [lindex $btp(killring) [expr $btp(killlen)-$ndx]]
643
644}
645
646proc bt:yank { w {num 1}} {
647    global btp
648    $w tag remove sel 1.0 end
649    if {$btp(arg) != "def"} {
650	set num $btp(arg)
651	set btp(arg) def
652    }
653    set btp(lastkill) 0.0
654    set tmp [$w index insert]
655    $w insert insert [bt:get-cut $num]
656    $w mark set emacs $tmp
657    $w yview -pickplace insert
658    set btp(prevcmd) yank
659}
660
661proc bt:yank-pop { w {num 1}} {
662    global btp
663    if {$btp(arg) != "def"} {
664	set num $btp(arg)
665	set btp(arg) def
666    }
667    if {$btp(prevcmd) != "yank"} return
668    $w tag remove sel 1.0 end
669    $w delete emacs insert
670    set tmp [$w index insert]
671    $w insert insert [bt:get-cut [expr $num+1]]
672    $w mark set emacs $tmp
673    $w yview -pickplace insert
674}
675
676proc bt:pop-mark { w } {
677    global btp
678    set ndx [expr [llength $btp($w,markring)]-1]
679    set oldmark [lindex $btp($w,markring) $ndx]
680    $w mark set emacs $oldmark
681    set btp($w,markring) [concat $oldmark [lreplace $btp($w,markring) $ndx $ndx]]
682}
683
684proc bt:push-mark { w ndx } {
685    global btp
686    lappend btp($w,markring) $ndx
687    $w tag remove emacssel 1.0 end 
688}
689 
690proc bt:set-mark { w {num def}} {
691    global btp
692    $w tag remove sel 1.0 end
693    if {$btp(arg) != "def"} {
694	set num $btp(arg)
695	set btp(arg) def
696    }
697    if {$num != "def"} {
698	if {[catch "$w index emacs"]} {
699	    $btp(error) "No emacs mark has been set yet!"
700	}
701        #puts stdout "$w.yview \n"
702        $w yview -pickplace insert
703        bt:pop-mark $w
704        $w mark set insert emacs
705    } else {
706	bt:push-mark $w [$w index insert]
707        $w mark set emacs insert
708    }
709    set btp(lastkill) 0.0
710    set btp(prevcmd) set-mark
711}
712
713proc bt:exchange-point-and-mark { w } {
714    global btp
715    if {[catch "$w index emacs"]} {
716	$btp(error) "No emacs mark has been set yet!"
717    }
718    set tmp [$w index insert]
719    $w mark set insert emacs
720    $w mark set emacs $tmp
721    set btp(lastkill) 0.0
722    set btp(prevcmd) set-mark
723}
724
725proc bt:open-line {w {num 1}} {
726    global btp
727    if {$btp(arg) != "def"} {
728	set num $btp(arg)
729	set btp(arg) def
730    }
731    catch {$w delete sel.first sel.last}
732    for {set i 0} {$i < $num } {incr i} {
733        $w insert insert \n
734    }
735    $w mark set insert insert-1c
736    $w yview -pickplace insert
737    set btp(prevcmd) open-line
738}
739
740proc bt:argkey { w a } {
741    global btp
742    set btp(arg) $a
743} 
744
745proc bt:numkey { w a } {
746    global btp
747    if {$btp(arg) == "def"} {
748	catch {%W delete sel.first sel.last}
749	$w insert insert $a
750	if {$btp(fillcol) && [bt:current-col $w] >= $btp(fillcol)} {
751	    bt:wrap-word $w
752	}
753	$w yview -pickplace insert
754	set btp(lastkill) 0.0
755	set btp(prevcmd) self-insert
756    } else {
757	if {$a == "-"} {
758	    if {$btp(arg) == "-"} { 
759		set btp(arg) "0" 
760	    } elseif {$btp(arg) == "0"} {
761		set btp(arg) "-"
762	    } else {
763		set btp(arg) [expr -1*$btp(arg)]
764	    }
765	} else {
766	    append btp(arg) $a
767	}
768    }
769} 
770
771proc bt:univ-arg { w } {
772    global btp
773    if {$btp(arg) == "def"} {
774	set btp(arg) 4
775    } else {
776	if {$btp(arg) == "-"} { 
777	    set btp(arg) "-4" 
778	} else {
779	    set btp(arg) [expr 4*$btp(arg)]
780	}
781    }
782}
783
784proc bt:wrap-word { w } {
785    global btp
786
787    bt:move-word $w -1
788    $w insert insert \n
789    bt:end-line $w
790}
791
792proc bt:set-fill-col { w {num 0}} {
793    global btp
794    if {$btp(arg) == "def"} {
795	if {$num < 1} {
796	    set btp(fillcol) [bt:current-col $w]
797	} else {
798	    set btp(fillcol) $num
799	}
800    } else {
801	if {$btp(arg) < 1} {
802	    set btp(fillcol) [bt:current-col $w]
803	} else {
804	    set btp(fillcol) $btp(arg)
805	}
806    }
807    set btp(arg) def
808    set btp(lastkill) 0.0
809    set btp(prevcmd) set-fill-col
810}
811
812proc bind_motiftext { tw } {
813    global bind_xnd
814
815    bind $tw <Control-KeyPress> {
816        global btp
817	if {"%A" != ""} {eval $btp(beep) }
818    }
819
820    # Some better bindings for text and entry
821    bind $tw <Up> {bt:move-line %W -1}
822    bind $tw <Down> {bt:move-line %W 1}
823    bind $tw <Left> {bt:move-char %W -1}
824    bind $tw <Right> {bt:move-char %W 1}
825    bind $tw <Home> {bt:begin-line %W}
826    bind $tw <End> {bt:end-line %W}
827    bind $tw <Control-Home> {bt:begin-buffer %W}
828    bind $tw <Control-End> {bt:end-buffer %W}
829    bind $tw <Control-Left> {bt:move-word %W -1}
830    bind $tw <Control-Right> {bt:move-word %W 1}
831    bind $tw <Next> {bt:scroll-next %W}
832    bind $tw <Prior> {bt:scroll-prior %W}
833
834    bind $tw <Any-KeyPress> {
835	global btp
836	set num 1
837	if {"%A" != ""} {
838	    if {$btp(arg) != "def"} {
839		set num $btp(arg)
840		set btp(arg) def
841	    }
842	    catch {%W delete sel.first sel.last}
843	    for {set i 0} { $i < $num} {incr i} {%W insert insert %A}
844	    if {$btp(fillcol) && [bt:current-col %W] >= $btp(fillcol)} {
845		if {"%A" == " "} {
846		    %W insert insert \n
847		} elseif {"%A" == "\t"} {
848		    %W insert insert \n\t
849		} else {
850		    bt:wrap-word %W
851		}
852	    }
853	    %W yview -pickplace insert
854	    set btp(lastkill) 0.0
855	    set btp(prevcmd) self-insert
856	}
857    }
858
859    bind $tw <KeyPress-Return> {
860	global btp
861        catch {%W delete sel.first sel.last}
862	set num 1
863	if {$btp(arg) != "def"} {
864	    set num $btp(arg)
865	    set btp(arg) def
866	}
867        for {set i 0} { $i < $num} {incr i} {%W insert insert "\n"}
868        %W yview -pickplace insert
869	set btp(lastkill) 0.0
870	set btp(prevcmd) newline
871    }
872
873    bind $tw <KeyPress-Delete> {bt:delete-back-char-or-sel %W 1}
874    bind $tw <KeyPress-BackSpace> {bt:delete-back-char-or-sel %W 1}
875
876    bind $tw <1> "[bind Text <1>]; \
877                  global btp; set btp(lastkill) 0.0; \
878		  set btp(prevcmd) mouse-set"
879    bind $tw <3> {%W tag remove sel 1.0 end}
880    bind $tw <B1-Motion> {bind_textB1motion %W @%x,%y}
881
882    set bind_xnd(b2-time) 0
883    set bind_xnd(b2-y) 0
884    bind $tw <2> {
885        global bind_xnd
886        %W scan mark %y
887        set bind_xnd(b2-time) %t
888        set bind_xnd(b2-y) %y
889    }
890    bind $tw <ButtonRelease-2> {
891        global bind_xnd
892	if {[expr %t-$bind_xnd(b2-time)]<1000} {
893	    %W insert insert [selection_if_any]
894 	    global btp
895	    set btp(lastkill) 0.0
896	    set btp(prevcmd) mouse-insert
897        }
898    }
899
900    # only one mouse, so no need have separate vars for each widget
901    set bind_xnd(txnd) 0
902    set bind_xnd(xdelay) 100
903    proc bind_textB1motion  { w loc } {
904	global bind_xnd
905
906	set ypos [lindex [split $loc ","] 1]
907	if {$ypos > [winfo height $w]} {
908		if {!$bind_xnd(txnd)} {after $bind_xnd(xdelay) bind_textExtend $w}
909		set bind_xnd(txnd) 1
910		set bind_xnd(direction) down
911	} elseif {$ypos < 0} {
912		if {!$bind_xnd(txnd)} {after $bind_xnd(xdelay) bind_textExtend $w}
913		set bind_xnd(txnd) 1
914		set bind_xnd(direction) up
915	} else {
916		set bind_xnd(txnd) 0
917		set bind_xnd(direction) 0
918	}
919
920	if {!$bind_xnd(txnd)} {
921		tk_textSelectTo $w $loc
922	}
923
924    }
925
926    bind $tw <ButtonRelease-1> { 
927        global bind_xnd btp
928        set bind_xnd(txnd) 0
929	set btp(lastkill) 0.0
930	set btp(prevcmd) mouse-select
931    }
932
933    proc bind_textExtend { w } {
934	 global bind_xnd
935
936	 if {$bind_xnd(txnd)} {
937	     if {$bind_xnd(direction) == "down"} {
938		 tk_textSelectTo $w sel.last+1l
939		 $w yview -pickplace sel.last+1l
940	     } elseif {$bind_xnd(direction) == "up"} {
941		 tk_textSelectTo $w sel.first-1l
942		 $w yview -pickplace sel.first-1l
943	     } else { return }
944	     after $bind_xnd(xdelay) bind_textExtend $w
945	 }
946    }
947
948}
949
950proc bind_emacstext { tw } {
951    global btp
952
953    bind $tw <Any-KeyPress> {
954        if [catch {set tmp [%W get emacssel.first emacssel.last]}] {
955        } else {
956            %W tag remove emacssel 1.0 $first
957            %W tag add emacssel $first $last
958            %W tag remove emacssel $last end
959            update idletasks
960        }
961        %W insert insert %A
962    }
963
964    # make Escape key simulate a state Alt key
965    bind $tw <Escape> { }
966    bind $tw <Escape><Any-KeyPress> {
967        global btp
968	if {"%A" != ""} {eval $btp(beep) }
969    }
970
971    bind $tw <Control-a> {bt:begin-line %W}
972    bind $tw <Control-e> {bt:end-line %W}
973    bind $tw <Control-f> {bt:move-char %W 1}
974    bind $tw <Control-b> {bt:move-char %W -1}
975    bind $tw <Escape><f> {bt:move-word %W 1}
976    bind $tw <Escape><b> {bt:move-word %W -1}
977
978    bind $tw <Control-n> {bt:move-line %W 1}
979    bind $tw <Control-p> {bt:move-line %W -1}
980    bind $tw <Control-l> {
981	%W yview -pickplace insert
982    }
983    bind $tw <Control-o> {bt:open-line %W 1}
984    bind $tw <Control-d> {bt:delete-back-char-or-sel %W -1}
985    bind $tw <Escape><d> {bt:delete-word %W 1}
986
987    bind $tw <Control-h> {bt:delete-back-char-or-sel %W -1}
988
989    bind $tw <Control-k> {bt:delete-line %W 0}
990    bind $tw <Control-w> {bt:delete-region-or-sel %W}
991    bind $tw <Escape><w> {bt:copy-region-or-sel %W}
992    bind $tw <Control-y> {bt:yank %W}
993    bind $tw <Escape><y> {bt:yank-pop %W}
994    bind $tw <Control-space> {bt:set-mark %W}
995
996    bind $tw <Control-u> {bt:univ-arg %W}
997    bind $tw <KeyPress-0> {bt:numkey %W %A}
998    bind $tw <KeyPress-1> {bt:numkey %W %A}
999    bind $tw <KeyPress-2> {bt:numkey %W %A}
1000    bind $tw <KeyPress-3> {bt:numkey %W %A}
1001    bind $tw <KeyPress-4> {bt:numkey %W %A}
1002    bind $tw <KeyPress-5> {bt:numkey %W %A}
1003    bind $tw <KeyPress-6> {bt:numkey %W %A}
1004    bind $tw <KeyPress-7> {bt:numkey %W %A}
1005    bind $tw <KeyPress-8> {bt:numkey %W %A}
1006    bind $tw <KeyPress-9> {bt:numkey %W %A}
1007
1008    bind $tw <Escape><KeyPress-0> {bt:argkey %W %A}
1009    bind $tw <Escape><KeyPress-1> {bt:argkey %W %A}
1010    bind $tw <Escape><KeyPress-2> {bt:argkey %W %A}
1011    bind $tw <Escape><KeyPress-3> {bt:argkey %W %A}
1012    bind $tw <Escape><KeyPress-4> {bt:argkey %W %A}
1013    bind $tw <Escape><KeyPress-5> {bt:argkey %W %A}
1014    bind $tw <Escape><KeyPress-6> {bt:argkey %W %A}
1015    bind $tw <Escape><KeyPress-7> {bt:argkey %W %A}
1016    bind $tw <Escape><KeyPress-8> {bt:argkey %W %A}
1017    bind $tw <Escape><KeyPress-9> {bt:argkey %W %A}
1018    bind $tw <Escape><KeyPress-minus> {bt:argkey %W %A}
1019
1020    # make C-x key a state
1021    bind $tw <Control-x> { }
1022    bind $tw <Control-x><Any-KeyPress> {
1023        global btp
1024	if {"%A" != ""} {eval $btp(beep) }
1025    }
1026    bind $tw <Control-x><Control-x> {bt:exchange-point-and-mark %W}
1027    bind $tw <Control-x><KeyPress-f> {bt:set-fill-col %W}
1028
1029    # Make Meta key like and Escape prefix
1030    if {$btp(use-meta)} {
1031	bind $tw <Meta-KeyPress> {
1032	    global btp
1033	    if {"%A" != ""} {eval $btp(beep) }
1034	}
1035	bind $tw <Control-Meta-KeyPress> {
1036	    global btp
1037	    if {"%A" != ""} {eval $btp(beep) }
1038	}
1039
1040	bind $tw <Meta-f> {bt:move-word %W 1}
1041	bind $tw <Meta-b> {bt:move-word %W -1}
1042	bind $tw <Meta-d> {bt:delete-word %W 1}
1043	bind $tw <Meta-w> {bt:copy-region-or-sel %W}
1044	bind $tw <Meta-y> {bt:yank-pop %W}
1045
1046	bind $tw <Meta-0> {bt:argkey %W %A}
1047	bind $tw <Meta-1> {bt:argkey %W %A}
1048	bind $tw <Meta-2> {bt:argkey %W %A}
1049	bind $tw <Meta-3> {bt:argkey %W %A}
1050	bind $tw <Meta-4> {bt:argkey %W %A}
1051	bind $tw <Meta-5> {bt:argkey %W %A}
1052	bind $tw <Meta-6> {bt:argkey %W %A}
1053	bind $tw <Meta-7> {bt:argkey %W %A}
1054	bind $tw <Meta-8> {bt:argkey %W %A}
1055	bind $tw <Meta-9> {bt:argkey %W %A}
1056	bind $tw <Meta-minus> {bt:argkey %W %A}
1057    }
1058}
1059
1060
1061
1062
1063#----------------------------------------------------------------------------
1064#----------------------------------------------------------------------------
1065#  
1066#     The  xe  main  code  follows  now  ...
1067#
1068#----------------------------------------------------------------------------
1069#----------------------------------------------------------------------------
1070
1071
1072#---------------------------------------------------------------
1073#   PrintOutputWindow
1074#
1075#---------------------------------------------------------------
1076proc PrintOutputWindow { printer_pipe } {
1077
1078    set f [open "|$printer_pipe" w] 
1079    puts $f [.pane.output.text get 1.0 end ] 
1080    close $f
1081}
1082
1083
1084#---------------------------------------------------------------
1085#   PrintPreDefined
1086#
1087#---------------------------------------------------------------
1088proc PrintPreDefined { } {
1089
1090    global landscape doublesided nobanner prsize
1091
1092
1093    set printerName [.printdlg.input.predef.f.prname.name get]
1094
1095    #puts stderr "printer_name: $printerName"
1096    #puts stderr "landscape:    $landscape"
1097    #puts stderr "doublesided:  $doublesided"
1098    #puts stderr "prsize:       $prsize"
1099
1100
1101    array set sizeoption { 
1102        yes-large    { -o vsi7 -o fp16 -o landscape }
1103        yes-normal   { -o vsi6 -o fp18 -o landscape -o height80  }
1104        yes-small    { -o vsi5 -o fp20 -o landscape -o height90  }
1105        yes-smallest { -o vsi4 -o fp24 -o landscape -o height100 }
1106        yes-micro    { -o vsi3 -o fp28 -o landscape -o height110 }
1107
1108        no-large     { -o vsi7 -o fp16 -o portrait }
1109        no-normal    { -o vsi6 -o fp18 -o portrait }
1110        no-small     { -o vsi5 -o fp20 -o portrait }
1111        no-smallest  { -o vsi4 -o fp24 -o portrait }
1112    }
1113
1114    set command $sizeoption(${landscape}-${prsize})
1115
1116    if {$doublesided == "yes"} {
1117        append command " -o duplex"
1118    } else {
1119        append command " -o simplex"
1120    }
1121
1122    if {$nobanner == "yes"} {
1123        append command " -o nb"
1124    }
1125
1126    append command " -d $printerName"
1127
1128    PrintOutputWindow  "lp $command"
1129}
1130
1131
1132#---------------------------------------------------------------
1133#   PrintDialog
1134#
1135#---------------------------------------------------------------
1136proc PrintDialog { } {
1137
1138    global dbname dbsname
1139
1140    set w .printdlg
1141    catch {destroy $w}
1142    toplevel $w -class Dialog
1143    wm title $w "Print Output"
1144    wm iconname $w "Print Output"
1145    wm protocol $w WM_DELETE_WINDOW { }
1146
1147    frame $w.input \
1148        -relief flat -borderwidth 0 -highlightthickness 0
1149    frame $w.buttons \
1150        -relief flat -borderwidth 0 -highlightthickness 0
1151
1152    button $w.buttons.print \
1153        -text " Print "  \
1154        -command "PrintPreDefined; destroy $w"
1155    button $w.buttons.cancel \
1156        -text " Cancel "  -command "destroy $w"
1157    pack $w.buttons.print $w.buttons.cancel -side top -pady 10 -fill x
1158
1159
1160
1161    #-----------------------------------------------
1162    #   pre-customized printer configuration
1163    #-----------------------------------------------
1164    frame $w.input.predef \
1165        -relief flat -borderwidth 0 -highlightthickness 0
1166    label $w.input.predef.h \
1167        -text "Pre-customized Printer Configuration:"
1168    frame $w.input.predef.f \
1169        -relief groove -borderwidth 2 -highlightthickness 0
1170    pack $w.input.predef.h -anchor w -side top 
1171    pack $w.input.predef.f -side top -ipadx 5 -ipady 5 -fill x
1172
1173    frame $w.input.predef.f.prname \
1174        -relief groove -borderwidth 0 -highlightthickness 0
1175    label $w.input.predef.f.prname.l \
1176        -text "Printer Name:"
1177    entry $w.input.predef.f.prname.name \
1178        -relief sunken -borderwidth 1 -highlightthickness 1 \
1179        -width 20 -background gray90 -exportselection yes
1180    pack $w.input.predef.f.prname.l -side left
1181    pack $w.input.predef.f.prname.name -side left -anchor w -fill x
1182
1183    frame $w.input.predef.f.kind \
1184        -relief groove -borderwidth 0 -highlightthickness 0
1185    radiobutton $w.input.predef.f.kind.large  \
1186         -text "Large (100 char width) " -variable prsize  -relief flat -value large
1187    radiobutton $w.input.predef.f.kind.normal \
1188         -text "Normal (150 char width)" -variable prsize  -relief flat -value normal
1189    radiobutton $w.input.predef.f.kind.small  \
1190         -text "Small (200 char width)" -variable  prsize   -relief flat -value small 
1191    radiobutton $w.input.predef.f.kind.smallest \
1192         -text "Smallest (240 char width)" -variable prsize  -relief flat -value smallest
1193    radiobutton $w.input.predef.f.kind.micro \
1194         -text "Micro (>240 char width)" -variable prsize  -relief flat -value micro
1195
1196    $w.input.predef.f.kind.small select
1197
1198    pack $w.input.predef.f.kind.large    \
1199         $w.input.predef.f.kind.normal   \
1200         $w.input.predef.f.kind.small    \
1201         $w.input.predef.f.kind.smallest \
1202         $w.input.predef.f.kind.micro    -anchor w -side top
1203
1204
1205    frame $w.input.predef.f.optionskind \
1206        -relief groove -borderwidth 0 -highlightthickness 0
1207    checkbutton $w.input.predef.f.optionskind.landscape -text "landscape (-o landscape)" \
1208        -variable landscape -onvalue "yes" -offvalue "no" -relief flat 
1209    $w.input.predef.f.optionskind.landscape select
1210    checkbutton $w.input.predef.f.optionskind.double    -text "double sided (-o duplex)" \
1211        -variable doublesided  -onvalue "yes" -offvalue "no" -relief flat
1212    checkbutton $w.input.predef.f.optionskind.nobanner  -text "no banner (-o nb)" \
1213        -variable nobanner -onvalue "yes" -offvalue "no" -relief flat
1214    pack $w.input.predef.f.optionskind.landscape \
1215         $w.input.predef.f.optionskind.double    \
1216         $w.input.predef.f.optionskind.nobanner  -anchor w -side top
1217
1218
1219    pack $w.input.predef.f.prname \
1220         $w.input.predef.f.kind   \
1221         $w.input.predef.f.optionskind -side top -padx 1 -pady 5 -fill x
1222
1223   
1224    #-----------------------------------------------
1225    #   self printer configuration
1226    #-----------------------------------------------
1227    frame $w.input.self \
1228        -relief flat -borderwidth 0 -highlightthickness 0
1229    label $w.input.self.h \
1230        -text "Full Command Line:"
1231    frame $w.input.self.f2 \
1232        -relief groove -borderwidth 2 -highlightthickness 0
1233
1234    entry $w.input.self.f2.cmdline \
1235        -relief sunken -borderwidth 2 -highlightthickness 1 \
1236        -width 40 -background gray90 -exportselection yes
1237    button $w.input.self.f2.print \
1238        -text " Print " -command {
1239            set printer_pipe [.printdlg.input.self.f2.cmdline get];
1240            PrintOutputWindow "$printer_pipe"
1241        }
1242    pack $w.input.self.f2.cmdline $w.input.self.f2.print \
1243        -side left -padx 5
1244    pack $w.input.self.h -anchor w -side top
1245    pack $w.input.self.f2 -side top -ipadx 5 -ipady 5
1246
1247    #-------------------------------------------------------------
1248    pack $w.input.predef $w.input.self -side top -pady 10 -fill x 
1249    pack $w.input    -side left -padx 10 -pady 10 -fill x
1250    pack $w.buttons  -side left -padx 10 -pady 30 -fill y
1251
1252}
1253
1254
1255#----------------------------------------------------------------------------
1256#   SaveTextWindow
1257#
1258#----------------------------------------------------------------------------
1259proc SaveTextWindow { textw filename } {
1260    set f [open $filename w ];
1261    $textw mark set insert end
1262    #--remove the empty part at the bottom
1263    while {1} {
1264        set line [$textw get {insert linestart} {insert lineend}]
1265        if {$line != ""} {
1266            break;
1267        }
1268        $textw mark set insert {insert -1 line}
1269        if {[$textw compare insert < 3.0]} {
1270            break;
1271        }
1272    }
1273    puts $f [$textw get 1.0 {insert lineend} ] 
1274    close $f
1275}
1276
1277
1278#----------------------------------------------------------------------------
1279#   Base64Init
1280#
1281#----------------------------------------------------------------------------
1282proc Base64Init { } {
1283 
1284    global base64_b2c base64_c2b
1285    set i -1
1286    foreach a { A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 
1287                a b c d e f g h i j k l m n o p q r s t u v w x y z 
1288                0 1 2 3 4 5 6 7 8 9 + /                             } {
1289
1290        binary scan [binary format c1 [incr i]] B* v
1291        set base64_b2c([string range $v 2 end]) $a
1292        set base64_c2b($a) [string range $v 2 end]
1293    }
1294}
1295
1296
1297#----------------------------------------------------------------------------
1298#   Base64EncodeBufferData
1299#
1300#----------------------------------------------------------------------------
1301proc Base64EncodeBufferData { data } {
1302    global base64_b2c
1303
1304    # Get the bit stream
1305    binary scan $data B* bits
1306
1307    # Convert groups of six bits to a list for easy traversal
1308    regsub -all {((0|1)(0|1)(0|1)(0|1)(0|1)(0|1))} $bits {\1 } bits
1309    foreach b $bits {
1310	append result $base64_b2c($b)
1311    }
1312    return $result
1313}
1314
1315
1316#----------------------------------------------------------------------------
1317#   Base64Encode
1318#
1319#----------------------------------------------------------------------------
1320proc Base64Encode { data {buffersize 6144} } {
1321
1322    global base64_b2c
1323
1324    if { ![array exists base64_b2c] } {
1325       Base64Init
1326    }
1327
1328    # Convert the data to a bitstream and then encode.
1329    # This approach requires a buffer eight times the size of the
1330    # data to be encoded, so just work on a buffer at a time.
1331    # The default buffer size is 6 * 1024 bytes (6KB).
1332    # This is a trade-off between speed and space.
1333
1334    if {$buffersize % 3} {
1335	# Buffer must be a multiple of 3 bytes
1336	set buffersize [expr $buffersize - $buffersize % 3]
1337    }
1338
1339    set linelen 0
1340    while {[string length $data] > $buffersize} {
1341	# Get the buffer to work on
1342	set buffer [string range $data 0 [expr $buffersize - 1]]
1343	set data [string range $data $buffersize end]
1344
1345	append result [Base64EncodeBufferData $buffer]
1346    }
1347    if {[string length $data]} {
1348	# Deal with remaining data
1349	# Encode to an even multiple of 3 bytes, and then
1350	# pad the rest
1351	set buffer [string range $data 0 [expr [string length $data] - [string length $data] % 3 - 1]]
1352	set remainder [string range $data [expr [string length $data] - [string length $data] % 3] end]
1353
1354	append result [Base64EncodeBufferData $buffer]
1355
1356	switch [string length $remainder] {
1357	    1 {
1358		binary scan $remainder B* bits
1359		append result $base64_b2c([string range $bits 0 5])
1360		append result $base64_b2c([string range $bits 6 7]0000)
1361		append result ==
1362	    }
1363	    2 {
1364		binary scan $remainder B* bits
1365		append result $base64_b2c([string range $bits 0 5])
1366		append result $base64_b2c([string range $bits 6 11])
1367		append result $base64_b2c([string range $bits 12 15]00)
1368		append result =
1369	    }
1370	}
1371    }
1372
1373    # Ensure lines are no more than 76 characters
1374    regsub -all {(........................................................................)} \
1375                $result "\\1\n" result
1376    return $result
1377}
1378
1379
1380#----------------------------------------------------------------------------
1381#   IntroWindow
1382#
1383#----------------------------------------------------------------------------
1384proc IntroWindow { } {
1385
1386    global HelvB12 Helv12
1387
1388    frame .splash -borderwidth 4 -relief raised
1389
1390    label .splash.info1 -font $HelvB12 -text "XE - a simple XML/XPath Browser/Viewer"
1391    label .splash.info2 -font $Helv12  -text "Version 0.2"
1392    label .splash.info3 -font $Helv12  -text "Copyright (c) 1999,2001 Jochen Loewer (loewerj@hotmail.com)"
1393
1394    pack  .splash.info1 \
1395          .splash.info2 \
1396          .splash.info3  -padx 4 -pady 4 -anchor w
1397    place .splash -anchor c -relx .5 -rely .5
1398    after 2500 destroy .splash
1399    update
1400}
1401
1402
1403#----------------------------------------------------------------------------
1404#   ConfigureProxy
1405#
1406#----------------------------------------------------------------------------
1407proc ConfigureProxy { } {
1408
1409    global HttpProxyHost HttpProxyPort gotProxy
1410
1411 
1412    set gotProxy  -1
1413
1414    set w .proxyDdlg
1415    catch {destroy $w}
1416
1417    toplevel    $w -class Dialog
1418    wm title    $w "Configure HTTP Proxy"
1419    wm iconname $w "HTTP Proxy"
1420    wm protocol $w WM_DELETE_WINDOW { }
1421
1422    frame $w.hdr \
1423        -relief flat -borderwidth 0 -highlightthickness 0
1424    label $w.hdr.icon -bitmap questhead
1425    label $w.hdr.msg -text "Specify HTTP proxy server:  "
1426
1427    frame $w.fields \
1428        -relief flat -borderwidth 0 -highlightthickness 0
1429    label $w.fields.hostlabel -text "Proxy Host:"    
1430    entry $w.fields.hostvalue \
1431        -relief sunken -borderwidth 1 -highlightthickness 1 \
1432        -width 20 -background gray90 -exportselection yes    
1433    label $w.fields.portlabel -text "Porxy Port:"    
1434    entry $w.fields.portvalue \
1435        -relief sunken -borderwidth 1 -highlightthickness 1 \
1436        -width 20 -background gray90 -exportselection yes 
1437
1438    frame $w.buttons \
1439        -relief flat -borderwidth 0 -highlightthickness 0
1440    button $w.buttons.ok  -text " OK "  \
1441        -command "set gotProxy \[list 1 \[$w.fields.hostvalue get\]     \
1442                                        \[$w.fields.portvalue get\] \]; \
1443                  destroy $w"
1444    bind $w.fields.portvalue <Return> "                                 \
1445                  set gotProxy \[list 1 \[$w.fields.hostvalue get\]     \
1446                                        \[$w.fields.portvalue get\] \]; \
1447                  destroy $w"
1448    button $w.buttons.cancel -text " Cancel " \
1449           -command "destroy $w; set gotProxy {0 {} {}}"
1450
1451    $w.fields.hostvalue insert 0 $HttpProxyHost
1452    $w.fields.portvalue insert 0 $HttpProxyPort
1453
1454    pack $w.hdr.icon $w.hdr.msg             -side left
1455
1456    grid $w.fields.hostlabel -in $w.fields -column 0 -row 0 -sticky e
1457    grid $w.fields.portlabel -in $w.fields -column 0 -row 1 -sticky e
1458    grid $w.fields.hostvalue -in $w.fields -column 1 -row 0 -sticky w
1459    grid $w.fields.portvalue -in $w.fields -column 1 -row 1 -sticky w
1460
1461    pack $w.buttons.ok $w.buttons.cancel     -side left
1462
1463
1464    pack $w.hdr     \
1465         $w.fields  \
1466         $w.buttons -side top -anchor w -padx 9 -pady 9
1467
1468    focus $w.fields.hostvalue
1469
1470    while {$gotProxy == -1} {
1471        vwait gotProxy
1472    }
1473    if {[lindex $gotProxy 0]} {
1474        set HttpProxyHost [lindex $gotProxy 1]
1475        set HttpProxyPort [lindex $gotProxy 2] 
1476    }
1477}
1478
1479
1480#----------------------------------------------------------------------------
1481#   GetUserPassword
1482#
1483#----------------------------------------------------------------------------
1484proc GetUserPassword { state_var login_var password_var } {
1485
1486    global gotPassword Login
1487
1488    upvar $state_var    state
1489    upvar $login_var    login
1490    upvar $password_var password
1491
1492    #parray state
1493
1494    set server ""
1495    set realm  ""
1496
1497    
1498    regexp {http://([^/]*)/(.*)} $state(url) all server file
1499
1500    array set meta $state(meta)
1501    if {[info exists meta(WWW-authenticate)]} {
1502        set realmStr [lindex $meta(WWW-authenticate) 1]
1503        regexp {realm="([^"]*)"} $realmStr all realm
1504    }
1505
1506    #puts stderr "login='$login' password='$password' server='$server' realm='$realm'"
1507
1508
1509    if {[info exists Login($server,$realm)]} {
1510        foreach { new_login new_password } $Login($server,$realm) break
1511        if {($new_login != $login ) || ($new_password != $password)} {
1512            set login    $new_login
1513            set password $new_password
1514            return 1 
1515        }
1516    }
1517 
1518    set gotPassword -1
1519    set login       ""
1520    set password    ""
1521
1522    set w .passwordDdlg
1523    catch {destroy $w}
1524
1525    toplevel    $w -class Dialog
1526    wm title    $w "HTTP Password"
1527    wm iconname $w "HTTP Password"
1528    wm protocol $w WM_DELETE_WINDOW { }
1529
1530    frame $w.hdr \
1531        -relief flat -borderwidth 0 -highlightthickness 0
1532    label $w.hdr.icon -bitmap questhead
1533    label $w.hdr.msg -text "Enter username for  $realm  at  $server  "
1534
1535    frame $w.fields \
1536        -relief flat -borderwidth 0 -highlightthickness 0
1537    label $w.fields.userlabel -text "User name:"    
1538    entry $w.fields.uservalue \
1539        -relief sunken -borderwidth 1 -highlightthickness 1 \
1540        -width 20 -background gray90 -exportselection yes    
1541    label $w.fields.passlabel -text "Password:"    
1542    entry $w.fields.passvalue \
1543        -relief sunken -borderwidth 1 -highlightthickness 1 \
1544        -width 20 -background gray90 -exportselection yes -show *
1545
1546    frame $w.buttons \
1547        -relief flat -borderwidth 0 -highlightthickness 0
1548    button $w.buttons.ok  -text " OK "  \
1549        -command "set gotPassword \[list 1 \[$w.fields.uservalue get\]     \
1550                                           \[$w.fields.passvalue get\] \]; \
1551                  destroy $w"
1552    bind $w.fields.passvalue <Return> "                                    \
1553                  set gotPassword \[list 1 \[$w.fields.uservalue get\]     \
1554                                           \[$w.fields.passvalue get\] \]; \
1555                  destroy $w"
1556    button $w.buttons.cancel -text " Cancel " \
1557           -command "destroy $w; set gotPassword {0 {} {}}"
1558
1559    pack $w.hdr.icon $w.hdr.msg             -side left
1560
1561    grid $w.fields.userlabel -in $w.fields -column 0 -row 0 -sticky e
1562    grid $w.fields.passlabel -in $w.fields -column 0 -row 1 -sticky e
1563    grid $w.fields.uservalue -in $w.fields -column 1 -row 0 -sticky w
1564    grid $w.fields.passvalue -in $w.fields -column 1 -row 1 -sticky w
1565
1566    pack $w.buttons.ok $w.buttons.cancel     -side left
1567
1568
1569    pack $w.hdr     \
1570         $w.fields  \
1571         $w.buttons -side top -anchor w -padx 9 -pady 9
1572
1573    focus $w.fields.uservalue
1574
1575    while {$gotPassword == -1} {
1576        vwait gotPassword
1577    }
1578
1579    if {[lindex $gotPassword 0]} {
1580        set login    [lindex $gotPassword 1]
1581        set password [lindex $gotPassword 2]
1582        set Login($server,$realm) [list $login $password]
1583        return 1
1584    }
1585    return 0
1586}
1587
1588
1589#----------------------------------------------------------------------------
1590#   xmlEdit
1591#
1592#----------------------------------------------------------------------------
1593proc xmlEdit { {line 0} {column 0} } {
1594
1595    global xml Cour12 Helv12
1596
1597    if {[winfo exists .edit]} {
1598        .edit.f.text mark set  insert $line.$column
1599        .edit.f.text see insert
1600        focus .edit.f.text 
1601        return
1602    }
1603    toplevel .edit
1604    wm title .edit "XML Source"
1605
1606    set path .edit.f
1607
1608    frame $path -relief flat -borderwidth 3 -highlightthickness 0
1609
1610    text $path.text -width 100 -height 30 -font $Cour12 \
1611                    -bg gray90 \
1612                    -exportselection yes  -wrap none  \
1613                    -yscrollcommand "$path.vsb set"   \
1614                    -xscrollcommand "$path.hsb set"
1615
1616    scrollbar $path.vsb -relief sunken  -orient vertical \
1617                        -command "$path.text yview"  
1618
1619    scrollbar $path.hsb -relief sunken  -orient horizontal  \
1620                        -command "$path.text xview" 
1621 
1622    button .edit.reload -text " Reload " -command xmlReload \
1623                        -font $Helv12
1624
1625    pack $path.vsb  -side right  -fill y    -expand no
1626    pack $path.hsb  -side bottom -fill x    -expand no
1627    pack $path.text -side top    -fill both -expand yes 
1628    pack $path -expand yes -fill both
1629    pack .edit.reload -anchor e
1630   
1631    $path.text delete 1.0 end
1632    $path.text insert end $xml
1633    .edit.f.text mark set  insert $line.$column
1634    .edit.f.text see insert
1635    focus .edit.f.text 
1636}
1637
1638
1639#----------------------------------------------------------------------------
1640#   xmlHighlight
1641#
1642#----------------------------------------------------------------------------
1643proc xmlHighlight { path pos tag highlight_tag} {
1644
1645    set range [$path tag nextrange $tag $pos [$path index "$pos lineend"] ]
1646    if {$range == ""} {
1647        set range [$path tag prevrange $tag $pos [$path index "$pos linestart"] ]
1648    }
1649    if {$range != ""} {
1650        eval $path tag add $highlight_tag [lrange $range 0 1]
1651    }
1652}
1653
1654
1655#----------------------------------------------------------------------------
1656#   xmlHighlightMotion
1657#
1658#----------------------------------------------------------------------------
1659proc xmlHighlightMotion { path pos tag highlight_tag} {
1660
1661    set tags [$path tag names $pos]
1662    if {[lsearch -exact $tags $highlight_tag] < 0} {
1663        $path tag remove $highlight_tag 1.0 end
1664    } 
1665    xmlHighlight $path $pos $tag $highlight_tag
1666}
1667
1668
1669#----------------------------------------------------------------------------
1670#   xmlJump
1671#
1672#----------------------------------------------------------------------------
1673proc xmlJump { path pos } {
1674    foreach tag [$path tag names $pos] {
1675        if { ($tag != "tag") } {
1676            xmlEdit [$tag getLine] [$tag getColumn]
1677        }
1678    }
1679}
1680
1681
1682#----------------------------------------------------------------------------
1683#   xmlOpen
1684#
1685#----------------------------------------------------------------------------
1686proc xmlOpen { path pos } {
1687    global levels
1688    foreach tag [$path tag names $pos] {
1689        if {($tag != "open") && ($tag != "hot") && ($tag != "sel")} {
1690
1691            $path configure -state normal
1692            set start [$path index "$pos linestart"]
1693            set end   [$path index "$start + 1 lines"]
1694            $path delete $start $end
1695            while 1 {
1696                set end   [$path index "$start + 1 lines"]
1697                set nextLine [$path get $start $end]
1698                if {[string match "$levels($tag)    *" $nextLine]} {
1699                     $path delete $start $end
1700                } else {
1701                   break
1702                }
1703            }
1704            $path mark set insert $start
1705            xmlWidgetLoad_Recurs $path 0 $levels($tag) $tag 2
1706            $path see $start
1707        }
1708    }
1709
1710    # that's a hack to remove selections, which occur sometimes
1711    after 50 "$path tag remove sel 1.0 end"
1712}
1713
1714#----------------------------------------------------------------------------
1715#   xmlClose
1716#
1717#----------------------------------------------------------------------------
1718proc xmlClose { path pos } {
1719    global levels
1720    foreach tag [$path tag names $pos] {
1721        if {($tag != "close") && ($tag != "hot") && ($tag != "sel")} {
1722
1723            $path configure -state normal
1724            set start [$path index "$pos linestart"]
1725            set end   [$path index "$start + 1 lines"]
1726            $path delete $start $end
1727
1728            while 1 {
1729                set end   [$path index "$start + 1 lines"]
1730                set nextLine [$path get $start $end]
1731                if {[string match "$levels($tag)    *" $nextLine]} {
1732                     $path delete $start $end
1733                } else {
1734                   break
1735                }
1736            }
1737            $path mark set insert $start
1738            xmlWidgetLoad_Recurs $path 0 $levels($tag) $tag 1
1739            $path see $start
1740        }
1741    }
1742
1743    # that's a hack to remove selections, which occur sometimes
1744    after 50 "$path tag remove sel 1.0 end"
1745}
1746
1747
1748#----------------------------------------------------------------------------
1749#   xmlWidget
1750#
1751#----------------------------------------------------------------------------
1752proc xmlWidget { path } {
1753  
1754    global  Cour12 HelvB12
1755
1756    set tagFont   $HelvB12
1757    set attrFont  $Cour12
1758    set opnclFont $Cour12
1759
1760    frame $path -relief flat -borderwidth 0 -highlightthickness 0
1761
1762    text $path.text -width 100 -height 25 -font $Cour12 \
1763                    -bg gray85 -cursor left_ptr         \
1764                    -exportselection yes  -wrap none    \
1765                    -yscrollcommand "$path.vsb set"     \
1766                    -xscrollcommand "$path.hsb set"
1767
1768    scrollbar $path.vsb -relief sunken  -orient vertical \
1769                        -command "$path.text yview"  
1770
1771    scrollbar $path.hsb -relief sunken  -orient horizontal  \
1772                        -command "$path.text xview" 
1773
1774    pack $path.vsb  -side right  -fill y    -expand no
1775    pack $path.hsb  -side bottom -fill x    -expand no
1776    pack $path.text -side top    -fill both -expand yes 
1777
1778    #$path.text tag configure tag  -font $tagFont            \
1779    #                              -background #ffffa666a666 \
1780    #                              -foreground black
1781
1782    $path.text tag configure tag  -font $tagFont \
1783                                  -foreground #40004000D000
1784
1785    $path.text tag configure comment -font $attrFont           \
1786                                     -background #d000e800d000 \
1787                                     -foreground black
1788
1789    $path.text tag configure textValue -font $attrFont           \
1790                                       -background #d200d200f000 \
1791                                       -foreground black
1792
1793    #$path.text tag configure attr -font $attrFont            \
1794    #                              -background #fae0d53fdaaa  \
1795    #                              -foreground black
1796
1797    #                                 -background #D000D000ffff \
1798    $path.text tag configure attrName -font $attrFont           \
1799                                      -foreground black
1800
1801    #                                 -background #D000D000ffff \
1802    #                                 -background #e800d000d000 \
1803
1804    #                                 -background gray90        \
1805    #                                 -foreground #d00000000000
1806
1807    $path.text tag configure attrValue -font $attrFont           \
1808                                       -background #f000d000d000 \
1809                                       -foreground black         
1810
1811    $path.text tag configure header -background gray90 \
1812                                    -foreground red2   
1813
1814    $path.text tag configure query -background gray95 \
1815                                   -foreground red2   
1816
1817    $path.text tag configure hot  -background #a666a666ffff
1818
1819    $path.text tag configure open  -font $opnclFont 
1820    $path.text tag configure close -font $opnclFont 
1821    $path.text tag configure leave -font $opnclFont 
1822
1823    $path.text tag bind tag   <2>      "xmlJump $path.text @%x,%y"
1824 
1825    $path.text tag bind open  <Enter>  "xmlHighlight $path.text @%x,%y open hot"
1826    $path.text tag bind open  <Motion> "xmlHighlightMotion $path.text @%x,%y open hot"
1827    $path.text tag bind open  <Leave>  "$path.text tag remove hot 1.0 end"
1828    $path.text tag bind open  <1>      "xmlOpen $path.text @%x,%y"
1829
1830    $path.text tag bind close <Enter>  "xmlHighlight $path.text @%x,%y open hot"
1831    $path.text tag bind close <Motion> "xmlHighlightMotion $path.text @%x,%y close hot"
1832    $path.text tag bind close <Leave>  "$path.text tag remove hot 1.0 end"
1833    $path.text tag bind close <1>      "xmlClose $path.text @%x,%y"
1834}
1835
1836
1837#----------------------------------------------------------------------------
1838#   xmlWidgetLoad_Recurs
1839#
1840#----------------------------------------------------------------------------
1841proc xmlWidgetLoad_Recurs { path doSiblings level node maxlevel } {
1842
1843    global levels
1844
1845    incr maxlevel -1
1846    if {$maxlevel < 0} { return }
1847
1848    while {$node != ""} {
1849        
1850        set levels($node) $level
1851
1852        $path insert insert $level
1853
1854        set type [$node nodeType]
1855        if { $type == "ELEMENT_NODE" } {
1856
1857        set firstChild [$node firstChild]
1858
1859        if {$firstChild == ""} {
1860            $path insert insert " = " leave
1861        } else {
1862            if {$maxlevel > 0} {
1863                $path insert insert " - " [list close $node]
1864            } else {
1865                $path insert insert " + " [list open $node]
1866            }
1867        }
1868        $path insert insert "[$node nodeName] " [list tag $node]
1869
1870        set attr_line_width 0
1871        set attr_name_width 0
1872        set attr_value_width [string length $level]
1873        foreach attr [$node attributes] {
1874            if {[llength $attr] > 1} {
1875                if {[lindex $attr 1] == ""} {
1876                    set attr [lindex $attr 0]
1877                } else {
1878                    set attr "[lindex $attr 1]:[lindex $attr 0]"
1879                }
1880            }
1881            set l [string length $attr]
1882            if {$l > $attr_name_width} { 
1883                set attr_name_width $l
1884            }
1885            incr attr_line_width $l
1886            set l [string length [$node getAttribute $attr]]
1887            if {$l > $attr_value_width} {
1888                set attr_value_width $l
1889            }
1890            incr attr_line_width $l
1891        }
1892
1893        set recurseToChilds 1
1894        set attrDisplayMode [expr $attr_line_width > 80]
1895       
1896        if {$attrDisplayMode} {
1897            foreach attr [$node attributes] {
1898                $path insert insert "\n"
1899                $path insert insert "$level    " 
1900                #$path insert insert [format " %-${attr_name_width}s = %-${attr_value_width}s  " \
1901                #                            $attr [$node getAttribute $attr] \
1902                #                    ] attr
1903                if {[llength $attr] > 1} {
1904                    if {[lindex $attr 1] == ""} {
1905                        set attr [lindex $attr 0]
1906                    } else {
1907                        set attr "[lindex $attr 1]:[lindex $attr 0]"
1908                    }
1909                }
1910                $path insert insert [format " %-${attr_name_width}s= " \
1911                                            $attr                      \
1912                                    ] attrName
1913                $path insert insert [$node getAttribute $attr] attrValue
1914                #$path insert insert [format "%-${attr_value_width}s  "    \
1915                #                            '[$node getAttribute $attr]'  \
1916                #                    ] attrValue
1917            }
1918            $path insert insert "\n"
1919        } else {
1920            if {[$node attributes] == ""} {
1921                set childs [$node childNodes] 
1922                if {[llength $childs] == 1} {
1923                    if {[$childs nodeType] == "TEXT_NODE"} {
1924                        set value [$childs nodeValue]
1925                        if {([string length $value] < 60) && 
1926                            ([string first \n $value] == -1)} {
1927
1928                            $path insert insert $value textValue
1929                            set recurseToChilds 0
1930                        }
1931                    }
1932                }
1933            } else {
1934                foreach attr [$node attributes] {
1935                    if {[llength $attr] > 1} {
1936                        if {[lindex $attr 1] == ""} {
1937                            set attr [lindex $attr 0]
1938                        } else {
1939                           set attr "[lindex $attr 1]:[lindex $attr 0]"
1940                        }
1941                    }
1942                    $path insert insert " $attr=" attrName
1943                    $path insert insert [$node getAttribute $attr] attrValue
1944                    #$path insert insert ' attrName
1945                }
1946            }
1947            $path insert insert "\n"
1948        }
1949        set recurseToChilds 1
1950        if {$recurseToChilds} {
1951            foreach child [$node childNodes] {
1952                xmlWidgetLoad_Recurs $path 1 "$level   " $child $maxlevel
1953            }
1954        }
1955        } else {
1956            switch $type {
1957                COMMENT_NODE {
1958                    $path insert insert " C "
1959                    $path insert insert [$node nodeValue] comment
1960                    $path insert insert "\n"
1961                }
1962
1963                CDATA_SECTION_NODE -
1964                TEXT_NODE {
1965                    set lines 0
1966                    foreach line [split [$node nodeValue] \n] {
1967                        if {$lines == 0} {         
1968                            $path insert insert " T "
1969                        } else {
1970                            $path insert insert "$level   "
1971                        }
1972                        if {$line == ""} {
1973                            $path insert insert " " textValue
1974                        } else {
1975                            $path insert insert $line textValue
1976                        }
1977                        $path insert insert "\n"
1978                        incr lines
1979                    }
1980                }
1981
1982                PROCESSING_INSTRUCTION_NODE {
1983                    $path insert insert " P "
1984                    $path insert insert [$node target] tag
1985                    set lines 0
1986                    foreach line [split [$node data] \n] {
1987                        if {$lines == 0} {
1988                            $path insert insert " "
1989                        } else {
1990                            $path insert insert "$level    "
1991                        }
1992                        $path insert insert $line attrValue
1993                        $path insert insert "\n"
1994                        incr lines
1995                    }
1996                }
1997
1998                default {
1999                    $path insert insert " ? "
2000                    $path insert insert [$node nodeValue] attrValue
2001                    $path insert insert "\n"
2002                }
2003            }
2004        }
2005
2006        if {!$doSiblings} {
2007            return
2008        }
2009        break
2010        #set node [$node nextSibling]
2011    }
2012}
2013
2014#----------------------------------------------------------------------------
2015#   xmlWidgetLoad
2016#
2017#----------------------------------------------------------------------------
2018proc xmlWidgetLoad { path mode location xml query } {
2019
2020    global doc root keepEmpties useSimple
2021
2022  if {$mode == "xml"} {
2023    if {$useSimple} {
2024        if {$keepEmpties} { 
2025            set doc [dom parse -keepEmpties -simple $xml]
2026        } else {
2027            set doc [dom parse -simple $xml]
2028        }
2029    } else {
2030        if {$keepEmpties} { 
2031            set doc [dom parse -keepEmpties $xml]
2032        } else {
2033            set doc [dom parse $xml]
2034        }
2035    }
2036  } else {
2037        if {$keepEmpties} { 
2038            set doc [dom parse -keepEmpties -html $xml]
2039        } else {
2040            set doc [dom parse -html $xml]
2041        }
2042  }
2043    set root [$doc documentElement]
2044
2045    set query [string trim $query]
2046    if {$query == ""} {
2047        set query /
2048    }
2049    $path insert end \n
2050    $path insert end xml(      header
2051    $path insert end $location query
2052    $path insert end ") "      header
2053    $path insert end $query    query
2054    $path insert end \n
2055
2056
2057    set nodes 0
2058    set rows  0
2059
2060    set results [$root selectNodes $query type]
2061
2062    switch $type { 
2063        nodes { 
2064            foreach node $results {
2065                $path mark set insert end
2066                xmlWidgetLoad_Recurs $path 1 "" $node 2
2067                $path insert end \n
2068                incr nodes
2069            }
2070        }
2071        attrnodes {
2072            foreach {attrName attrValue} $results {
2073                $path insert end $attrName attrName 
2074                $path insert end " "
2075                $path insert end $attrValue attrValue
2076                $path insert end \n
2077                incr rows
2078            }
2079        }
2080        attrvalues {
2081             foreach result $results {
2082                 $path insert end "$result\n"
2083                 incr rows
2084             }
2085        }
2086        default {
2087             $path insert end "$results\n"
2088        }
2089    }
2090    if {$rows  != 0} { $path insert end "---$rows result(s)---\n" }
2091    if {$nodes != 0} { $path insert end "---$nodes node(s)---\n"  }
2092    $path yview -pickplace end
2093}
2094
2095
2096#----------------------------------------------------------------------------
2097#   xmlReload
2098#
2099#----------------------------------------------------------------------------
2100proc xmlReload { } {
2101    global xml
2102
2103    set xml [.edit.f.text get 1.0 end]
2104
2105    xmlWidgetLoad .xml.text xml $xml
2106}
2107
2108
2109
2110
2111
2112
2113
2114   
2115#----------------------------------------------------------------------------
2116#   GetXML
2117#
2118#----------------------------------------------------------------------------
2119proc GetXML { url } {
2120
2121    global Login HttpProxyHost HttpProxyPort
2122
2123
2124    if {[regexp { *file:(.*)} $url all path]} {
2125        #puts stderr "file path='$path'"
2126        set fd [open $path]
2127        set xml [read $fd [file size $path]]
2128        close $fd
2129    } 
2130    if {[regexp { *http:(.*)} $url all path]} {
2131
2132        #puts stderr "http url='$path'"
2133        set xml      ""
2134        set login    ""
2135        set password ""
2136
2137        #------------------------------------------------------
2138        #    try to re-use old login and password
2139        #
2140        #------------------------------------------------------
2141        regexp {//([^/]*)/(.*)} $url all server file
2142        set indexes [array names Login $server,*]
2143        if {[llength $indexes] == 1} {
2144            foreach { login password } $Login($indexes) break
2145        }
2146
2147        while 1 { 
2148                set hdrs {}
2149                if {$login != ""} {
2150                    #-------------------------------------------
2151                    #   generate Basic Authenication header
2152                    #------------------------------------------
2153                    set hdrs [list Authorization "Basic [Base64Encode $login:$password]" ] 
2154                }
2155                #-------------------------------------------
2156                #   do HTTP request
2157                #------------------------------------------- 
2158                http::config -proxyhost $HttpProxyHost -proxyport $HttpProxyPort 
2159                set token [http::geturl $url -headers $hdrs]
2160   
2161                
2162                #-------------------------------------------
2163                #   wait till HTTP request finishes
2164                #------------------------------------------
2165                http::wait $token
2166                upvar $token state
2167
2168                set statuscode [lindex $state(http) 1]
2169                if {$statuscode != "200"} {
2170                    if {$statuscode == "401"} {
2171                        if {[GetUserPassword state login password]} {
2172                            #puts stderr "login='$login' password='$password'"
2173                            continue
2174                        } else {
2175                            return ""
2176                        }
2177                    } else {
2178                        puts stderr "\n\n\nstatuscode=$statuscode"
2179                        puts stderr "$state(http)"
2180                        break
2181                    }
2182                } else {
2183                    set xml [http::data $token] 
2184                    break
2185                }
2186        }
2187    } 
2188    return $xml
2189}
2190
2191
2192#----------------------------------------------------------------------------
2193#   xmlExecute
2194#
2195#----------------------------------------------------------------------------
2196proc xmlExecute { sel } {
2197
2198    #puts stderr $sel
2199
2200    if {[regexp { *(xml|html)\(([^)]*)\)(.*)} $sel all mode location query]} {
2201        #puts stderr "'$sel' location='$location' query='$query'"
2202       
2203        .pane.output.text configure -cursor watch
2204        .                 configure -cursor watch
2205        update
2206
2207        set xml [GetXML $location]
2208        if {$xml != ""} {
2209            xmlWidgetLoad .pane.output.text $mode $location $xml $query
2210        }
2211        .pane.output.text configure -cursor left_ptr
2212        .                 configure -cursor left_ptr
2213
2214    } else {
2215        error "Not a complete query!!"
2216    }
2217}
2218
2219
2220#----------------------------------------------------------------------------
2221#   GotoParent
2222#
2223#----------------------------------------------------------------------------
2224proc GotoParent { } {
2225
2226    global PointerXY
2227 
2228
2229    set pos  $PointerXY
2230    set path .pane.output.text
2231
2232    foreach tag [$path tag names $pos] {
2233
2234        #puts stderr "tag=$tag"
2235
2236        if {[string match domNode* $tag]} {
2237
2238            set tag [$tag parentNode]
2239            if {$tag == ""} return
2240
2241            $path configure -state normal
2242            set start [$path index "$pos linestart"]
2243            set end   [$path index "$start + 1 lines"]
2244            regexp {$( *)} [$path index "$start + 1 lines"] all level
2245            $path delete $start $end
2246            while 1 {
2247                set end   [$path index "$start + 1 lines"]
2248                set nextLine [$path get $start $end]
2249                if {[string match "$level    *" $nextLine]} {
2250                     $path delete $start $end
2251                } else {
2252                   break
2253                }
2254            }
2255            $path mark set insert $start
2256            xmlWidgetLoad_Recurs $path 0 $level $tag 2
2257            $path see $start
2258        }
2259    }
2260}
2261
2262
2263#----------------------------------------------------------------------------
2264#   As
2265#
2266#----------------------------------------------------------------------------
2267proc As { method } {
2268
2269    global PointerXY
2270 
2271    set path .pane.output.text
2272
2273    foreach tag [$path tag names $PointerXY] {
2274
2275        if {[string match domNode* $tag]} {
2276             set oldEnd [$path index end]
2277             $path insert end \n[$tag $method]
2278             $path see $oldEnd
2279        }
2280    }
2281}
2282
2283
2284#----------------------------------------------------------------------------
2285#   ToXPath
2286#
2287#----------------------------------------------------------------------------
2288proc ToXPath { } {
2289
2290    global PointerXY
2291 
2292    set path .pane.output.text
2293
2294    foreach tag [$path tag names $PointerXY] {
2295
2296        if {[string match domNode* $tag]} {
2297             set oldEnd [$path index end]
2298             $path insert end \n[$tag toXPath]
2299             $path see $oldEnd
2300        }
2301    }
2302}
2303
2304
2305
2306
2307#----------------------------------------------------------------------------
2308#   begin main part
2309#----------------------------------------------------------------------------
2310
2311namespace eval ::dom::xpathFunc {
2312    proc names { ctxNode pos nodeListType nodeList args } {
2313        if {[llength $args] != 2} {
2314            error "wrong # of args for XPATH function 'names'"
2315        } 
2316        foreach { type value } $args break
2317        if {($type != "nodes") && ($type != "attrnodes") } {
2318            error "names only applicable for node or attribute node lists!"
2319        }
2320        set n {}
2321        if {$type == "nodes"} {
2322            foreach node $value { lappend n [$node nodeName] }
2323        } else {
2324            foreach {attrName attrValue} $value { lappend n $attrName }
2325        }
2326        return [list string $n]
2327    }
2328}
2329 
2330  set xe_save   "~/.xe-input"
2331  set xe_config "~/.xe-config"
2332
2333  if {[llength $argv] > 0} {
2334      set xe_save [lindex $argv 0]
2335  }
2336
2337
2338  set bgcolor   "grey90"
2339  set fgcolor   "black"
2340
2341  switch $tcl_platform(platform) {
2342      unix {
2343          set Cour12    8x13
2344          set CourB12   8x13b
2345          set Helv10    "-Adobe-helvetica-medium-r-normal--*-100-*"
2346          set Helv12    "-Adobe-helvetica-medium-r-normal--*-120-*"
2347          set HelvB10   "-Adobe-helvetica-bold-r-normal--*-100-*"
2348          set HelvB12   "-Adobe-helvetica-bold-r-normal--*-120-*"
2349      }
2350      windows {
2351          set Cour12    "{Courier New} 10"
2352          set CourB12   "{Courier New} 10 bold"
2353          set Helv10    "Arial 9"
2354          set Helv12    "Arial 10"
2355          set HelvB10   "Arial 9  bold"
2356          set HelvB12   "Arial 10 bold"
2357      }
2358  }
2359
2360  option add *background                  gray80
2361  option add *foreground                  black
2362  option add *selector                    black
2363  option add *Scrollbar.foreground        #dfdfdf
2364  option add *Scrollbar.activeForeground  #efefef
2365  option add *font                        $HelvB12
2366
2367  wm title . "xe - [lindex $argv 0]"
2368
2369  wm minsize . 30 10
2370  wm geometry  . 80x20
2371
2372  #---------------------------------------
2373  #   set up iconwin
2374  #---------------------------------------
2375  if {$tcl_platform(platform)== "unix"} {
2376      toplevel .icwin
2377      frame .icwin.f -relief flat  -borderwidth 1
2378      label .icwin.f.l1 -text xe -font $Helv12
2379      label .icwin.f.l2 -text  [lindex $argv 0] -font $Helv12
2380      pack  .icwin.f
2381      pack  .icwin.f.l1 .icwin.f.l2 -anchor nw
2382      .icwin configure  -relief ridge -borderwidth 2
2383      wm geometry .icwin 60x60
2384      wm iconwindow . .icwin 
2385  }
2386 
2387  
2388  set keepEmpties 0  
2389  set useSimple   0
2390
2391  frame .menu -relief raised -borderwidth 1 -highlightthickness 0
2392
2393  #-- File --------------
2394
2395  menubutton .menu.file -text " File " -menu .menu.file.m
2396  menu .menu.file.m -tearoff 0                                       
2397    .menu.file.m add command  -label " Clear Input Window "  -command {
2398        .pane.upper.input.text delete 0.0 end 
2399     }
2400    .menu.file.m add separator
2401    .menu.file.m add command -label " Save Output Window in  ~/xe-out" -command { 
2402        SaveTextWindow .pane.output.text "~/xe-out" 
2403    }
2404    .menu.file.m add command -label " Print Output Window" -command { 
2405        PrintDialog 
2406    }
2407    .menu.file.m add separator
2408    .menu.file.m add command -label " Quit without Save" -command  { exit }
2409    .menu.file.m add command -label " Save Input Window in $xe_save" -command { 
2410        SaveTextWindow .pane.upper.input.text $xe_save 
2411    }
2412    .menu.file.m add command -label " Quit and Save Input Window in $xe_save" \
2413    -command  { 
2414        SaveTextWindow .pane.upper.input.text $xe_save
2415        exit   
2416    }   
2417   
2418  #-- Options --------------
2419
2420  menubutton .menu.options -text " Options " -menu .menu.options.m
2421  menu .menu.options.m  -tearoff 0 
2422      .menu.options.m add command -label " http proxy " -command ConfigureProxy
2423      .menu.options.m add check -label " keep empties " \
2424                                -underline 1 -variable  keepEmpties 
2425      .menu.options.m add check -label " use simple parser " \
2426                                -underline 1 -variable  useSimple
2427  pack .menu.file  \
2428       .menu.options -side left
2429
2430  label .menu.info -text "XE " -font $HelvB12
2431  pack  .menu.info -side right
2432
2433
2434
2435  
2436  pane .pane vertical 1000 1000 
2437  .pane configure -highlightthickness 0
2438
2439  frame .pane.upper -borderwidth 0 -highlightthickness 0
2440
2441  frame .pane.upper.input   -borderwidth 2 -highlightthickness 0
2442
2443  text .pane.upper.input.text -relief sunken -bd 2 -height 10 -width 80 \
2444                   -bg $bgcolor  -fg $fgcolor                           \
2445                   -font $Cour12 -padx 2 -pady 2 -setgrid 1             \
2446                   -yscrollcommand ".pane.upper.input.sb set"
2447
2448  .pane.upper.input.text configure -exportselection yes
2449  .pane.upper.input.text tag configure search  -background white -foreground black
2450  scrollbar .pane.upper.input.sb  -relief sunken   -command ".pane.upper.input.text yview"
2451  pack .pane.upper.input.sb     -side right -fill y    -expand no
2452  pack .pane.upper.input.text   -side top   -fill both -expand yes 
2453
2454  xmlWidget .pane.output
2455
2456  
2457  pack .pane.output -side bottom -fill both -expand yes 
2458
2459  frame .pane.upper.buttons  -borderwidth 1 -highlightthickness 0
2460
2461  label  .pane.upper.buttons.searchL -text "   search:" -underline 4 -font $Helv12
2462  entry  .pane.upper.buttons.search  -width 20  -relief sunken -borderwidth 2 \
2463                            -textvariable searchString -exportselection yes   \
2464                            -font $Cour12 -highlightthickness 1 \
2465                            -background  gray90
2466  button .pane.upper.buttons.padb1 -state disabled -relief flat \
2467                                   -highlightthickness 0        \
2468                                   -borderwidth 0 -padx 15 -pady 0 
2469
2470  button .pane.upper.buttons.padb2 -state disabled -relief flat \
2471                                   -highlightthickness 0        \
2472                                    -borderwidth 0 -padx 15 -pady 0
2473
2474  button .pane.upper.buttons.execute -text "execute <sel.>" -command {
2475      set sel [selection get]
2476      if {$sel != ""} {
2477          xmlExecute $sel
2478      }
2479  } -pady 2
2480
2481  button .pane.upper.buttons.clearoutput -text clearoutput -command {
2482       .pane.output.text delete 0.0 en
2483       foreach doc [info commands domDoc*] {
2484           $doc delete
2485       }
2486  } -pady 2
2487
2488
2489  pack .pane.upper.buttons.searchL     \
2490       .pane.upper.buttons.search      \
2491       .pane.upper.buttons.padb1       \
2492       .pane.upper.buttons.execute     \
2493       .pane.upper.buttons.padb2       \
2494       .pane.upper.buttons.clearoutput -side left
2495  pack .pane.upper.buttons -anchor w
2496
2497
2498  pack .pane.upper.input    -side top    -fill both -expand yes  
2499  pack .pane.upper.buttons  -side bottom -fill x    -expand no
2500  pack .pane.upper          -fill both -expand yes
2501
2502  pack .menu   -fill x    -side top   -expand no
2503  pack .pane   -side top  -fill both  -expand yes
2504
2505  pane_place .pane vertical 0.25  .pane.upper .pane.output
2506
2507  bind_emacstext Text
2508
2509
2510  menu .pane.output.m  -tearoff 0
2511  .pane.output.m add command -label " goto parent " -command GotoParent
2512  .pane.output.m add command -label " asXML "       -command "As asXML"
2513  .pane.output.m add command -label " asHTML "      -command "As asHTML"
2514  .pane.output.m add command -label " toXPath "     -command ToXPath
2515
2516  bind .pane.output.text <3> {
2517      .pane.output.text configure -cursor left_ptr
2518      set PointerXY @%x,%y
2519      eval tk_popup .pane.output.m [winfo pointerxy %W]
2520  }
2521    
2522
2523  #--------------------------------------------------------------------
2524  #   search feature
2525  #--------------------------------------------------------------------
2526  set origSearchWin .pane.upper.input.text
2527  .pane.output.text      tag configure search -background white -foreground black  
2528  .pane.upper.input.text tag configure search -background white -foreground black  
2529  bind Text <Control-s> {
2530      global origSearchWin
2531      set origSearchWin %W
2532      focus .pane.upper.buttons.search
2533  }
2534  bind .pane.upper.buttons.search <Control-s> {
2535      set len [string length $searchString]
2536      .pane.upper.input.text tag remove search 0.0 end  
2537      .pane.output.text tag  remove search 0.0 end     
2538      set curinsert [$origSearchWin index insert]
2539      set spos [$origSearchWin search -regexp $searchString insert]
2540      if {$spos != ""} { 
2541          if {[$origSearchWin compare $curinsert == $spos]} {
2542              $origSearchWin mark set insert {insert +1char}
2543          }
2544          set spos [$origSearchWin search -regexp $searchString insert]
2545          if {$spos != ""} { 
2546              $origSearchWin mark set insert $spos
2547              $origSearchWin see insert
2548              $origSearchWin tag add search insert "insert + $len char"
2549          }
2550      }
2551      break
2552  }
2553
2554
2555  #--------------------------------------------------------------------
2556  #   load the xe save file into the input window 
2557  #
2558  #--------------------------------------------------------------------
2559  if {[catch { set f [open $xe_save r ] }] == 0} {
2560      .pane.upper.input.text delete 1.0 end
2561      while { [gets $f i] >= 0 }  {
2562          .pane.upper.input.text insert end $i
2563          .pane.upper.input.text insert end "\n"
2564      }
2565      close $f
2566  }
2567
2568  IntroWindow
2569
2570
2571  # button .startedit -text " Edit plain XML " -font $Helv12 -command xmlEdit
2572  # button .dump -text " dump " -font $Helv12 -command {puts stderr [info commands xmlelem*]}
2573
2574  # pack .xml -fill both -expand yes
2575  # pack .dump .startedit -anchor e
2576
2577  # set fd  [open [lindex $argv 0]] 
2578  # set xml [read $fd]
2579  # close $fd        
2580  # xmlWidgetLoad .pane.output.text $xml
2581
2582
2583#----------------------------------------------------------------------------
2584#   end of main part
2585#----------------------------------------------------------------------------
2586