SecuritySNACCRuntime/tcl-lib/snacced.tcl

   1 # file: .../tcl-lib/snacced.tcl
   2 #
   3 # $Header: /cvs/root/Security/SecuritySNACCRuntime/tcl-lib/Attic/snacced.tcl,v 1.1.1.1 2001/05/18 23:14:11 mb Exp $
   4 # $Log: snacced.tcl,v $
   5 # Revision 1.1.1.1  2001/05/18 23:14:11  mb
   6 # Move from private repository to open source repository
   7 #
   8 # Revision 1.1.1.1  1999/03/16 18:06:56  aram
   9 # Originals from SMIME Free Library.
  10 #
  11 # Revision 1.2  1997/02/28 13:39:57  wan
  12 # Modifications collected for new version 1.3: Bug fixes, tk4.2.
  13 #
  14 # Revision 1.1  1997/01/01 23:12:00  rj
  15 # first check-in
  16 #
  17
  18 # todo:
  19 #       int, enum and bit string editors with scrollbar
  20
  21 #\[banner "initialization"]---------------------------------------------------------------------------------------------------------
  22
  23 set version 1.0
  24
  25 #tk colormodel . monochrome
  26
  27 # check all types whether they were marked as PDU.
  28 # collect them in an associative array (indexed by module name)
  29 foreach t [snacc types] \
  30 {
  31   if {[lindex [snacc type $t] 1] == {pdu}} \
  32   {
  33     set module [lindex $t 0]
  34     set type [lindex $t 1]
  35     lappend pdus($module) $type
  36   }
  37 }
  38
  39 #foreach n [array names pdus] \
  40 #{
  41 #  debug "module $n: $pdus($n)"
  42 #}
  43
  44 #\[banner "debugging aid"]----------------------------------------------------------------------------------------------------------
  45
  46 set debug 0
  47
  48 proc debug {text} \
  49 {
  50   global debug
  51   if $debug {puts $text}
  52 }
  53
  54 #\[banner "help texts"]-------------------------------------------------------------------------------------------------------------
  55
  56 set helptext(about) "SnaccEd $version"
  57
  58 set helptext(manoeuv) \
  59 "Button 1
  60   on label
  61     show/hide subnodes (except for lists)
  62   on list
  63     perform action (selected with button 3's popup)
  64
  65 Button 2
  66   on label
  67     open/close value editor
  68   on canvas, list or text
  69     drag view
  70
  71 Button 3
  72   on label
  73     show/hide parent
  74   on list
  75     select action mode (for button 1)
  76   on text
  77     pops up menu for text import/export
  78 "
  79
  80 #\[banner "File loading and saving"]------------------------------------------------------------------------------------------------
  81
  82 # called from file_reload and file_load_from
  83 # clears the display so that only the file's root gets shown
  84 proc file_prune {fileref} \
  85 {
  86   upvar #0 $fileref file
  87
  88   set tree $file(tree)
  89   set handle $file(handle)
  90
  91   list_cleanup /$handle $handle
  92   $tree prune {}
  93
  94   ed_addnode $tree {} {} {} $handle $handle valid
  95   $tree draw
  96 }
  97
  98 # this function is called from the "File" menu.
  99 # it reloads the file contents from its old origin:
 100 proc file_reload {fileref} \
 101 {
 102   set rc 1
 103   upvar #0 $fileref file
 104   # file_prune must be called before the snacc object is modified:
 105   file_prune $fileref
 106   $file(toplevel) config -cursor watch
 107   update idletasks
 108   if {[catch {snacc read $file(handle)} msg]} \
 109   {
 110     tk_dialog .d load "Couldn't reload: $msg" warning 0 Dismiss
 111   } \
 112   else \
 113   {
 114     set file(modified) 0
 115     set rc 0
 116   }
 117   $file(toplevel) config -cursor arrow
 118   return $rc
 119 }
 120
 121 # this function is called from the "File" menu.
 122 # it lets the user select a file and loads its contents
 123 proc file_load_from {fileref} \
 124 {
 125   set rc 1
 126   upvar #0 $fileref file
 127   if {[selbox fn ct]} \
 128   {
 129     # file_prune must be called before the snacc object is modified:
 130     file_prune $fileref
 131     $file(toplevel) config -cursor watch
 132     update idletasks
 133     if {[catch {snacc read $file(handle) $ct $fn} msg]} \
 134     {
 135       tk_dialog .d load "Couldn't load $fn: $msg" warning 0 Dismiss
 136     } \
 137     else \
 138     {
 139       set file(modified) 0
 140       set rc 0
 141     }
 142     $file(toplevel) config -cursor arrow
 143   }
 144   return $rc
 145 }
 146
 147 # this function is called from the "File" menu.
 148 # it saves the file contents to its old origin:
 149 proc file_save {fileref} \
 150 {
 151   set rc 1
 152   upvar #0 $fileref file
 153   $file(toplevel) config -cursor watch
 154   update idletasks
 155   if {[catch {snacc write $file(handle)} msg]} \
 156   {
 157     tk_dialog .d save "Couldn't save: $msg" warning 0 Dismiss
 158   } \
 159   else \
 160   {
 161     set file(modified) 0
 162     set rc 0
 163   }
 164   $file(toplevel) config -cursor arrow
 165   return $rc
 166 }
 167
 168 # this function is called from the "File" menu.
 169 # it lets the user select a file and saves the file's contents
 170 proc file_save_as {fileref} \
 171 {
 172   set rc 1
 173   upvar #0 $fileref file
 174   if {[selbox fn {}]} \
 175   {
 176     $file(toplevel) config -cursor watch
 177     update idletasks
 178     if {[catch {snacc write $file(handle) $fn} msg]} \
 179     {
 180       tk_dialog .d save "Couldn't save $fn: $msg" warning 0 Dismiss
 181     } \
 182     else \
 183     {
 184       set file(modified) 0
 185       set rc 0
 186     }
 187     $file(toplevel) config -cursor arrow
 188   }
 189   return $rc
 190 }
 191
 192 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 193 # this function is called from prune_or_add_children, list_click, new_choice, toggle_se* and set_or_add_root
 194 # it adds the node's children to the display
 195 # some of the children may already be displayed (this is usually the case when the function gets called from list_click or set_or_add_root).
 196 # ed_addnode will be called for every child.
 197
 198 proc ed_expand {tree treepath snaccpath} \
 199 {
 200   set canvas [$tree canvas]
 201
 202   set info [snacc info $snaccpath]
 203   set type [lindex $info 2]
 204
 205   switch $type \
 206   {
 207     SEQUENCE -
 208     SET \
 209     {
 210       debug "$type:"
 211       foreach elem [lindex $info 3] \
 212       {
 213         set name [lindex $elem 0]
 214         set validity [lindex $elem 1]
 215         debug "  $validity $name"
 216         ed_addnode $tree $treepath $treepath $snaccpath $name $name $validity
 217       }
 218     }
 219     SEQUENCE\ OF -
 220     SET\ OF \
 221     {
 222       set len [lindex $info 3]
 223       set varname var:$treepath
 224       upvar #0 $varname var
 225 debug [list treepath=$treepath]
 226 debug [list varname=$varname]
 227 debug [list idlist=$var(idlist)]
 228 debug [list expand list ($type) len=$len]
 229       for {set i 0} {$i < $len} {incr i} \
 230       {
 231         set id [lindex $var(idlist) $i]
 232 debug [list index $i id $id]
 233         if {$id} \
 234         {
 235           ed_addnode $tree $treepath $treepath $snaccpath $id $i valid
 236         }
 237       }
 238     }
 239     CHOICE \
 240     {
 241       set name [lindex $info 3]
 242       set validity [lindex $info 4]
 243       debug "  $validity $name"
 244       ed_addnode $tree $treepath $treepath $snaccpath $name $name $validity
 245     }
 246   }
 247 }
 248
 249 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 250
 251 # ed_addnode is called from set_or_add_root, new_file, file_prune and ed_expand.
 252 # the node may already be displayed (this is usually the case when the function ed_expand gets called from list_click or set_or_add_root). in this case the node gets moved to the right position.
 253 # otherwise the node is created at the right place.
 254
 255 # the arguments are:
 256 #   tree                name of the tree widget
 257 #   treeparent          tag of the displayed parent node. this is usually the same as the treeparentpath, except when the display gets extended into the parent direction where the root tag is {}
 258 #   treeparentpath      tag of the logical parent node.
 259 #   snaccparentpath     names of the
 260 #   treenode            node's name, gets appended to the treeparentpath
 261 #   snaccnode           node's name, gets appended to the snaccparentpath
 262 #   validity
 263
 264 proc ed_addnode {tree treeparent treeparentpath snaccparentpath treenode snaccnode validity} \
 265 {
 266   set canvas [$tree canvas]
 267
 268   set treepath "$treeparentpath/$treenode"
 269   set snaccpath "$snaccparentpath $snaccnode"
 270
 271   if [llength [$canvas find withtag $treepath]] \
 272   {
 273 debug [list movelink $treepath $treeparent]
 274     $tree movelink $treepath $treeparent
 275   } \
 276   else \
 277   {
 278 #debug [list addnode $snaccpath]
 279     if {[llength $snaccparentpath] > 0} \
 280     {
 281       set nodelabeltext $snaccnode
 282     } \
 283     else \
 284     {
 285       set finfo [snacc finfo [string range $snaccpath 1 end]]
 286       if {[lindex $finfo 0] == {}} \
 287       {
 288         set nodelabeltext {(unnamed)}
 289       } \
 290       else \
 291       {
 292         set nodelabeltext [lindex $finfo 0]
 293       }
 294     }
 295     $canvas create text 0 0 -text $nodelabeltext -tags [list $validity-label $treepath $treepath:label]
 296
 297     set line [$canvas create line 0 0 0 0]
 298
 299     # fix for canvas bug: for reverse video, the canvas displays black items on a black background
 300     if {[tk colormodel .] == {monochrome} && [lindex [$canvas config -background] 4] == {black}} \
 301     {
 302       $canvas itemconfigure $treepath -fill white
 303       $canvas itemconfigure $line -fill white
 304     }
 305
 306     if {$validity == {void}} \
 307     {
 308       if {[tk colormodel .] == {color}} \
 309       {
 310         # #b0b0b0 is the light grey of disabled checkbuttons:
 311         $canvas itemconfigure $treepath -fill #b0b0b0
 312         $canvas itemconfigure $line -fill #b0b0b0
 313       } \
 314       else \
 315       {
 316         $canvas itemconfigure $treepath -stipple gray50
 317         $canvas itemconfigure $line -stipple gray50
 318       }
 319     }
 320
 321 debug [list addlink $treeparent $treepath $line]
 322     $tree addlink $treeparent $treepath $line
 323   }
 324 }
 325
 326 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 327 # open/drop subtree
 328 proc prune_or_add_children {canvas} \
 329 {
 330   set tree $canvas.t
 331 #  debug $canvas
 332   set id [$canvas find withtag current]
 333   if {$id == {}} \
 334   {
 335     debug "no item"
 336   } \
 337   else \
 338   {
 339     set treepath [lindex [$canvas gettags $id] 1]
 340     set snaccpath [tree2snacc $treepath]
 341     set type [lindex [snacc info $snaccpath] 2]
 342     switch $type \
 343     {
 344       SEQUENCE\ OF - SET\ OF
 345       {}
 346       default
 347       {
 348 #    debug $treepath
 349         if {[$tree isleaf $treepath]} \
 350         {
 351           debug [list expanding $treepath $snaccpath]
 352           ed_expand $tree $treepath $snaccpath
 353         } \
 354         else \
 355         {
 356           debug [list cutting $treepath]
 357           # !!! list_cleanup usually has to be called with the node that gets removed!
 358           # in this case calling it with the node that stays around doesn't hurt because it is guaranteed not to be a SEQUENCE OF or SET OF type (they are handled a few lines above)
 359           list_cleanup $treepath $snaccpath
 360           $tree prune $treepath
 361         }
 362       }
 363     }
 364   }
 365   $tree draw
 366 }
 367
 368 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 369 # this function has to be called whenever a subtree that may contain SET OF or SEQUENCE of types gets removed from the display
 370 # it must be called *before* the snacc object gets destroyed, the function examines it!
 371 proc list_cleanup {treepath snaccpath} \
 372 {
 373   set info [snacc info $snaccpath]
 374   set type [lindex $info 2]
 375   switch $type \
 376   {
 377     SET - SEQUENCE - CHOICE
 378     {
 379       foreach elem [lindex $info 3] \
 380       {
 381         set name [lindex $elem 0]
 382         set validity [lindex $elem 1]
 383         if {$validity == {valid}} \
 384         {
 385           set subtreepath "$treepath/$name"
 386           set subsnaccpath "$snaccpath $name"
 387           list_cleanup $subtreepath $subsnaccpath
 388         }
 389       }
 390     }
 391     SET\ OF - SEQUENCE\ OF
 392     {
 393       set varname var:$treepath
 394       global $varname
 395 debug [list varname=$varname]
 396       if {[info exists $varname]} \
 397       {
 398         set idlist [set $varname\(idlist)]
 399 debug [list idlist=$idlist]
 400         set i 0
 401         foreach id $idlist \
 402         {
 403           if {$id != 0} \
 404           {
 405             set subtreepath "$treepath/$id"
 406             set subsnaccpath "$snaccpath $i"
 407             list_cleanup $subtreepath $subsnaccpath
 408           }
 409           incr i
 410         }
 411         unset $varname
 412       }
 413     }
 414   }
 415 }
 416
 417 # this function must be called when calling "$tree root $treepath".
 418 # it calls list_cleanup for all nodes that are neither parent nor in the subtree pointed to by $treepath.
 419 proc list_cleanup_not_me {treepath snaccpath} \
 420 {
 421   if {[set i [llength $snaccpath]] > 1} \
 422   {
 423     incr i -1
 424     set parenttreepath [join [lrange [split $treepath /] 0 $i] /]
 425     incr i -1
 426     set parentsnaccpath [lrange $snaccpath 0 $i]
 427
 428     set info [snacc info $parentsnaccpath]
 429     set type [lindex $info 2]
 430     switch $type \
 431     {
 432       SET - SEQUENCE - CHOICE
 433       {
 434         foreach elem [lindex $info 3] \
 435         {
 436           set name [lindex $elem 0]
 437           set validity [lindex $elem 1]
 438           if {$validity == {valid}} \
 439           {
 440             set subparenttreepath "$parenttreepath/$name"
 441             set subparentsnaccpath "$parentsnaccpath $name"
 442             if {$subparenttreepath != $treepath} \
 443             {
 444               list_cleanup $subparenttreepath $subparentsnaccpath
 445             }
 446           }
 447         }
 448       }
 449       SET\ OF - SEQUENCE\ OF
 450       {
 451         set varname var:$parenttreepath
 452         global $varname
 453   debug [list varname=$varname]
 454         set idlist [set $varname\(idlist)]
 455 debug [list idlist=$idlist]
 456         set i 0
 457         foreach id $idlist \
 458         {
 459           if {$id != 0} \
 460           {
 461             set subparenttreepath "$parenttreepath/$id"
 462             set subparentsnaccpath "$parentsnaccpath $i"
 463             if {$subparenttreepath != $treepath} \
 464             {
 465               list_cleanup $subparenttreepath $subparentsnaccpath
 466               set $varname\(idlist) [lreplace [set $varname\(idlist)] $i $i 0]
 467             }
 468           }
 469           incr i
 470         }
 471       }
 472     }
 473     # recursion:
 474     list_cleanup_not_me $parenttreepath $parentsnaccpath
 475   }
 476 }
 477
 478 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 479 # /file0/files/1/name \(-> { file0 files 0 name}
 480
 481 proc tree2snacc {treepath} \
 482 {
 483   set subtreepath {}
 484   foreach elem [lrange [split $treepath /] 1 end] \
 485   {
 486     set treeelem $elem
 487     if {[regexp {^[0-9]} $elem]} \
 488     {
 489       set varname var:$subtreepath
 490       global $varname
 491       set idlist [set $varname\(idlist)]
 492       set id $elem
 493       set index 0
 494       foreach lid $idlist \
 495       {
 496         if {$lid == $id} break
 497         incr index
 498       }
 499       if {$index == [llength $idlist]} \
 500       {
 501         error "tree2snacc: id $id not found in idlist [list $idlist]"
 502       }
 503       set snaccelem $index
 504     } \
 505     else \
 506     {
 507       set snaccelem $elem
 508     }
 509     append subtreepath /$treeelem
 510     append subsnaccpath " $snaccelem"
 511   debug [list >>$subtreepath--$subsnaccpath<<]
 512   }
 513   debug [list >>$subtreepath--$subsnaccpath<<]
 514   return $subsnaccpath
 515 }
 516
 517 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 518 proc import_text {text_w treepath} \
 519 {
 520   if {[selbox fn {}]} \
 521   {
 522     if {[catch {set text [snacc import $fn]} msg]} \
 523     {
 524       tk_dialog .d import "Couldn't import $fn: $msg" warning 0 Dismiss
 525     } \
 526     else \
 527     {
 528       $text_w delete 0.0 end
 529       $text_w insert end $text
 530       snacc set [tree2snacc $treepath] $text
 531     }
 532   }
 533 }
 534
 535 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 536 proc export_text {text_w} \
 537 {
 538   if {[selbox fn {}]} \
 539   {
 540     if {[catch {snacc export [$text_w get 0.0 end] $fn} msg]} \
 541     {
 542       tk_dialog .d import "Couldn't export $fn: $msg" warning 0 Dismiss
 543     }
 544   }
 545 }
 546
 547 proc frame_resize_bindings {fileref treepath} \
 548 {
 549   upvar #0 $fileref file
 550
 551   set frame $file(canvas).edit$treepath
 552
 553   bind $frame <ButtonPress-1> [list frame_resize_start $fileref %x %y]
 554   bind $frame <Button1-Motion> [list frame_resize_cont $fileref $treepath %x %y]
 555   bind $frame <ButtonRelease-1> [list frame_resize_end $fileref $treepath]
 556
 557   $frame config -cursor bottom_right_corner
 558 }
 559
 560 proc frame_resize_start {fileref x y} \
 561 {
 562 #debug [list frame_resize_start $fileref $x $y]
 563
 564   upvar #0 $fileref file
 565
 566   set file(resize_x) $x
 567   set file(resize_y) $y
 568 }
 569
 570 proc frame_resize_cont {fileref treepath x y} \
 571 {
 572 #debug [list frame_resize_cont $fileref $treepath $x $y]
 573
 574   upvar #0 $fileref file
 575
 576   set frame $file(canvas).edit$treepath
 577   set frametag $treepath:edit
 578
 579   set oldw [lindex [$file(canvas) itemconfig $frametag -width] 4]
 580   set oldh [lindex [$file(canvas) itemconfig $frametag -height] 4]
 581 debug "old: $oldw x $oldh"
 582   set neww [max 1 [expr $oldw+$x-$file(resize_x)]]
 583   set newh [max 1 [expr $oldh+$y-$file(resize_y)]]
 584 debug "new: $neww x $newh"
 585   $file(canvas) itemconfig $frametag -width $neww -height $newh
 586   set file(resize_x) $x
 587   set file(resize_y) $y
 588 }
 589
 590 proc frame_resize_end {fileref treepath} \
 591 {
 592 #debug [list frame_resize_end $fileref $treepath]
 593
 594   upvar #0 $fileref file
 595
 596   $file(tree) nodeconfig $treepath
 597   $file(tree) draw
 598 }
 599
 600 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 601 # toggle content editor
 602 proc toggle_editor {canvas} \
 603 {
 604   set tree $canvas.t
 605   set id [$canvas find withtag current]
 606   if {$id == {}} \
 607   {
 608     debug "no item"
 609   } \
 610   else \
 611   {
 612     set treepath [lindex [$canvas gettags $id] 1]
 613     set snaccpath [tree2snacc $treepath]
 614     set frame $canvas.edit$treepath
 615     if [llength [$canvas find withtag $treepath:edit]] \
 616     {
 617 debug "removing editor for [list $treepath]"
 618       $canvas delete $treepath:edit
 619       destroy $frame
 620       $tree nodeconfig $treepath -remove {}
 621     } \
 622     else \
 623     {
 624 debug "opening editor for [list $treepath]"
 625
 626       set fileref [lindex [split $treepath /] 1]
 627
 628       frame $frame -borderwidth 3 -bg #cdb79e
 629       set cleanup [list [list destroy $frame]]
 630
 631       set info [snacc info $snaccpath]
 632       set type [lindex $info 2]
 633
 634       switch $type \
 635       {
 636         NULL \
 637         {
 638           set label $frame.label
 639           label $label -text NULL
 640           pack $label
 641         }
 642         BOOLEAN \
 643         {
 644           set value [snacc get $snaccpath]
 645
 646           set var var:$treepath
 647           global $var
 648           set $var $value
 649
 650           set button $frame.button
 651           #checkbutton $button -variable $var
 652           checkbutton $button -onvalue TRUE -offvalue FALSE -variable $var -textvariable $var -command [list debug [list $canvas $treepath]]
 653           pack $button
 654
 655           trace variable $var w change_simple
 656         }
 657         INTEGER \
 658         {
 659           set value [snacc get $snaccpath]
 660
 661           set var var:$treepath
 662           global $var
 663           set $var $value
 664
 665           if {[lindex $info 0] != {{} {}}} \
 666           {
 667             set typeinfo [snacc type [lindex $info 0]]
 668
 669             foreach elem [lindex $typeinfo 3] \
 670             {
 671               set en [lindex $elem 0]
 672               set ev [lindex $elem 1]
 673               set button $frame.button$en
 674               radiobutton $button -text $en -variable $var -value $ev -anchor w
 675               pack $button -fill x
 676             }
 677           }
 678
 679           set entry $frame.entry
 680           entry $entry -textvariable $var -width 9 -relief sunken
 681
 682           int_entry_bindings $entry
 683
 684           pack $entry -anchor w -fill x
 685
 686           focus $entry
 687
 688           trace variable $var w change_simple
 689         }
 690         ENUMERATED \
 691         {
 692           set typeinfo [snacc type [lindex $info 0]]
 693
 694           if {[catch {set value [snacc get $snaccpath]} msg] == 1} \
 695           {
 696             global errorInfo errorCode
 697             if {$errorCode == {SNACC ILLENUM}} \
 698             {
 699               set value [lindex [lindex $typeinfo 3] 0]
 700               snacc set $snaccpath $value
 701               append msg "--setting to first legal symbolic value \"$value\""
 702               tk_dialog .d illenum "$msg" warning 0 Dismiss
 703             } \
 704             else \
 705             {
 706               error $msg $errorInfo $errorCode
 707             }
 708           }
 709
 710           set var var:$treepath
 711           global $var
 712           set $var $value
 713
 714           foreach ev [lindex $typeinfo 3] \
 715           {
 716             set button $frame.button$ev
 717             radiobutton $button -text $ev -variable $var -value $ev -anchor w
 718             pack $button -fill x
 719           }
 720
 721           trace variable $var w change_simple
 722         }
 723         REAL \
 724         {
 725           set value [snacc get $snaccpath]
 726
 727           set var var:$treepath
 728           global $var
 729           set $var $value
 730
 731           set entry $frame.entry
 732           entry $entry -textvariable $var -relief sunken
 733           pack $entry
 734
 735           frame_resize_bindings $fileref $treepath
 736
 737           focus $entry
 738
 739           trace variable $var w change_simple
 740         }
 741         BIT\ STRING \
 742         {
 743           set value [snacc get $snaccpath]
 744
 745           set var var:$treepath
 746           global $var
 747           set $var $value
 748
 749           set max_ev 0
 750           if {[lindex $info 0] != {{} {}}} \
 751           {
 752             set typeinfo [snacc type [lindex $info 0]]
 753
 754             foreach elem [lindex $typeinfo 3] \
 755             {
 756               set en [lindex $elem 0]
 757               set ev [lindex $elem 1]
 758               set max_ev [max $ev $max_ev]
 759               set button $frame.button$en
 760               checkbutton $button -text $en -variable $var:$ev -command [list toggle_bit $var $ev] -anchor w
 761               pack $button -fill x
 762             }
 763           }
 764
 765           set entry $frame.entry
 766           entry $entry -textvariable $var -relief sunken
 767           set len [max 8 [string length $value] [expr $max_ev + 1]]
 768           if {$len > 0} \
 769           {
 770 debug [list length of entry is $len]
 771             $entry config -width $len
 772           }
 773           pack $entry -anchor w -fill x
 774
 775           bit_string_entry_bindings $entry
 776
 777           focus $entry
 778
 779           trace variable $var w change_bits
 780           set $var $value; # trigger the trace
 781         }
 782         OBJECT\ IDENTIFIER \
 783         {
 784           set value [snacc get $snaccpath]
 785
 786           set var var:$treepath
 787           global $var
 788           set $var $value
 789
 790           set entry $frame.entry
 791           entry $entry -textvariable $var -relief sunken
 792           pack $entry -fill both
 793
 794           frame_resize_bindings $fileref $treepath
 795
 796           focus $entry
 797
 798           trace variable $var w change_simple
 799         }
 800         OCTET\ STRING \
 801         {
 802           set value [snacc get $snaccpath]
 803
 804           set text $frame.text
 805           set sb $frame.sb
 806
 807           text $text -borderwidth 2 -relief sunken -yscrollcommand [list $sb set] -width 32 -height 8
 808           scrollbar $sb -relief sunken -command [list $text yview] -width 10 -cursor arrow
 809
 810           pack $sb -side right -fill y
 811           pack $text -side left -expand true -fill both
 812
 813           bind $text <ButtonPress-2> [list $text scan mark %y]
 814           bind $text <Button2-Motion> [list $text scan dragto %y]
 815
 816           bind $text <Leave> "snacc set \[tree2snacc $treepath\] \[$text get 0.0 end\]"
 817           bind $text <FocusOut> "snacc set \[tree2snacc $treepath\] \[$text get 0.0 end\]"
 818
 819           set m $frame.menu
 820           menu $m
 821           $m add command -label Load... -command "[list import_text $text $treepath]; [list $m unpost]"
 822           $m add command -label Save... -command "[list export_text $text]; [list $m unpost]"
 823
 824           bind $text <ButtonPress-3> "[list $m] post \[expr %X -16\] \[expr %Y -8\]"
 825           bind $m <ButtonPress-3> [list $m unpost]
 826           bind $m <Any-Leave> [list $m unpost]
 827
 828           $text insert end $value
 829           focus $text
 830
 831           frame_resize_bindings $fileref $treepath
 832         }
 833         SEQUENCE -
 834         SET \
 835         {
 836           set typeinfo [snacc type [lindex $info 0]]
 837
 838           debug "$type:"
 839
 840           set varelems [lindex $info 3]
 841           set typeelems [lindex $typeinfo 3]
 842
 843           for {set i 0; set len [llength $varelems]} {$i < $len} {incr i} \
 844           {
 845             set varelem [lindex $varelems $i]
 846             set typeelem [lindex $typeelems $i]
 847
 848             set name [lindex $varelem 0]
 849             set validity [lindex $varelem 1]
 850             debug "  $validity $name"
 851
 852             set var var:$treepath:$name
 853             global $var
 854             set $var $validity
 855
 856             set button $frame.$name
 857             checkbutton $button -text $name -onvalue valid -offvalue void -variable $var -command [list toggle_se* $canvas $treepath $name] -anchor w
 858             if {[lindex $typeelem 4] == {mandatory}} \
 859             {
 860               #$button configure -disabledforeground [lindex [$button configure -fg] 4] -state disabled
 861               $button configure -state disabled
 862             }
 863             pack $button -fill x
 864           }
 865         }
 866         SEQUENCE\ OF -
 867         SET\ OF \
 868         {
 869           set len [lindex $info 3]
 870
 871           set varname var:$treepath
 872           upvar #0 $varname var
 873           if {![info exists var(idlist)]} \
 874           {
 875             set var(idlist) {}
 876             set var(lastid) 0
 877           }
 878           # no! needs a longer lifetime!
 879           #lappend cleanup [list global $varname] [list unset $varname]
 880
 881 #         set mbar $frame.mbar
 882           set list $frame.list
 883           set sb $frame.sb
 884
 885           scrollbar $sb -command [list $list yview] -width 10 -relief sunken -cursor arrow
 886 #         listbox $list -yscroll [list $sb set] -relief sunken -width 4 -height 5
 887           text $list -borderwidth 2 -relief sunken -yscrollcommand [list $sb set] -width 4 -height 8 -exportselection 0
 888           pack $sb -side right -fill y
 889           pack $list -side left -expand true -fill both
 890
 891 #         frame $mbar -relief raised -bd 2
 892 #         pack $mbar -side top -fill x
 893
 894 #         set mode $mbar.mode
 895 #         set mode $frame.mode
 896 #         set m $mode.m
 897 #         menubutton $mode -text Mode -menu $m
 898           set m $frame.mode
 899           menu $m
 900           set lm "[list list_mode $canvas $treepath]; [list $m unpost]"
 901           $m add radiobutton -label Display -variable ${varname}(mode) -value display -command $lm
 902           $m invoke last
 903           $m add radiobutton -label Insert -variable ${varname}(mode) -value insert -command $lm
 904           $m add radiobutton -label Append -variable ${varname}(mode) -value append -command $lm
 905           $m add radiobutton -label Delete -variable ${varname}(mode) -value delete -command $lm
 906 #         pack $mode -side left
 907
 908 #         pack $mode -side top -fill x
 909
 910           $list tag config display -background #b2dfee -relief raised
 911           bind $list <Button-1> [list list_click $canvas $treepath]
 912           bind $list <Double-Button-1> { }
 913           bind $list <Triple-Button-1> { }
 914           bind $list <Button1-Motion> { }
 915
 916           bind $list <ButtonPress-3> "[list $m] post \[expr %X-16\] \[expr %Y-8\]"
 917           bind $m <ButtonPress-3> [list $m unpost]
 918           bind $m <Any-Leave> [list $m unpost]
 919           debug $m
 920
 921           for {set i 0} {$i < $len} {incr i} \
 922           {
 923             $list insert end [format "%4d\n" $i]
 924
 925             if {[llength $var(idlist)] > $i} \
 926             {
 927               if {[set id [lindex $var(idlist) $i]]} \
 928               {
 929                 set line [expr $i + 1]
 930                 $list tag add display $line.0 $line.end
 931               }
 932             } \
 933             else \
 934             {
 935               set var(idlist) [linsert $var(idlist) $i 0]
 936             }
 937           }
 938
 939           frame_resize_bindings $fileref $treepath
 940         }
 941         CHOICE \
 942         {
 943           set name [lindex $info 3]
 944           set validity [lindex $info 4]
 945           set typeinfo [snacc type [lindex $info 0]]
 946
 947           set var var:$treepath
 948           set oldvar oldvar:$treepath
 949           global $var $oldvar
 950           set $var $name
 951           set $oldvar $name
 952
 953           foreach elem [lindex $typeinfo 3] \
 954           {
 955             set en [lindex $elem 0]
 956             set button $frame.button$en
 957             radiobutton $button -text $en -variable $var -value $en -command [list new_choice $canvas $treepath] -anchor w
 958             pack $button -fill x
 959           }
 960           debug "  $validity $name"
 961         }
 962         default \
 963         {
 964           error "unexpected type $type"
 965         }
 966       }
 967
 968       scan [$canvas bbox $treepath:label] "%d%d%d%d" lx uy rx ly
 969       $canvas create window $lx $ly -anchor nw -tags [list edit $treepath $treepath:edit] -window $frame
 970
 971       update idletasks;         # calculate frame's size (needed by tree widget)
 972
 973       # explicitly set the frame's width&height to avoid nasty effects when resizing:
 974       scan [$canvas bbox $treepath:edit] "%d%d%d%d" lx uy rx ly
 975       $canvas itemconfig $treepath:edit -width [expr $rx - $lx] -height [expr $ly - $uy]
 976
 977 #debug [list cleanup = [join $cleanup \;]]
 978       $tree nodeconfig $treepath -remove [join $cleanup \;]
 979     }
 980   }
 981   $tree draw
 982 }
 983
 984 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 985 proc list_click {canvas treepath} \
 986 {
 987   set tree $canvas.t
 988   set snaccpath [tree2snacc $treepath]
 989
 990 debug [list treepath=$treepath]
 991 debug [list snaccpath=$snaccpath]
 992 debug [list tree2snacc: [tree2snacc $treepath]]
 993   set varname var:$treepath
 994   upvar #0 $varname var
 995   set frame $canvas.edit$treepath
 996   set list $frame.list
 997
 998   debug [list list_click: $list]
 999 debug [list varname=$varname]
1000 debug [list idlist=$var(idlist)]
1001 #  debug [$list tag ranges display]
1002   set text_index [$list index current]
1003 #debug [list index: $index]
1004   if {$text_index != ""} \
1005   {
1006     # strip the column number:
1007     set line [lindex [split $text_index .] 0]
1008     # lines numbers start at 1, indices at 0:
1009     set index [expr $line - 1]
1010     set len [llength $var(idlist)]
1011     set tags [$list tag names $text_index]
1012     switch $var(mode) \
1013     {
1014       display \
1015       {
1016 debug [list tags: $tags]
1017 debug [list line: $line]
1018         if {$index < $len} \
1019         {
1020           set id [lindex $var(idlist) $index]
1021 debug [list index $index id $id]
1022           if {$id} \
1023           {
1024             $list tag remove display $line.0 $line.end
1025             list_cleanup $treepath/$id "$snaccpath $index"
1026 debug [list $tree rmlink $treepath/$id]
1027             $tree rmlink $treepath/$id
1028             set var(idlist) [lreplace $var(idlist) $index $index 0]
1029           } \
1030           else \
1031           {
1032             $list tag add display $line.0 $line.end
1033             set var(idlist) [lreplace $var(idlist) $index $index [incr var(lastid)]]
1034             ed_expand $tree $treepath $snaccpath
1035           }
1036         }
1037       }
1038       insert -
1039       append \
1040       {
1041         if {$var(mode) == {append}} {incr index}
1042 debug [list insert $index 0]
1043         set var(idlist) [linsert $var(idlist) $index 0]
1044 debug [list $var(idlist)]
1045 debug [list catch [list snacc set "$snaccpath {insert $index}" {}]]
1046         catch [list snacc set "$snaccpath {insert $index}" {}]
1047         set file(modified) 1
1048 debug [list [snacc get $snaccpath]]
1049
1050         $list insert end [format "%4d\n" [expr [lindex [split [$list index end] .] 0] - 1]]
1051
1052         for {set i $len} {$i > $index} {incr i -1} \
1053         {
1054           set line [expr $i + 1]
1055           if {[set id [lindex $var(idlist) $i]]} \
1056           {
1057 debug [list $canvas itemconfigure $treepath/$id:label -text $i]
1058             $canvas itemconfigure $treepath/$id:label -text $i
1059             if {![lindex $var(idlist) [expr $i - 1]]} \
1060             {
1061 debug [list $list tag add display $line.0 $line.end]
1062               $list tag add display $line.0 $line.end
1063             }
1064           } \
1065           else \
1066           {
1067             if {![lindex $var(idlist) [expr $i - 1]]} \
1068             {
1069 debug [list $list tag remove display $line.0 $line.end]
1070               $list tag remove display $line.0 $line.end
1071             }
1072           }
1073         }
1074         set line [expr $index + 1]
1075 debug [list $list tag remove display $line.0 $line.end]
1076         $list tag remove display $line.0 $line.end
1077       }
1078       delete \
1079       {
1080         if {$index < $len} \
1081         {
1082 debug [list delete $index]
1083
1084           if {[set id [lindex $var(idlist) $index]]} \
1085           {
1086             # list_cleanup must be called before the snacc object is modified:
1087             list_cleanup $treepath/$id "$snaccpath $index"
1088             $tree rmlink $treepath/$id
1089           }
1090           incr len -1
1091           for {set i $index} {$i < $len} {incr i} \
1092           {
1093             set line [expr $i + 1]
1094             if {[set id [lindex $var(idlist) [expr $i + 1]]]} \
1095             {
1096 debug [list $canvas itemconfigure $treepath/$id:label -text $i]
1097               $canvas itemconfigure $treepath/$id:label -text $i
1098               if {![lindex $var(idlist) $i]} \
1099               {
1100 debug [list $list tag add display $line.0 $line.end]
1101                 $list tag add display $line.0 $line.end
1102               }
1103             } \
1104             else \
1105             {
1106               if {[lindex $var(idlist) $i]} \
1107               {
1108 debug [list $list tag remove display $line.0 $line.end]
1109                 $list tag remove display $line.0 $line.end
1110               }
1111             }
1112           }
1113
1114           set var(idlist) [lreplace $var(idlist) $index $index]
1115 debug [list $var(idlist)]
1116 debug [list snacc unset "$snaccpath $index"]
1117           snacc unset "$snaccpath $index"
1118           set file(modified) 1
1119 debug [list [snacc get $snaccpath]]
1120           $list delete [$list index {end - 1 line}] [$list index end]
1121         }
1122       }
1123     }
1124     $tree draw
1125   }
1126 }
1127
1128 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1129 proc list_mode {canvas treepath} \
1130 {
1131   set var var:$treepath
1132   global $var
1133   set mode [set ${var}(mode)]
1134   set frame $canvas.edit$treepath
1135   set list $frame.list
1136
1137   switch $mode \
1138   {
1139     display {set cursor arrow}
1140     insert {set cursor based_arrow_up}
1141     append {set cursor based_arrow_down}
1142     delete {set cursor pirate}
1143   }
1144   $list config -cursor $cursor
1145
1146   debug [list list_mode: ${var}(mode) set to $mode]
1147 }
1148
1149 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1150 proc toggle_bit {var i} \
1151 {
1152   global $var:$i $var
1153   set bit [set $var:$i]
1154   set val [set $var]
1155
1156 debug [list toggle_bit $val $i to $bit]
1157
1158   set pre [string range $val 0 [expr $i - 1]]
1159
1160   set fill {}
1161   for {set l [string length $val]} {$l < $i} {incr l} \
1162   {
1163     append fill 0
1164 debug [list appending: $val]
1165   }
1166
1167   set post [string range $val [expr $i + 1] end]
1168
1169 debug [list toggle_bit combining $pre $fill $bit $post]
1170   set $var $pre$fill$bit$post
1171 }
1172
1173 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1174 proc change_bits {var element op} \
1175 {
1176   global $var
1177   set val [set $var]
1178 debug [list change_bits $var set to $val]
1179
1180 debug [list set l [string length $val]]
1181   set l [string length $val]
1182   for {set i 0} {$i < $l} {incr i} \
1183   {
1184     global $var:$i
1185     if {[info exists $var:$i]} \
1186     {
1187 debug [list set $var:$i [string index $val $i]]
1188       set $var:$i [string index $val $i]
1189     } \
1190     else \
1191     {
1192 debug [list non-exist: $var:$i]
1193     }
1194   }
1195
1196   foreach bitvar [info globals $var:*] \
1197   {
1198     set i [lindex [split $bitvar :] 2]
1199     if {$i >= $l} \
1200     {
1201       global $bitvar
1202       set $bitvar 0
1203     }
1204   }
1205
1206   change_simple $var $element $op
1207 }
1208
1209 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1210 proc change_simple {var element op} \
1211 {
1212   global $var
1213   set val [set $var]
1214 debug [list change_simple $var set to $val]
1215
1216   set treepath [lindex [split $var :] 1]
1217 debug [list treepath= $treepath]
1218   set fileref [lindex [split $treepath /] 1]
1219   upvar #0 $fileref file
1220   set canvas $file(canvas)
1221 debug [list canvas= $canvas]
1222   set snaccpath [tree2snacc $treepath]
1223 debug [list snaccpath= $snaccpath]
1224   snacc set $snaccpath $val
1225   set file(modified) 1
1226 }
1227
1228 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1229 proc new_choice {canvas treepath} \
1230 {
1231   set tree $canvas.t
1232   set snaccpath [tree2snacc $treepath]
1233
1234   set var var:$treepath
1235   set oldvar oldvar:$treepath
1236   global $var $oldvar
1237   set val [set $var]
1238   set oldval [set $oldvar]
1239
1240   set fileref [lindex [split $treepath /] 1]
1241   upvar #0 $fileref file
1242
1243 debug "$file(modified)"
1244   debug [list new choice: $snaccpath = $val]
1245
1246   # list_cleanup must be called before the snacc object is modified:
1247   list_cleanup $treepath/$oldval "$snaccpath $oldval"
1248
1249   catch {snacc set $snaccpath [list $val {}]}
1250   set file(modified) 1
1251 debug "$file(modified)"
1252
1253   if {[llength [$canvas find withtag "$treepath/$oldval"]]} \
1254   {
1255     $tree rmlink "$treepath/$oldval"
1256     ed_expand $tree $treepath $snaccpath
1257     $tree draw
1258   }
1259
1260   set $oldvar $val
1261 }
1262
1263 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1264 proc toggle_se* {canvas treepath name} \
1265 {
1266   set tree $canvas.t
1267   set snaccpath [tree2snacc $treepath]
1268
1269   set var var:$treepath:$name
1270   global $var
1271   set val [set $var]
1272
1273   set fileref [lindex [split $treepath /] 1]
1274   upvar #0 $fileref file
1275
1276   debug "$snaccpath $name = $val"
1277
1278   # this procedure is called after the button value has changed, so adjust the display to the current (new) setting:
1279   if {$val == {void}} \
1280   {
1281     # (change valid \(-> void)
1282     # list_cleanup must be called before the snacc object is modified:
1283     list_cleanup $treepath/$name "$snaccpath $name"
1284     snacc unset "$snaccpath $name"
1285   } \
1286   else \
1287   {
1288     # (change void \(-> valid)
1289     catch {snacc set "$snaccpath $name" {}}
1290   }
1291   set file(modified) 1
1292
1293   if {[llength [$canvas find withtag "$treepath/$name"]]} \
1294   {
1295 debug [list rmlink "$treepath/$name"]
1296     $tree rmlink "$treepath/$name"
1297     # a bug in the tree widget requires us to redraw here:
1298       $tree draw
1299     ed_expand $tree $treepath $snaccpath
1300     $tree draw
1301   }
1302 }
1303
1304 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1305 # add/drop parent and siblings
1306 proc set_or_add_root {canvas} \
1307 {
1308   set tree $canvas.t
1309   set id [$canvas find withtag current]
1310   if {$id == {}} \
1311   {
1312     debug "no item"
1313   } \
1314   else \
1315   {
1316     set treepath [lindex [$canvas gettags $id] 1]
1317     set snaccpath [tree2snacc $treepath]
1318 #    debug $path
1319     if {[llength $snaccpath] == 1} \
1320     {
1321       debug "at root already"
1322     } \
1323     else \
1324     {
1325       if {[$tree isroot $treepath]} \
1326       {
1327         # show the parent:
1328 debug [list expanding [list $treepath $snaccpath]]
1329         set i [llength $snaccpath]
1330
1331         incr i -1
1332
1333         set treeparentpath [join [lrange [split $treepath /] 0 $i] /]
1334         set treeparentnode [lindex [split $treepath /] $i]
1335         incr i -1
1336         set snaccparentpath [lrange $snaccpath 0 $i]
1337         set snaccparentnode [lindex $snaccpath $i]
1338
1339         set treeparentparentpath [join [lrange [split $treepath /] 0 $i] /]
1340         incr i -1
1341         set snaccparentparentpath [lrange $snaccpath 0 $i]
1342
1343 #debug [list ed_addnode $tree {} $parentparentpath $parentnode valid]
1344         ed_addnode $tree {} $treeparentparentpath $snaccparentparentpath $treeparentnode $snaccparentnode valid
1345 #debug [list ed_expand $tree $parentpath]
1346         ed_expand $tree $treeparentpath $snaccparentpath
1347       } \
1348       else \
1349       {
1350         # hide everything above this subtree:
1351 #       debug "cutting $path"
1352         list_cleanup_not_me $treepath $snaccpath
1353         $tree root $treepath
1354       }
1355 #      debug [snacc info $path]
1356     }
1357   }
1358   $tree draw
1359 }
1360
1361 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1362 proc file_open {} \
1363 {
1364   if {[selbox fn ct nullfn]} \
1365   {
1366 debug "fn=$fn ct=$ct"
1367     if {$fn != {}} \
1368     {
1369       if {[catch {set f [snacc open $ct $fn create]} msg]} \
1370       {
1371         tk_dialog .d load "Couldn't open $fn {$ct}: $msg" warning 0 Dismiss
1372         return -1
1373       }
1374     } \
1375     else \
1376     {
1377       if {[catch {set f [snacc create $ct]} msg]} \
1378       {
1379         tk_dialog .d create "Couldn't create {$ct}: $msg" warning 0 Dismiss
1380         return -1
1381       }
1382     }
1383     new_file $f
1384     return 0
1385   }
1386   return -1
1387 }
1388
1389 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
1390
1391 set #file 0
1392 set #files 0
1393
1394 # returns 1 on `cancel', otherwise exits or returns 0
1395 proc close_file {fileref} \
1396 {
1397   upvar #0 $fileref file
1398
1399   if {$file(modified)} \
1400   {
1401     set fi [snacc finfo $file(handle)]
1402     set fn [lindex $fi 0]
1403     set hasfn [expr {$fn != {}}]
1404     set isrw [expr {[lindex $fi 1] == {rw}}]
1405     set msg {There are unsaved changes}
1406     if {$hasfn} \
1407     {
1408       append msg " in `$fn'"
1409     }
1410     append msg {. Save them?}
1411     switch [lindex {save discard cancel} [tk_dialog .d modified $msg questhead 0 Yes No Cancel]] \
1412     {
1413       cancel \
1414       {
1415         return 1
1416       }
1417       save \
1418       {
1419         if {$hasfn && $isrw} \
1420         {
1421           if {[file_save $fileref]} \
1422           {
1423             return 1
1424           }
1425         } \
1426         else \
1427         {
1428           if {[file_save_as $fileref]} \
1429           {
1430             return 1
1431           }
1432         }
1433       }
1434     }
1435   }
1436
1437   destroy $file(toplevel)
1438   global #files
1439   if {![incr #files -1]} \
1440   {
1441     exit
1442   }
1443   return 0
1444 }
1445
1446 proc file_quit {} \
1447 {
1448   global #files
1449   for {set i 0} {${#files}} {incr i} \
1450   {
1451     if {[winfo exists .[set fileref file$i]]} \
1452     {
1453       if {[close_file $fileref]} \
1454       {
1455         return
1456       }
1457     }
1458   }
1459 }
1460
1461 proc new_file {handle} \
1462 {
1463   global #file
1464
1465   while {[winfo exists [set toplevel .[set fileref file${#file}]]]} \
1466   {
1467     incr #file
1468   }
1469
1470   #global $fileref
1471   upvar #0 $fileref file
1472
1473   set file(handle) $handle
1474
1475   set file(toplevel) [toplevel $toplevel]
1476   wm title $toplevel snaccEd
1477   wm minsize $toplevel 150 100
1478   wm geometry $toplevel 500x500
1479
1480   global #files
1481   incr #files
1482
1483   set file(modified) 0
1484
1485   $toplevel config -cursor arrow
1486
1487   set menubar $toplevel.menu
1488   frame $menubar -relief raised -bd 2
1489   pack $menubar -side top -fill x
1490
1491   set filem $menubar.file
1492   set m $filem.m
1493   menubutton $filem -text File -menu $m
1494   menu $m
1495   $m add command -label Reload -command [list file_reload $fileref]
1496   $m add command -label Load... -command [list file_load_from $fileref]
1497   $m add command -label Save -command [list file_save $fileref]
1498   $m add command -label {Save As...} -command [list file_save_as $fileref]
1499   $m add command -label Close -command [list close_file $fileref]
1500   $m add separator
1501   $m add command -label Open... -command file_open
1502   $m add separator
1503   $m add command -label Quit -command file_quit
1504   set fi [snacc finfo $handle]
1505   set hasnofn [expr {[lindex $fi 0] == {}}]
1506   set isro [expr {[lindex $fi 1] == {ro}}]
1507   if {$hasnofn} \
1508   {
1509     $m entryconfigure Reload -state disabled
1510   }
1511   if {$hasnofn || $isro} \
1512   {
1513     $m entryconfigure Save -state disabled
1514   }
1515   pack $filem -side left
1516
1517   set help $menubar.help
1518   set m $help.m
1519   menubutton $help -text Help -menu $help.m
1520   menu $m
1521   $m add command -label About -command "help [list $m] \$helptext(about)"
1522   $m add command -label Manoeuvering -command "help [list $m] \$helptext(manoeuv)"
1523   pack $help -side right
1524
1525   tk_menuBar $menubar $filem $help
1526
1527   frame $toplevel.f0
1528   frame $toplevel.f1
1529
1530   pack $toplevel.f0 -expand true -fill both
1531   pack $toplevel.f1 -fill x
1532
1533   set file(canvas) [set canvas [canvas $toplevel.c -width 0 -height 0]]
1534
1535   set hsb [scrollbar $toplevel.hsb -orient horiz -relief sunken -command [list $canvas xview]]
1536   set vsb [scrollbar $toplevel.vsb -relief sunken -command [list $canvas yview]]
1537
1538   $canvas config -xscroll [list $hsb set] -yscroll [list $vsb set]
1539
1540   set blind [frame $toplevel.blind -width [lindex [$vsb config -width] 4]]
1541
1542   pack $vsb -in $toplevel.f0 -side right -fill y
1543   pack $canvas -in $toplevel.f0 -side left -expand true -fill both
1544
1545   pack $blind -in $toplevel.f1 -side right
1546   pack $hsb -in $toplevel.f1 -side left -expand true -fill x
1547
1548   bind $canvas <ButtonPress-2> [list $canvas scan mark %x %y]
1549   bind $canvas <Button2-Motion> [list $canvas scan dragto %x %y]
1550
1551   $canvas bind valid-label <Button-1> {prune_or_add_children %W}
1552   $canvas bind valid-label <Button-2> {toggle_editor %W}
1553   $canvas bind valid-label <Button-3> {set_or_add_root %W}
1554
1555   set file(tree) [set tree [tree $canvas.t]]
1556
1557   ed_addnode $tree {} {} {} $handle $handle valid
1558
1559   $tree draw
1560
1561   tkwait visibility $toplevel
1562 }
1563
1564 proc snacced {} \
1565 {
1566   wm withdraw .
1567
1568   global argc argv
1569
1570   if {$argc == 0} \
1571   {
1572     if {[file_open]} \
1573     {
1574       exit 1
1575     }
1576   } \
1577   else \
1578   {
1579     if {$argc == 3} \
1580     {
1581       set ct [lrange $argv 0 1]
1582       set fn [lindex $argv 2]
1583       if {[catch {set f [snacc open $ct $fn create]} msg]} \
1584       {
1585         tk_dialog .d load "Couldn't open $fn {$ct}: $msg" warning 0 Dismiss
1586         exit 1
1587       }
1588     } \
1589     elseif {$argc == 2} \
1590     {
1591       set ct [lrange $argv 0 1]
1592       if {[catch {set f [snacc create $ct]} msg]} \
1593       {
1594         tk_dialog .d create "Couldn't create {$ct}: $msg" warning 0 Dismiss
1595         exit 1
1596       }
1597     } \
1598     else \
1599     {
1600       exit 1
1601     }
1602     new_file $f
1603   }
1604 }