SecuritySNACCRuntime/tcl-lib/selbox.tcl

   1 # file: selbox.tcl
   2 # file and content type selection box (ASN.1)
   3 #
   4 # $Header: /cvs/root/Security/SecuritySNACCRuntime/tcl-lib/Attic/selbox.tcl,v 1.1.1.1 2001/05/18 23:14:10 mb Exp $
   5 # $Log: selbox.tcl,v $
   6 # Revision 1.1.1.1  2001/05/18 23:14:10  mb
   7 # Move from private repository to open source repository
   8 #
   9 # Revision 1.1.1.1  1999/03/16 18:06:56  aram
  10 # Originals from SMIME Free Library.
  11 #
  12 # Revision 1.2  1997/02/28 13:39:56  wan
  13 # Modifications collected for new version 1.3: Bug fixes, tk4.2.
  14 #
  15 # Revision 1.1  1997/01/01 23:11:59  rj
  16 # first check-in
  17 #
  18
  19 proc selbox_newfn {sbref} \
  20 {
  21   upvar #0 $sbref sb
  22
  23   set fn $sb(toplevel).f.fn.name
  24
  25   set name [$fn get]
  26
  27   debug $name
  28 }
  29
  30 proc selbox_newbase {sbref} \
  31 {
  32   global $sbref
  33   upvar #0 $sbref sb
  34
  35   set fb_list $sb(toplevel).f.lists.basename
  36   set bs [$fb_list curselection]
  37   if {[llength $bs] == 1} \
  38   {
  39     set base [$fb_list get $bs]
  40
  41 debug base=$base
  42     set path [split $sb(fn) /]
  43     set len [llength $path]
  44     set last [expr $len-1]
  45 debug len=$len
  46     if {$base == {..}} \
  47     {
  48       if {$len == 0} \
  49       {
  50         set $sbref\(fn) ..
  51       } \
  52       else \
  53       {
  54 #       set sb [join [lrange $path 0 $last] /]
  55         if {[lindex $path $last] == {..}} \
  56         {
  57           append $sbref\(fn) /..
  58         } \
  59         else \
  60         {
  61           set $sbref\(fn) [join [lrange $path 0 $last] /]
  62         }
  63       }
  64     } \
  65     else \
  66     {
  67       if {$len == 0} \
  68       {
  69         set $sbref\(fn) $base
  70       } \
  71       else \
  72       {
  73 incr last -1
  74 #       set sb [join [concat [lrange $path 0 $last] $base] /]
  75 debug [list set $sbref\(fn) [join [concat [lrange $path 0 $last] $base] /]]
  76         set $sbref\(fn) [join [concat [lrange $path 0 $last] $base] /]
  77       }
  78     }
  79 debug "sb(fn)=$sb(fn)"
  80   }
  81 }
  82
  83 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
  84 proc selbox_update {name elem op} \
  85 {
  86 debug ">selbox_update $name $elem $op"
  87   upvar #0 $name sb
  88
  89 #debug "$name=$sb"
  90   set fb_list $sb(toplevel).f.lists.basename
  91   $fb_list delete 0 end
  92   $fb_list insert 0 ..
  93   set dir [file dirname $sb(fn)]
  94   set base [file tail $sb(fn)]
  95   set names [lsort [glob $dir/{.*,*}]]
  96   foreach name $names \
  97   {
  98     set name [file tail $name]
  99 #    debug $name
 100     if {$name != {.} && $name != {..}} \
 101     {
 102       $fb_list insert end $name
 103       if {$name == $base} \
 104       {
 105         $fb_list select from end
 106         $fb_list yview end
 107       }
 108     }
 109   }
 110 }
 111
 112 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 113 proc selbox_tm_click {sbref} \
 114 {
 115   upvar #0 $sbref sb
 116
 117   global pdus
 118
 119   set t $sb(toplevel).t.lists
 120   set tm $t.modules
 121   set tt $t.types
 122
 123   set ms [$tm curselection]
 124   if {[llength $ms] == 1} \
 125   {
 126     $tt delete 0 end
 127     eval $tt insert 0 $pdus([$tm get $ms])
 128   }
 129 }
 130
 131 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 132 proc selbox_ok {sbref} \
 133 {
 134   upvar #0 $sbref sb
 135
 136   set fn $sb(toplevel).f.fn.name
 137   set t $sb(toplevel).t.lists
 138   set m $t.modules
 139   set t $t.types
 140
 141   if {$sb(want_fn) && $sb(fn) == {} && $sb(force_fn)} \
 142   {
 143     tk_dialog .d {select filename} "You need to enter a file name" warning 0 Ok
 144     return
 145   }
 146
 147   if {$sb(want_ct)} \
 148   {
 149     set ms [$m curselection]
 150     set ts [$t curselection]
 151
 152     if {[llength $ms] == 1 && [llength $ts] == 1} \
 153     {
 154       set sb(ct) "[$m get $ms] [$t get $ts]"
 155     } \
 156     else \
 157     {
 158       tk_dialog .d {select content type} "You need to select a content type" warning 0 Ok
 159       return
 160     }
 161   }
 162
 163   set sb(rc) 1
 164   destroy $sb(toplevel)
 165 }
 166
 167 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 168 proc selbox_cancel {sbref} \
 169 {
 170   upvar #0 $sbref sb
 171
 172   set sb(rc) 0
 173   destroy $sb(toplevel)
 174 }
 175
 176 #\[sep]-----------------------------------------------------------------------------------------------------------------------------
 177 # the selbox (short for `file and content type selection box')
 178 # selbox has to be called with two arguments, which may be either empty or be the name of a global variable.
 179 # the selbox can display two sections: one for selecting a file name, a second for selecting a content type.
 180 # the selbox arguments denote the variable names for the the two sections.
 181 # if a variable name is empty, its corresponding section will not be displayed.
 182 # if filename_ref is non-empty, a filename will forced to be entered unless `nullfn' is given in args.
 183
 184 # the 1x1 geometry for the listboxes below allows them to shrink when the selbox is resized.
 185 # (otherwise, the buttons and the second listbox will disappear!)
 186
 187 set #sb 0
 188
 189 proc selbox {filename_ref conttype_ref args} \
 190 {
 191   # change this if you get widget or variable name collisions:
 192   set prefix selbox
 193
 194   # choose a unique variable and widget name:
 195   global #sb
 196   while {[winfo exists [set toplevel .[set sbref $prefix${#sb}]]]} \
 197   {
 198     incr #sb
 199   }
 200
 201   global $sbref
 202   upvar #0 $sbref sb
 203
 204   if {$filename_ref != {}} \
 205   {
 206     set sb(want_fn) 1
 207     set sb(force_fn) 1
 208     upvar $filename_ref filename
 209   } \
 210   else \
 211   {
 212     set sb(want_fn) 0
 213   }
 214
 215   if {$conttype_ref != {}} \
 216   {
 217     set sb(want_ct) 1
 218     upvar $conttype_ref conttype
 219   } \
 220   else \
 221   {
 222     set sb(want_ct) 0
 223   }
 224
 225   foreach arg $args \
 226   {
 227     switch $arg \
 228     {
 229       nullfn \
 230       {
 231         set sb(force_fn) 0
 232       }
 233       default \
 234       {
 235         error "selbox: illegal argument $arg"
 236       }
 237     }
 238   }
 239
 240   set sb(toplevel) [toplevel $toplevel]
 241   wm minsize $toplevel 1 1
 242   wm geometry $toplevel 300x300
 243
 244   #--- up to three frames, for the file name, for the content type, and for a row of buttons:
 245   set borderwidth 5
 246   set relief ridge
 247   if {$sb(want_fn)} \
 248   {
 249     set f [frame $toplevel.f -relief $relief -bd $borderwidth]
 250   }
 251   if {$sb(want_ct)} \
 252   {
 253     set t [frame $toplevel.t -relief $relief -bd $borderwidth]
 254   }
 255   set btns [frame $toplevel.btns -relief $relief -bd $borderwidth]
 256
 257   #--- fill the upper file frame:
 258
 259   if {$sb(want_fn)} \
 260   {
 261   #  set c [canvas $f.c -bg blue]
 262     set flabel [label $f.label -text {File name:}]
 263     set flists [frame $f.lists]
 264     set fnf [frame $f.fn]
 265   #$c create window 0 0 -window $flists -anchor nw
 266   #set hsb [scrollbar $f.sb -orient horizontal -command "$c xview"]
 267   #  set fd_list [listbox $flists.dirname -relief sunken]
 268     set fb_list [listbox $flists.basename -relief sunken -width 1 -height 1 -selectmode single]
 269
 270   #  set fd_sb [scrollbar $flists.dir_sb]
 271     set fb_sb [scrollbar $flists.base_sb]
 272
 273     $fb_list configure -yscrollcommand "$fb_sb set"
 274     $fb_sb configure -command "$fb_list yview"
 275
 276   #  tk_listboxSingleSelect $fd_list $fb_list
 277   #  tk_listboxSingleSelect $fb_list
 278   #  bind $fd_list <Double-Button-1> "sb_newdir $sb"
 279     bind $fb_list <Double-Button-1> "selbox_newbase $sbref"
 280
 281     set fn [entry $fnf.name -relief sunken -textvariable $sbref\(fn)]
 282
 283     #bind $fn <Return> "sb_newfn $sb"
 284
 285   #  pack $fd_list $fd_sb $fb_list $fb_sb -side left -expand 1 -fill y
 286     pack $fb_list -side left -expand 1 -fill both
 287     pack $fb_sb -side left -fill y
 288     pack $fn
 289
 290     pack $flabel -fill x
 291     pack $fnf -fill x
 292     pack $flists -expand 1 -fill both
 293   #  pack $c $hsb -expand 1 -fill both
 294
 295     trace variable $sbref\(fn) w selbox_update
 296     # ``set sb(fn) {}'' doesn't work! (selbox_update will be called with the alias, not the global name!)
 297     if {[info exists filename]} \
 298     {
 299       set $sbref\(fn) $filename
 300     } \
 301     else \
 302     {
 303       set $sbref\(fn) {}
 304     }
 305
 306     pack $f -expand 1 -fill both
 307   }
 308
 309   #--- fill the middle type frame:
 310
 311   if {$sb(want_ct)} \
 312   {
 313     set tlabel [label $t.label -text {Content type:}]
 314     set tlists [frame $t.lists]
 315
 316     set tm [listbox $tlists.modules -exportselection 0 -relief sunken -width 1 -height 1 -selectmode single]
 317     set tt [listbox $tlists.types -exportselection 0 -relief sunken -width 1 -height 1 -selectmode single]
 318
 319     set tm_sb [scrollbar $tlists.mod_sb]
 320     set tt_sb [scrollbar $tlists.type_sb]
 321
 322     # tk_listboxSingleSelect $tm $tt
 323     $tm configure -yscrollcommand "$tm_sb set"
 324     $tm_sb configure -command "$tm yview"
 325
 326     global pdus
 327     eval $tm insert 0 [array names pdus]
 328     bind $tm <1> "[bind Listbox <1>]; selbox_tm_click $sbref"
 329
 330     pack $tm $tm_sb $tt $tt_sb -side left
 331       pack configure $tm $tt -expand 1 -fill both
 332       pack configure $tm_sb $tt_sb -fill y
 333     pack $tlabel -fill x
 334     pack $tlists -expand 1 -fill both
 335
 336     pack $t -expand 1 -fill both
 337   }
 338
 339   #--- fill the lower button frame:
 340
 341   button $btns.ok -text Ok -command "selbox_ok $sbref"
 342   button $btns.cancel -text Cancel -command "selbox_cancel $sbref"
 343
 344   pack $btns.ok $btns.cancel -side left -padx 3m
 345
 346   pack $btns -fill x
 347
 348   #--- now we're set up, let's go to work:
 349
 350   set of [focus]
 351   focus $fn
 352
 353   tkwait window $toplevel
 354   # if we got an affirmative response, export the selection:
 355   if $sb(rc) \
 356   {
 357     if {$sb(want_fn)} { set filename $sb(fn) }
 358     if {$sb(want_ct)} { set conttype $sb(ct) }
 359   }
 360   focus $of
 361   return $sb(rc)
 362 }