gdb/gdbtk/library/managedwin.itb

   1 # Managed window for Insight.
   2 # Copyright (C) 1998, 1999, 2000, 2001, 2002, 2004, 2008 Red Hat, Inc.
   3 #
   4 # This program is free software; you can redistribute it and/or modify it
   5 # under the terms of the GNU General Public License (GPL) as published by
   6 # the Free Software Foundation; either version 2 of the License, or (at
   7 # your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13
  14
  15 # ------------------------------------------------------------
  16 #  PUBLIC METHOD:  constructor
  17 # ------------------------------------------------------------
  18 itcl::body ManagedWin::constructor {args} {
  19   #debug "$this args=$args"
  20   set _top [winfo toplevel $itk_interior]
  21 }
  22
  23 # ------------------------------------------------------------
  24 #  PUBLIC METHOD: destructor
  25 # ------------------------------------------------------------
  26 itcl::body ManagedWin::destructor {} {
  27   # If no toplevels remain, quit.  However, check the quit_if_last
  28   # flag since we might be doing something like displaying a
  29   # splash screen at startup...
  30
  31   if {!$numTopWins && [quit_if_last]} {
  32     if {$::iipc && [pref get gdb/ipc/exit]} {
  33       $::insight_ipc send quit
  34     }
  35     gdb_force_quit
  36   } else {
  37     destroy_toplevel
  38   }
  39 }
  40
  41 # ------------------------------------------------------------
  42 #  PUBLIC METHOD:  window_name - Set the name of the window
  43 #   (and optionally its icon's name).
  44 # ------------------------------------------------------------
  45 itcl::body ManagedWin::window_name {wname {iname ""}} {
  46
  47   if {$wname != ""} {
  48     set _wname $wname
  49   } else {
  50     set wname $_wname
  51   }
  52   if {$iname != ""} {
  53     set _iname $iname
  54   } else {
  55     set iname $_iname
  56   }
  57
  58   if {$win_instance != ""} {
  59     append wname " \[$win_instance\]"
  60     if {$iname != ""} {
  61       append iname " \[$win_instance\]"
  62     }
  63   }
  64   wm title $_top $wname
  65   if {$iname != ""} {
  66     wm iconname $_top $iname
  67   } else {
  68     wm iconname $_top $wname
  69   }
  70 }
  71
  72 # ------------------------------------------------------------
  73 #  PUBLIC METHOD:  window_instance - Set the string to be
  74 #   appended to each window title for this instance of Insight
  75 # ------------------------------------------------------------
  76 itcl::body ManagedWin::window_instance {ins} {
  77   set win_instance $ins
  78   foreach obj [itcl::find objects -isa ManagedWin] {
  79     debug "$obj ManagedWin::_wname"
  80     $obj window_name ""
  81   }
  82 }
  83
  84 # ------------------------------------------------------------
  85 #  PUBLIC METHOD: pickle - This is the base class pickle
  86 #   method.  It returns a command that can be used to recreate
  87 #   this particular window.
  88 # ------------------------------------------------------------
  89 itcl::body ManagedWin::pickle {} {
  90   return [list ManagedWin::open [namespace tail [info class]]]
  91 }
  92
  93 # ------------------------------------------------------------
  94 #  PUBLIC METHOD:  reveal
  95 # ------------------------------------------------------------
  96 itcl::body ManagedWin::reveal {} {
  97   # Do this update to flush all changes before deiconifying the window.
  98   update idletasks
  99
 100   raise $_top
 101   wm deiconify $_top
 102
 103   # Some window managers (on unix) fail to honor the geometry unless
 104   # the window is visible.
 105   if {[info exists ::$_top._init_geometry]} {
 106     upvar ::$_top._init_geometry gm
 107     if {$::gdbtk_platform(platform) == "unix"} {
 108       wm geometry $_top $gm
 109     }
 110     unset ::$_top._init_geometry
 111   }
 112
 113   # There used to be a `focus -force' here, but using -force is
 114   # unfriendly, so it was removed.  It was then replaced with a simple
 115   # `focus $top'.  However, this has no useful effect -- it just
 116   # resets the subwindow of $top which has the `potential' focus.
 117   # This can actually be confusing to the user.
 118
 119   # NOT for Windows, though. Without the focus, we get, eg. a
 120   # register window on top of the source window, but the source window
 121   # will have the focus. This is not the proper model for Windows.
 122   if {$::gdbtk_platform(platform) == "windows"} {
 123     focus -force [focus -lastfor $_top]
 124   }
 125 }
 126
 127 # ------------------------------------------------------------
 128 #  PUBLIC PROC:  restart
 129 # ------------------------------------------------------------
 130 itcl::body ManagedWin::restart {} {
 131   # This is needed in case we've called "gdbtk_busy" before the restart.
 132   # This will configure the stop/run button as necessary
 133   after idle gdbtk_idle
 134
 135   # call the reconfig method for each object
 136   foreach obj [itcl::find objects -isa ManagedWin] {
 137     if {[catch {$obj reconfig} msg]} {
 138       dbug W "reconfig failed for $obj - $msg"
 139     }
 140   }
 141 }
 142
 143 # ------------------------------------------------------------------
 144 #  PUBLIC PROC:  shutdown - This writes all the active windows to
 145 #   the preferences file, so they can be restored at startup.
 146 #   FIXME: Currently assumes only ONE window per type...
 147 # ------------------------------------------------------------------
 148 itcl::body ManagedWin::shutdown {} {
 149   set activeWins {}
 150   foreach win [itcl::find objects -isa ManagedWin] {
 151     if {![$win isa ModalDialog] && ![$win _ignore_on_save]} {
 152       set g [wm geometry [winfo toplevel [namespace tail $win]]]
 153       pref setd gdb/geometry/[namespace tail $win] $g
 154       lappend activeWins [$win pickle]
 155     }
 156   }
 157   pref set gdb/window/active $activeWins
 158 }
 159
 160 # ------------------------------------------------------------------
 161 #  PUBLIC PROC:  startup - This restores all the windows that were
 162 #   opened at shutdown.
 163 #   FIXME: Currently assumes only ONE window per type...
 164 # ------------------------------------------------------------------
 165 itcl::body ManagedWin::startup {} {
 166   debug "Got active list [pref get gdb/window/active]"
 167
 168   foreach cmd [pref get gdb/window/active] {
 169     eval $cmd
 170   }
 171   # If we open the source window, and a source window already exists,
 172   # then we end up raising it twice during startup.  This yields an
 173   # annoying effect for the user: if the user tries the bury the
 174   # source window during startup, it will raise itself again.  This
 175   # explains why we first check to see if a source window exists
 176   # before trying to create it -- raising the window is an inevitable
 177   # side effect of the creation process.
 178   if {[llength [find SrcWin]] == 0} {
 179     ManagedWin::open SrcWin
 180   }
 181 }
 182
 183 # ------------------------------------------------------------
 184 #  PUBLIC PROC:  open_dlg
 185 # ------------------------------------------------------------
 186 itcl::body ManagedWin::open_dlg {class args} {
 187
 188   set newwin [eval _open $class $args]
 189   if {$newwin != ""} {
 190     $newwin reveal
 191     $newwin post
 192   }
 193 }
 194
 195 # ------------------------------------------------------------
 196 #  PUBLIC PROC:  open
 197 # ------------------------------------------------------------
 198 itcl::body ManagedWin::open {class args} {
 199
 200   set newwin [eval _open $class $args]
 201   if {$newwin != ""} {
 202     if {[$newwin isa ModalDialog]} {
 203       parse_args [list {expire 0}]
 204       after idle "$newwin reveal; $newwin post 0 $expire"
 205     } else {
 206       after idle "$newwin reveal"
 207     }
 208   }
 209
 210   return $newwin
 211 }
 212
 213 # ------------------------------------------------------------
 214 #  PRIVATE PROC:  _open
 215 # ------------------------------------------------------------
 216 itcl::body ManagedWin::_open { class args } {
 217   debug "$class $args"
 218
 219   parse_args force
 220
 221   if {!$force} {
 222     # check all windows for one of this type
 223     foreach obj [itcl::find objects -isa ManagedWin] {
 224       if {[$obj isa $class]} {
 225         $obj reveal
 226         return $obj
 227       }
 228     }
 229
 230   }
 231   # need to create a new window
 232   return [eval _create $class $args]
 233 }
 234
 235 # ------------------------------------------------------------
 236 #  PRIVATE PROC:  _create
 237 # ------------------------------------------------------------
 238 itcl::body ManagedWin::_create { class args } {
 239
 240   set win [string tolower $class]
 241   debug "win=$win args=$args"
 242
 243   parse_args {center transient {over ""}}
 244
 245   # increment window numbers until we get an unused one
 246   set i 0
 247   while {[winfo exists .$win$i]} { incr i }
 248
 249   while { 1 } {
 250     set top [toplevel .$win$i]
 251     wm withdraw $top
 252     wm protocol $top WM_DELETE_WINDOW "destroy $top"
 253     wm group $top .
 254     set newwin $top.$win
 255     if {[catch {uplevel \#0 eval $class $newwin $args} msg]} {
 256       dbug E "object creation of $class failed: $msg"
 257       dbug E $::errorInfo
 258       if {[string first "object already exists" $msg] != -1} {
 259         # sometimes an object is still really around even though
 260         # [winfo exists] said it didn't exist.  Check for this case
 261         # and increment the window number again.
 262         catch {destroy $top}
 263         incr i
 264       } else {
 265         return ""
 266       }
 267     } else {
 268       break
 269     }
 270   }
 271
 272   if {[catch {pack $newwin -expand yes -fill both}]} {
 273     dbug W "packing of $newwin failed: $::errorInfo"
 274     return ""
 275   }
 276
 277   wm maxsize $top $_screenwidth $_screenheight
 278   wm minsize $top 20 20
 279   update idletasks
 280
 281   if {$over != ""} {
 282     # center new window
 283     center_window $top -over [winfo toplevel [namespace tail $over]]
 284   } elseif {$center} {
 285     center_window $top
 286   }
 287
 288   if {$transient} {
 289     wm resizable $top 0 0
 290
 291     # If a SrcWin is around, use its toplevel as the master for
 292     # the transient. Otherwise use ".". (The splash screen will
 293     # need ".", for example.)
 294     set srcs [ManagedWin::find SrcWin]
 295     if {[llength $srcs] > 0} {
 296       set w [winfo toplevel [namespace tail [lindex $srcs 0]]]
 297     } else {
 298       set w .
 299     }
 300     wm transient $top $w
 301   } elseif {$::gdbtk_platform(platform) == "unix"} {
 302     # Modal dialogs DONT get Icons...
 303     if {[pref get gdb/use_icons] && ![$newwin isa ModalDialog]} {
 304       set icon [_make_icon_window ${top}_icon]
 305       wm iconwindow $top $icon
 306       bind $icon <Double-1> "$newwin reveal"
 307     }
 308   }
 309
 310   if {[info exists ::env(GDBTK_TEST_RUNNING)] && $::env(GDBTK_TEST_RUNNING)} {
 311     set g "+100+100"
 312     wm geometry $top $g
 313     wm positionfrom $top user
 314   } else {
 315     set g [pref getd gdb/geometry/$newwin]
 316     if {$g == "1x1+0+0"} {
 317       dbug E "bad geometry"
 318       set g ""
 319     }
 320     if {$g != ""} {
 321       # OK. We have a requested geometry. We know that it fits on the screen
 322       # because we set the maxsize.  Now we have to make sure it will not be
 323       # displayed off the screen.
 324       set w 0; set h 0; set x 0; set y 0
 325       if {![catch {scan $g  "%dx%d%d%d" w h x y} res]} {
 326         if {$x < 0} {
 327           set x [expr $_screenwidth + $x]
 328         }
 329         if {$y < 0} {
 330           set y [expr $_screenheight + $y]
 331         }
 332
 333         # If the window is transient, then don't reset its size, since
 334         # the user didn't set this anyway, and in some cases where the
 335         # size can change dynamically, like the Global Preferences
 336         # dialog, this can hide parts of the dialog with no recourse...
 337
 338         # if dont_remember_size is true, don't set size, just like
 339         # transients
 340
 341         if {$transient || [dont_remember_size]} {
 342           set g "+${x}+${y}"
 343         } else {
 344           set g "${w}x${h}+${x}+${y}"
 345         }
 346         if {[expr $x+50] < $_screenwidth && [expr $y+20] < $_screenheight} {
 347           wm positionfrom $top user
 348           wm geometry $top $g
 349           set ::$top._init_geometry $g
 350         }
 351       }
 352     }
 353   }
 354
 355   bind $top <Alt-F4> [list delete object $newwin]
 356
 357   return $newwin
 358 }
 359
 360 # ------------------------------------------------------------
 361 #  PUBLIC PROC:  find
 362 # ------------------------------------------------------------
 363 itcl::body ManagedWin::find { win } {
 364   debug "$win"
 365   set res ""
 366   foreach obj [itcl::find objects -isa ManagedWin] {
 367     if {[$obj isa $win]} {
 368       lappend res $obj
 369     }
 370   }
 371   return $res
 372 }
 373
 374 # ------------------------------------------------------------
 375 #  PUBLIC PROC:  init
 376 # ------------------------------------------------------------
 377 itcl::body ManagedWin::init {} {
 378   wm withdraw .
 379   set _screenheight [winfo screenheight .]
 380   set _screenwidth [winfo screenwidth .]
 381 }
 382
 383 # ------------------------------------------------------------
 384 #  PUBLIC METHOD:  destroy_toplevel
 385 # ------------------------------------------------------------
 386 itcl::body ManagedWin::destroy_toplevel {} {
 387   after idle "update idletasks;destroy $_top"
 388 }
 389
 390 # ------------------------------------------------------------
 391 #  PROTECTED METHOD:  _freeze_me
 392 # ------------------------------------------------------------
 393 itcl::body ManagedWin::_freeze_me {} {
 394   $_top configure -cursor watch
 395   ::update idletasks
 396 }
 397
 398 # ------------------------------------------------------------
 399 #  PROTECTED METHOD: _thaw_me
 400 # ------------------------------------------------------------
 401 itcl::body ManagedWin::_thaw_me {} {
 402
 403   $_top configure -cursor {}
 404   ::update idletasks
 405 }
 406
 407 # ------------------------------------------------------------------
 408 #  PRIVATE PROC: _make_icon_window - create a small window with an
 409 #   icon in it for use by certain Unix window managers.
 410 # ------------------------------------------------------------------
 411 itcl::body ManagedWin::_make_icon_window {name {file "gdbtk_icon"}} {
 412   if {![winfo exists $name]} {
 413     toplevel $name
 414     label $name.im -image \
 415       [image create photo icon_photo -file [file join $::gdb_ImageDir $file.gif]]
 416   }
 417   pack $name.im
 418   return $name
 419 }