# ------------------------------------------------------------ # QW::WIDGET::TREE class # ------------------------------------------------------------ ::package require $::qw::control(package_iwidgets); #::package require Iwidgets; ::itcl::class ::QW::WIDGET::TREE { inherit iwidgets::Scrolledwidget private variable _nodes; # Array of all nodes by id. private variable _selecteds ;# Array of selected nodes by node $this. private variable _root ""; protected variable _options ""; protected variable _callback ""; protected variable _box_width ""; protected variable _box_height ""; protected variable _isDirty ""; protected variable _icon_open ""; protected variable _icon_closed ""; protected variable _icon_leaf ""; protected variable _canvas; protected variable _box_plus ""; protected variable _box_minus ""; protected variable _box_empty ""; method constructor {args} { ::array set _selecteds {}; ::array set _nodes {}; ::set _options $::qw::widget::options; ::sargs::var::+= _options [::subst { .command { .select {} .doubleclick {} } /item { .box { /plus { .icon { .file {[::file join $::qw_library system images box_plus.gif]} } } /minus { .icon { .file {[::file join $::qw_library system images box_minus.gif]} } } /empty { .icon { .file {[::file join $::qw_library system images box_empty.gif]} } } } .icon {} /leaf { .icon { .file {[::file join $::qw_library system images documenticon.gif]} } } /open { .icon { .file {[::file join $::qw_library system images openfoldericon.gif]} } } /closed { .icon { .file {[::file join $::qw_library system images closedfoldericon.gif]} } } } }]; ::sargs::var::+= _options $args; itk_option remove iwidgets::Labeledwidget::state ::set _icon_open [::image create photo -file [option_get /item/open.icon.file]]; ::set _icon_closed [::image create photo -file [option_get /item/closed.icon.file]]; ::set _icon_leaf [::image create photo -file [option_get /item/leaf.icon.file]]; ::set _box_plus [::image create photo -file [option_get /item.box/plus.icon.file]]; ::set _box_minus [::image create photo -file [option_get /item.box/minus.icon.file]]; ::set _box_empty [::image create photo -file [option_get /item.box/empty.icon.file]]; # # Create a clipping frame which will provide the border for # relief display. # itk_component add clipper { frame $itk_interior.clipper } { usual keep -borderwidth -relief -highlightthickness -highlightcolor rename -highlightbackground -background background Background } ::grid $itk_component(clipper) -row 0 -column 0 -sticky nsew ::grid rowconfigure $_interior 0 -weight 1 ::grid columnconfigure $_interior 0 -weight 1 ::set _canvas [::canvas $itk_component(clipper).canvas \ -width 1 \ -height 1 \ -xscrollcommand [::itcl::code $this _scrollWidget $itk_interior.horizsb] \ -yscrollcommand [::itcl::code $this _scrollWidget $itk_interior.vertsb] \ -borderwidth 0 \ -background white \ -highlightthickness 0 \ ]; # -cursor center_ptr /* { itk_component add canvas { ::canvas $itk_component(clipper).canvas \ -cursor center_ptr \ -width 1 \ -height 1 \ -xscrollcommand [::itcl::code $this _scrollWidget $itk_interior.horizsb] \ -yscrollcommand [::itcl::code $this _scrollWidget $itk_interior.vertsb] \ -borderwidth 0 \ -background white \ -highlightthickness 0 } { usual ignore -highlightthickness -highlightcolor ignore -insertbackground -insertborderwidth ignore -insertontime -insertofftime -insertwidth ignore -selectborderwidth ignore -borderwidth } */ } ::grid $_canvas -row 0 -column 0 -sticky nsew ::grid rowconfigure $itk_component(clipper) 0 -weight 1 ::grid columnconfigure $itk_component(clipper) 0 -weight 1 $itk_component(vertsb) configure -command [::itcl::code $_canvas yview] $itk_component(horizsb) configure -command [::itcl::code $_canvas xview] # Add popup menus that can be configured by the user to add new functionality. /* { itk_component add itemMenu { menu $itk_component(list).itemmenu -tearoff 0 } { usual ignore -tearoff rename -cursor -menucursor menuCursor Cursor } itk_component add bgMenu { menu $itk_component(list).bgmenu -tearoff 0 } { usual ignore -tearoff rename -cursor -menucursor menuCursor Cursor } */ } # # Adjust the bind tags to remove the class bindings. Also, add # bindings for mouse button 1 to do selection and button 3 to # display a popup. # #314120030325 ::bindtags $_canvas [::list $_canvas . all] # bind $itk_component(list) [::itcl::code $this _select %x %y] # bind $itk_component(list) [::itcl::code $this _post %x %y] # ::eval itk_initialize $args eval itk_initialize "" # kludge alert # We are not handling -background properly # The way we use icons it looks like we will need a plain white background # We have to see how to set default background to white even though # we inherited the background option. # configure -background white -vscrollmode dynamic -hscrollmode dynamic -selectbackground red # ::set itk_option(-selectbackground) red; configure \ -hscrollmode [option_get /scroll/horizontal.mode] \ -vscrollmode [option_get /scroll/horizontal.mode] \ ; # ::set itk_option(-selectbackground) red; # hide the damn label until we can get rid of altogether # grid forget [component label] # pack forget [component label] # deleting the label causes error when destructing. # itk_component delete label # ::foreach Option [configure] {puts $Option}; /* { Kludge Alert: Plus/Minus Box size. Because the plus/minus box might not be displayed in any particular item we cannot always use canvas item information to get their size. So we create a temporary box here and get its size once. */ } $_canvas create image 0 0 -image $_box_minus -anchor nw -tags _temp_; ::set BoundingBox [$_canvas bbox _temp_]; $_canvas delete _temp_; ::set _box_width [::expr [::lindex $BoundingBox 2]-[::lindex $BoundingBox 0]]; ::set _box_height [::expr [::lindex $BoundingBox 3]-[::lindex $BoundingBox 1]]; ::set Toplevel [::lindex [bindtags $itk_component(hull)] end-1]; ::bind $Toplevel [::itcl::code $this mouse_wheel %D]; } destructor { ::rename $_root {}; ::set _root ""; ::if {$_isDirty ne ""} {::after cancel $_isDirty} ::set _isDirty ""; ::image delete $_icon_open $_icon_closed $_icon_leaf $_box_plus $_box_minus $_box_empty; ::destroy $_canvas; } method option_get {Path} {::return [::sargs::get_poly $_options $Path];} method option_set {args} { ::qw::s_args_marshal; ::sargs::var::+= _options $s_args; } method canvas {} {::return $_canvas;} method xview {args} {::return [::eval $_canvas xview $args];} method yview {args} {::return [::eval $_canvas yview $args];} method node {Id} { return $_nodes($Id); } method node_class {} {::return ::QW::WIDGET::TREE::NODE;} method nodes_create {args} {::return [::namespace current]::[::eval [node_class] #auto $args;]} method make_dirty {} { ::if {$_isDirty eq ""} { ::set _isDirty [::after idle [::itcl::code $this make_clean]]; } } method make_clean {} { $_canvas configure -scrollregion [$_canvas bbox all]; ::set _isDirty ""; ::update idletasks; } method nodes_attach {Node} { ::set _nodes([$Node id]) $Node; } method nodes_detach {Node} {::unset _nodes([$Node id]);} method selecteds {} {::return [::array names _selecteds];} method selecteds_attach {Node} {::set _selecteds([$Node id]) $Node;} method selecteds_detach {Node} {::unset _selecteds([$Node id]);} method selecteds_clear {} { ::foreach Id [::array names _selecteds] {[node $Id] deselect;} ::qw::assert {![::array size _selecteds]} return $this; } method mouse_wheel {Delta} { ::set OldPos [::lindex [$_canvas yview] 0]; ::set MoveBy [::expr {int($Delta/120)*-0.02}]; ::set NewPos [::expr {$OldPos+$MoveBy}]; $_canvas yview moveto $NewPos; } method see {} { /* { Kludge Alert I tried and tried to get the current position of the scrolled viewport. It certainly works when we are stable but the important time I need it is when the window first appears. Nothing works at that time due to the usual tk timing problems. So I find out who my toplevel is and get his requested size as a rough approximation of the size of the viewable area. Crude but effective. To get the toplevel I extract the first component of the widgets's path. */ } ::if {![::llength [selecteds]]} {::return $this;} ::set Selected [::lindex [selecteds] 0]; ::set ItemBBox [$_selecteds($Selected) bounding_box $_selecteds($Selected)]; ::set ItemTop [::lindex $ItemBBox 1]; ::set ItemBottom [::lindex $ItemBBox 3]; ::set CanvasBBox [$_canvas bbox all]; ::set CanvasTop [::lindex $CanvasBBox 1]; ::set CanvasBottom [::lindex $CanvasBBox 3]; ::if {$CanvasTop<0} {::set CanvasTop 0;} ::set CanvasHeight [::expr {$CanvasBottom-$CanvasTop}]; ::set ViewPortHeight [::winfo reqheight $_canvas]; ::if {$ViewPortHeight==1} { ::set MyToplevel ".[::lindex [::split $itk_component(hull) .] 1]"; ::set ViewPortHeight [::winfo reqheight $MyToplevel]; ::set Top [::expr {double($ItemTop)-double($ViewPortHeight)/2.0}]; ::set Top [::expr {double($Top)/double($CanvasHeight)}]; ::if {$Top<0.0} {::set Top 0.0;} $_canvas yview moveto $Top; return $this; } /* { If we reach this point we can assume we have hit "steady state" and that the sizes reported are valid. However, this code will likely never be called because we do not really need to attempt to see the current position once the user is in control. The only time we really need the see method is when it doesn't work. */ } ::qw::bug 314120030918120133; ::foreach {ViewPortTopRatio ViewPortBottomRatio} [$itk_component(vertsb) get] {}; ::set ViewPortTop [::expr {$ViewPortTopRatio*$CanvasHeight}]; ::set ViewPortBottom [::expr {$ViewPortBottomRatio*$CanvasHeight}]; /* { ::puts " ItemTop:$ItemTop" ::puts " ItemBottom:$ItemBottom" ::puts " ViewPortTop:$ViewPortTop" ::puts " ViewPortBottom:$ViewPortBottom" ::puts " ViewPortTopRatio:$ViewPortTopRatio" ::puts " ViewPortBottomRatio:$ViewPortBottomRatio" ::puts " CanvasTop:$CanvasTop" ::puts " CanvasBottom:$CanvasBottom" ::puts " CanvasHeight:$CanvasHeight" ::puts " ViewPortHeight:$ViewPortHeight" */ } ::if {$ItemTop>=$ViewPortTop&&$ItemBottom<=$ViewPortBottom} {::return $this;} ::set Top [::expr {double($ItemTop)-double($ViewPortHeight)/2.0}]; ::set Top [::expr {double($Top)/double($CanvasHeight)}]; ::if {$Top<0.0} {::set Top 0.0;} $_canvas yview moveto $Top; return $this; } method clear {} { /* { This is a heavy-handed clear of the widget. It destroys the root which recursively destroys all nodes in the tree. The root is reset to "" so that the tree will be completely rebuilt. clear is called when the query command is changed. Note that we do not clear the selected nodes array because the node destructors should automatically do that. */ } ::if {$_root eq ""} {::return $this;} delete object $_root; ::set _root ""; return $this; } method root_get {} { ::return [callback_call -command root]; } method text_get {Id} { ::return [callback_call -command text -id $Id]; } method kids_get {Id} { ::return [callback_call -command kids -id $Id]; } method icon_get {Id} { ::return [callback_call -command icon -id $Id]; } method draw {} { ::if {$_root eq ""} { ::set RootId [root_get]; ::set _root [nodes_create]; $_root id $RootId; $_root tree [::itcl::scope $this]; # ::set _root [nodes_create -id $RootId -tree [::itcl::scope $this]]; } $_root draw; make_dirty; } method expand_all {} { ::qw::assert {$_root ne ""} $_root expand_all make_dirty; } method callback_set {Callback} { ::set _callback $Callback; return $this; } method callback_call {args} { ::if {$_callback eq ""} { ::return ""; } ::return [::uplevel #0 $_callback $args]; } method box_width {} {::return $_box_width;} method box_height {} {::return $_box_height;} method box_minus {} {::return $_box_minus;} method box_plus {} {::return $_box_plus;} method box_empty {} {::return $_box_empty;} method doubleclick {Button Path} { ::if {$Button==1} { ::if {[option_get ".command.doubleclick"] ne ""} { ::uplevel #0 [option_get ".command.doubleclick"]; } } } } # ------------------------------------------------------------ # ::QW::WIDGET::TREE::NODE class # ------------------------------------------------------------ ::itcl::class ::QW::WIDGET::TREE::NODE { protected variable _id ""; protected variable _tree ""; protected variable _parent ""; protected variable _index -1; protected variable _kids ""; protected variable _isExpanded 0; protected variable _isSelected 0; protected variable _canvas ""; protected variable _text ""; method id {{Src get}} { ::if {$Src eq "get"} {::return $_id;} ::set _id $Src; return $this; } method tree {{Src get}} { ::if {$Src eq "get"} {::return $_tree;} ::set _tree $Src; $_tree nodes_attach $this; ::set _canvas [$_tree canvas]; return $this; } method parent {{Src get}} { ::if {$Src eq "get"} {::return $_parent;} ::set _parent $Src; return $this; } method index {{Src get}} { ::if {$Src eq "get"} {::return $_index;} ::set _index $Src; return $this; } method index_incr {{Src 1}} {::incr _index $Src;return $this;} method text {} { ::if {$_text==""} { ::set _text [$_tree text_get $_id]; ::set _text [::string trim $_text]; ::set _text [::string map {\n " " \r ""} $_text]; } return $_text; } method prev {} { ::if {$_parent eq ""} {::return "";} ::qw::assert {$_index>=0} ::if {!$_index} {::return "";} return [::lindex [$_parent kids] [::expr $_index-1]]; } method next {} { ::if {$_parent eq ""} {::return "";} ::qw::assert {$_index>=0} ::set Items [::llength [$_parent kids]]; ::if {$_index == [::expr $Items-1]} {::return "";} return [::lindex [$_parent kids] [::expr $_index+1]]; } constructor {args} { ::eval configure $args return $this; } destructor { kids_destroy; ::if {[::winfo exists $_canvas]} { undraw; }; ::if {$_parent ne ""} {$_parent kids_detach $this} $_tree nodes_detach $this; } method kids_destroy {} { while {[::llength $_kids]} { #::qw::itcl_delete_object [::lindex $_kids end]; # ::rename [::lindex $_kids end] {}; ::itcl::delete object [::lindex $_kids end]; } ::qw::assert {![::llength $_kids]} # ::set _kids ""; return $this; } method kids_detach {Kid} { ::set Index [$Kid index]; ::qw::assert {$Index < [::llength $_kids]} ::set _kids [::lreplace $_kids $Index $Index]; ::for {::set i $Index} {$i<[::llength $_kids]} {::incr i} { [::lindex $_kids $i] index_incr -1; } return $this; } method kids {} { ::if {[::llength $_kids]} { ::return $_kids; } ::foreach Id [$_tree kids_get $_id] { ::set Kid [$_tree nodes_create]; $Kid id $Id; $Kid parent [::itcl::scope $this]; $Kid tree $_tree; $Kid index [::llength $_kids]; ::lappend _kids $Kid; } return $_kids; } method isLeaf {} { return [expr {[::llength [kids]]==0}]; } method isBranch {} {::return [::expr {![isLeaf]}];} method isExpanded {} {::return $_isExpanded;} method isSelected {} {::return $_isSelected;} method select {} { $_tree selecteds_clear; ::set _isSelected 1; $_canvas itemconfigure $this-hilite -fill [$_tree option_get /selection.background]; $_canvas itemconfigure $this-text -fill [$_tree option_get /selection.foreground]; $_tree selecteds_attach $this; ::if {[$_tree option_get ".command.select"] ne ""} { ::uplevel #0 [$_tree option_get ".command.select"]; } #rwb_help # ::puts "314120030924,[$_tree selecteds]" # return $this; } method deselect {} { $_canvas itemconfigure $this-hilite -fill "" $_canvas itemconfigure $this-text -fill [$_tree option_get /item.foreground]; $_tree selecteds_detach $this; ::set _isSelected 0; return $this; } method toggle {} { ::if {[isLeaf]} {::return $this;} ::if {[isExpanded]} {::return [collapse];} return [expand]; } method draw {} { # BoxX is the center of the box or if no box, where it would have been. ::if {$_parent==""} { ::set BoxX [::expr [$_tree box_width]/2]; } else { ::set BoxX [$_parent center_x $_parent-icon]; } ::set Top 0; ::set Prev [prev]; ::if {$Prev ne ""} { ::set Top [$Prev kids_bottom]; } else { ::if {$_parent ne ""} {::set Top [$_parent bottom $_parent];} } ::if {[isBranch]} { ::if {[isExpanded]} { ::set BoxImage [$_tree box_minus]; } else { ::set BoxImage [$_tree box_plus]; } } else { ::set BoxImage [$_tree box_empty]; } $_canvas create image $BoxX $Top -image $BoxImage -anchor n -tags [::list $this $this-box]; ::set Left [::expr $BoxX+[$_tree box_width]/2]; # Kludge alert: Hard-wired padding between box and icon. ::incr Left 5; $_canvas create image $Left $Top -image [$_tree icon_get $_id] -anchor nw -tags [::list $this $this-icon]; ::set Left [right $this-icon]; $_canvas create text $Left $Top -text [text] -anchor nw -tags [::list $this $this-text] -font [$_tree option_get /item.font]; ::if {$_isSelected} { ::set TextColor [$_tree option_get /selection.foreground]; } else { ::set TextColor [$_tree option_get /item.foreground]; } $_canvas itemconfigure $this-text -fill $TextColor; ::set Height [height $this]; $_canvas move $this-box 0 [::expr ($Height-[height $this-box])/2+1]; # We center the icon and text vertically with overall bbox for the item. $_canvas move $this-icon 0 [::expr ($Height-[height $this-icon])/2]; $_canvas move $this-text 0 [::expr ($Height-[height $this-text])/2]; ::set CenterY [center_y $this]; $_canvas lower [$_canvas create line [left $this-icon] $CenterY $BoxX $CenterY -fill grey -tags [::list $this $this-line_h]]; draw_vertical_line; ::if {$_isSelected} { ::set Fill [$_tree option_get /selection.background]; } else { ::set Fill [$_tree option_get /item.background]; } ::set SelectBackground [::eval $_canvas create rectangle [bounding_box $this-text]]; $_canvas itemconfigure $SelectBackground -fill $Fill -outline "" -tags [::list $this hilite $this-hilite]; $_canvas lower $SelectBackground; bindings_set; ::if {[isExpanded]} { draw_kids; } } method bindings_set {} { $_canvas bind $this-text [::itcl::code $this select]; $_canvas bind $this-icon [::itcl::code $this select]; $_canvas bind $this-box [::itcl::code $this toggle]; $_canvas bind $this-icon [::itcl::code $this doubleclick 1]; $_canvas bind $this-text [::itcl::code $this doubleclick 1]; } method draw_vertical_line {} { ::if {$_parent==""} {::return;} $_canvas delete $this-line_v; ::set x [::expr [$_parent center_x $_parent-icon]-1]; ::set Prev [prev]; ::if {$Prev!=""} { ::set y [$Prev center_y $Prev]; } else { ::set y [$_parent center_y $_parent]; } $_canvas lower [$_canvas create line $x [center_y $this] $x $y -fill grey -tags $this-line_v]; return $this; } method draw_kids {} { ::foreach Kid [kids] {$Kid draw;} return $this; } method bounding_box {Tag} {::return [$_canvas bbox $Tag];} method height {Tag} {::return [::expr [bottom $Tag]-[top $Tag]];} method width {Tag} {::return [::expr [right $Tag]-[left $Tag]];} method top {Tag} {::return [::lindex [bounding_box $Tag] 1];} method left {Tag} {::return [::lindex [bounding_box $Tag] 0];} method bottom {Tag} {::return [::lindex [bounding_box $Tag] 3];} method right {Tag} {::return [::lindex [bounding_box $Tag] 2];} method center_x {Tag} {::return [::expr [left $Tag]+[width $Tag]/2];} method center_y {Tag} {::return [::expr [top $Tag]+[height $Tag]/2];} method expand {} { ::if {[isLeaf]} { ::return $this; } ::if {[isExpanded]} { ::return $this; } ::set _isExpanded 1; ::switch -- $::tcl_platform(platform) { windows { ::itcl::local ::QW::MOUSE_CURSOR_SANDWICH #auto .widget $_canvas .cursor $::qw::platform_dependent_cursor(wait); } unix { ::itcl::local ::QW::MOUSE_CURSOR_SANDWICH #auto .widget $_canvas .cursor "watch"; } } $_canvas addtag _about_to_move_ overlapping 0 [::expr [bottom $this]+1] [right all] [bottom all]; draw_kids; $_canvas move _about_to_move_ 0 [::expr [kids_bottom] - [bottom $this]]; $_canvas dtag _about_to_move_ _about_to_move_ ::for {::set Parent $this} {$Parent ne ""} {::set Parent [$Parent parent]} { ::if {[$Parent next] ne ""} {[$Parent next] draw_vertical_line;} } ::set x [left $this-box]; ::set y [top $this-box]; $_canvas delete $this-box; $_canvas create image $x $y -image [$_tree box_minus] -anchor nw -tags [::list $this $this-box]; ::set x [left $this-icon]; ::set y [top $this-icon]; $_canvas delete $this-icon; $_canvas create image $x $y -image [$_tree icon_get $_id] -anchor nw -tags [::list $this $this-icon]; $_tree make_dirty; # $_tree configure -cursor $Cursor return $this; } method expand_all {} { expand; ::foreach Kid [kids] {$Kid expand_all} $_tree make_dirty; return $this; } method kids_undraw {} { ::if {![isExpanded]} { ::return; } ::foreach Kid [kids] { $Kid undraw; } } method undraw {} { kids_undraw; $_canvas delete $this $this-line_v; } method kids_bottom {} { ::if {![isExpanded]} {::return [bottom $this];} ::if {![::llength [kids]]} {::return [bottom $this];} return [[::lindex $_kids end] kids_bottom]; } method collapse {} { ::if {[isLeaf]} {::return $this;} ::if {![isExpanded]} {::return $this;} $_canvas addtag _about_to_move_ overlapping 0 [::expr [kids_bottom]+1] [right all] [bottom all]; ::set Distance_y [::expr [bottom $this]-[kids_bottom]]; kids_undraw; ::set _isExpanded 0; $_canvas move _about_to_move_ 0 $Distance_y; $_canvas dtag _about_to_move_ _about_to_move_ ::set x [left $this-icon]; ::set y [top $this-icon]; $_canvas delete $this-icon; $_canvas create image $x $y -image [$_tree icon_get $_id] -anchor nw -tags [::list $this $this-icon]; ::for {::set Parent $this} {$Parent!=""} {::set Parent [$Parent parent]} { ::if {[$Parent next]!=""} {[$Parent next] draw_vertical_line;} } ::set x [left $this-box] ::set y [top $this-box] $_canvas delete $this-box; $_canvas create image $x $y -image [$_tree box_plus] -anchor nw -tags [::list $this $this-box]; $_tree make_dirty; return $this; } method doubleclick {Button} { $_tree doubleclick $Button $_id; } } # option add *Dialog.master "." widgetDefault # ------------------------------------------------------------ # ::QW::WIDGET::TREE::FRACTAL # ------------------------------------------------------------ ::itcl::class ::QW::WIDGET::TREE::FRACTAL { inherit ::QW::WIDGET::TREE; public constructor {args} { ::eval ::QW::WIDGET::TREE::constructor $args; } { eval itk_initialize "" # ::eval itk_initialize $args; } # destructor {chain;} method items {Path} { ::return [::llength [::sargs::names .structure [option_get .structure$Path] .glob /*]]; #*/ } method node_class {} {::return ::QW::WIDGET::TREE::FRACTAL::NODE;} method root_get {} {::return "";} # method text_get {Path} {::return [option_set .structure$Path.text];} method text_get {Path} { # return [::subst [::sargs::set $_options .structure$Path.text]]; ::if {![::sargs::exists $_options .structure$Path.text]} { ::qw::throw "Could not find .text in \".structure$Path\""; } return [::sargs::get $_options .structure$Path.text]; } method kids_get {Path} { ::set Field [option_get .structure$Path]; ::set Names [::sargs::names .structure $Field .glob /*]; # */ ::set Result ""; ::foreach Name $Names {::lappend Result $Path$Name;} return $Result; } method icon_get {Path} { # ::if {![items $Path]} {::return $_icon_leaf;} ::if {[[node $Path] isExpanded]} {::return $_icon_open;} return $_icon_closed; } } ::itcl::class ::QW::WIDGET::TREE::FRACTAL::NODE { inherit ::QW::WIDGET::TREE::NODE; public constructor {args} { ::eval ::QW::WIDGET::TREE::NODE::constructor $args; } { } # destructor {chain;} } # ------------------------------------------------------------ # ::QW::WIDGET::TREE::DOS class # ------------------------------------------------------------ ::itcl::class ::QW::WIDGET::TREE::DOS { inherit ::QW::WIDGET::TREE; protected variable _kids; protected variable _types; protected variable _drives ""; protected variable _icon_newviews ""; # itk_option define -files files Files 1 {}; public variable dialog ""; public constructor {args} { ::eval ::QW::WIDGET::TREE::constructor $args; } { # ::set _icon_newviews [::image create photo -file [::file join $::qw_library system images NV2.ICO]]; # ::set _icon_newviews [::image create photo -file [::file join $::qw_library system images nv_16x16.gif]]; # ::set _icon_newviews [::image create photo -file [::file join $::qw_library system images nv2_icon_24.gif]]; ::set _icon_newviews [::image create photo -file [::file join $::qw_library system images nv2_icon_18.gif]]; # ::set _icon_newviews [::image create photo -file [::file join $::qw_library system images NewViews.ico]]; # ::set _icon_newviews [::image create photo -file j:/nv/nvjr.ico] ::sargs::var::+= _options { .files 1 .patterns * }; ::sargs::var::+= _options $args; /* { ::array set Args $args; ::if {[::info exists Args(-files)]} { ::set itk_option(-files) $Args(-files); ::unset Args(-files); } */ } ::array set _kids {}; ::array set _types {}; # ::eval itk_initialize [::array get Args]; # draw # [node ""] expand; # ::eval itk_initialize $args; } method select_path {Path} { ::if {$Path eq ""} {::return;} ::set Path [::string tolower $Path]; ::while {![::file exists $Path]} { /* { We keep chopping the tail from path until we find a directory that exists. */ } ::set Path [::eval ::file join [::lreplace [::file split $Path] end end]]; ::if {$Path eq ""} {::return;} } ::if {![option_get ".files"]} { /* { The path was found but it may be a file and we may only want directories. In this situation we again drop the tail. */ } while {[::file isfile $Path]} { ::set Path [::eval ::file join [::lreplace [::file split $Path] end end]]; ::if {$Path eq ""} {::return;} } } /* { We have a path that exists. We now start at the root and expand nodes until we have the path in sight. */ } ::set List [::file split $Path]; [node ""] expand ::set Length [::llength $List]; ::for {::set i 0} {$i<$Length} {::incr i} { ::set Path [::eval ::file join [::lrange $List 0 $i]]; ::if {$i<$Length-1} {[node $Path] expand}; } [node $Path] select # ::after idle "::update idletasks;after idle [::itcl::code $this see];" } method node_class {} {::return ::QW::WIDGET::TREE::DOS::NODE;} method root_get {} { ::set _types([root_name]) root; return [root_name]; } method text_get {Path} { ::if {[isRoot $Path]} {::return "drives";} ::switch -- $_types($Path) { root {::return "drives"} drive {::return "[::string range $Path 0 1]";} directory - file {::return [::file tail $Path];} } ::qw::bug 314120030918120146; } method kids_get {Path} { /* { ::glob -types does not always work with the vfs so we get all files and then select the directories or files manually. The problem with the vfs is that when we glob the kids of a particular parent directory we do so in the context of the parent directory. So qw.exe showed up as a file. When we specifically query the type of qw.exe we get "directory". */ } ::set Path [::string tolower $Path]; ::if {[::info exists _kids($Path)]} {::return $_kids($Path);} # ::itcl::local ::QW::MOUSE_CURSOR_SANDWICH #auto .widget $_canvas .cursor $::qw::platform_dependent_cursor(wait); ::if {$Path eq [root_name]} { ::set _kids($Path) [drives_get]; ::set _types($Path) root; ::foreach Kid $_kids($Path) { ::set _types($Kid) drive; } ::return $_kids($Path); } ::set Kids [::glob -nocomplain [::file join $Path *]]; # ::set Kids [::glob -nocomplain -join $Path *]; ::set Directories ""; ::foreach Kid $Kids { ::if {[::file isdirectory $Kid]} { ::lappend Directories $Kid; } } # ::set Directories [::glob -nocomplain -type d -join $Path *]; ::set Directories [::string tolower $Directories]; ::set Directories [::lsort -dictionary -increasing $Directories]; ::foreach Directory $Directories { ::set _types($Directory) directory; } ::set Files ""; ::if {[option_get .files]} { # ::set Files [::eval ::glob -nocomplain -type f -join $Path [option_get .patterns]]; ::set Files ""; ::set KidFiles ""; ::foreach Pattern [option_get .patterns] { ::set Kids [::glob -nocomplain [::file join $Path $Pattern]]; # ::set Kids [::glob -nocomplain -join $Path $Pattern]; ::foreach Kid $Kids { ::if {[::file isfile $Kid]} { ::lappend KidFiles $Kid; } } ::set Files [::qw::union $Files $KidFiles]; # ::set Files [::concat $Files [::eval ::glob -nocomplain -type f -join $Path $Pattern]]; } ::set Files [::string tolower $Files]; ::set Files [::lsort -dictionary -increasing $Files]; ::foreach File $Files {::set _types($File) file;} } ::set _kids($Path) [::concat $Directories $Files]; ::return $_kids($Path); } method icon_get {Path} { # ::set IsExpanded [[node $Path] isExpanded]; ::switch -- $_types($Path) { root - directory - drive { ::if {[[node $Path] isExpanded]} {::return $_icon_open;} # ::if {[[node $Path] isLeaf]} {::return $_icon_leaf;} ::return $_icon_closed; # ::if {$IsExpanded} {::return $_icon_open}; # return $_icon_closed; } } ::if {[::string tolower [::file extension $Path]] eq ".nv2"} { ::return $_icon_newviews; } return $_icon_leaf; } method root_name {} {::return "";} method isRoot {Path} {::return [::string equal $Path [root_name]];} method isDrive {Path} { ::if {[::regexp ^\[a-z|A-Z\]:/$ $Path]} {::return 1;} ::return 0; } method isDirectory {Path} { ::switch -- $_types($Path) { root - drive - directory {::return 1} } return 0; } method drives_get {} { ::if {[::llength $_drives]!=0} { ::return $_drives; } ::set _drives [::file volumes]; ::set _drives [::string tolower $_drives]; # Kludge alert: Leaving out A and B for speed. ::set _drives [::lrange $_drives [::lsearch -exact $_drives c:/] end]; return $_drives; } method doubleclick {Button Path} { ::if {$Button==1} { ::if {[option_get ".files"]} { ::if {![::file isfile $Path]} { [node $Path] toggle; return ""; } } return [chain $Button $Path]; } } } ::itcl::class ::QW::WIDGET::TREE::DOS::NODE { inherit ::QW::WIDGET::TREE::NODE; protected variable _isLoaded 0; public constructor {args} { ::eval ::QW::WIDGET::TREE::NODE::constructor $args; } { } /* { destructor { # puts "QW::DIALOG::DOS::TREE::NODE destructor" chain; } */ } method isLeaf {} { ::if {[isLoaded]} {::return [chain];} ::if {![$_tree isDirectory $_id]} { ::set _isLoaded 1; return 1; } return 0; } method isLoaded {} { return $_isLoaded; } method kids {} { ::if {[isLoaded]} {::return [chain];} return ""; } method expand {} { ::if {![isLoaded]} { ::set _isLoaded 1; kids; ::if {[isLeaf]} { ::set x [left $this-box]; ::set y [top $this-box]; $_canvas delete $this-box; $_canvas create image $x $y -image [$_tree box_empty] -anchor nw -tags [::list $this $this-box]; }; } return [chain]; } } /* { ::QW::WIDGET::TREE ::QW::WIDGET::COMPLETION_PERCENTAGE1 ::QW::WIDGET::COMPLETION_PERCENTAGE ::QW::WIDGET::TREE::NODE ::QW::WIDGET::TREE::FRACTAL ::QW::WIDGET::TREE::DOS ::QW::WIDGET::TREE::DOS::NODE ::QW::WIDGET::TREE::FRACTAL::NODE */ }