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