perllib/FVWM/Module/Tk.pm

   1 # Copyright (c) 2003-2009 Mikhael Goikhman
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program; if not, write to the Free Software
  15 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16
  17 package FVWM::Module::Tk;
  18
  19 use 5.004;
  20 use strict;
  21
  22 use FVWM::Module::Toolkit qw(base Tk Tk::Dialog Tk::ROText);
  23
  24 sub new ($@) {
  25         my $class = shift;
  26         # support the old API with the first top-level argument
  27         my $top = shift if @_ && UNIVERSAL::isa($_[0], "Tk::Toplevel");
  28         my %params = @_;
  29
  30         $top = delete $params{TopWindow} if exists $params{TopWindow};
  31         my $self = $class->SUPER::new(%params);
  32
  33         $self->internal_die("TopWindow given in constructor is not Tk::Toplevel")
  34                 unless $top || UNIVERSAL::isa($top, "Tk::Toplevel");
  35         unless ($top) {
  36                 $top = MainWindow->new;
  37                 $top->withdraw;
  38         }
  39
  40         $self->{top_window} = $top;
  41
  42         return $self;
  43 }
  44
  45 sub event_loop ($) {
  46         my $self = shift;
  47         my @params = @_;
  48
  49         $self->event_loop_prepared(@params);
  50         my $top = $self->{top_window};
  51         $top->fileevent($self->{istream},
  52                 readable => sub {
  53                         unless ($self->process_packet($self->read_packet)) {
  54                                 if ($self->{disconnected}) {
  55                                         # Seems like something does not want to exit - force it.
  56                                         # For example, a new Tk window is launched on ON_EXIT.
  57                                         $top->destroy if defined $top && defined $top->{Configure};
  58                                         $self->debug("Forced to exit to escape event_loop, fix the module", 0);
  59                                         exit 1;
  60                                 }
  61                                 $self->event_loop_finished(@params);
  62                                 $top->destroy;
  63                         } else {
  64                                 $self->event_loop_prepared(@params);
  65                         }
  66                 }
  67         );
  68         MainLoop;
  69 }
  70
  71 sub show_error ($$;$) {
  72         my $self = shift;
  73         my $error = shift;
  74         my $title = shift || ($self->name . " Error");
  75
  76         my $top = $self->{top_window};
  77
  78         my $dialog = $top->Dialog(
  79                 -title => $title,
  80                 -bitmap => 'error',
  81                 -default_button => 'Close',
  82                 -text => $error,
  83                 -buttons => ['Close', 'Close All Errors', 'Exit Module'],
  84         );
  85         my $btn = $dialog->Show;
  86
  87         $self->terminate if $btn eq 'Exit Module';
  88         $self->send("All ('$title') Close") if $btn eq 'Close All Errors';
  89 }
  90
  91 sub show_message ($$;$) {
  92         my $self = shift;
  93         my $msg = shift;
  94         my $title = shift || ($self->name . " Message");
  95
  96         $self->{top_window}->messageBox(
  97                 -icon => 'info',
  98                 -type => 'ok',
  99                 -title => $title,
 100                 -message => $msg,
 101         );
 102 }
 103
 104 sub show_debug ($$;$) {
 105         my $self = shift;
 106         my $msg = shift;
 107         my $title = shift || ($self->name . " Debug");
 108
 109         my $dialog = $self->{tk_debug_dialog};
 110
 111         my $top = $self->{top_window};
 112         unless (defined $top && defined $top->{Configure}) {
 113                 # in the constructor (too early) or in destructor (too late)
 114                 $self->FVWM::Module::Toolkit::show_debug($msg, $title);
 115                 return;
 116         }
 117
 118         if (!$dialog) {
 119                 # Tk's Dialog widgets are too damn inflexible.
 120                 # It's less hassle to build one from scratch.
 121                 $dialog = $top->Toplevel(-title => $title);
 122                 my $scroll = $dialog->Frame()->pack(-expand => 1, -fill => 'both');
 123                 my $bottom = $dialog->Frame()->pack(-expand => 0, -fill => 'x');
 124                 my $text = $scroll->Scrolled('ROText',
 125                         -bg => 'white',
 126                         -wrap => 'word',
 127                         -scrollbars => 'oe',
 128                 )->pack(-expand => 1, -fill => 'both');
 129
 130                 $dialog->protocol('WM_DELETE_WINDOW', sub { $dialog->withdraw(); });
 131                 my @pack_opts = (-side => 'left', -expand => 1, -fill => 'both');
 132
 133                 $bottom->Button(
 134                         -text => 'Close',
 135                         -command => sub { $dialog->withdraw(); },
 136                 )->pack(@pack_opts);
 137                 $bottom->Button(
 138                         -text => 'Clear',
 139                         -command => sub { $text->delete('0.0', 'end'); },
 140                 )->pack(@pack_opts);
 141                 $bottom->Button(
 142                         -text => 'Save',
 143                         -command => sub {
 144                                 my $file = $dialog->getSaveFile(-title => "Save $title");
 145                                 return unless defined $file;
 146                                 if (!open(OUT, ">$file")) {
 147                                         $self->show_error("Couldn't save $file: $!", 'Save Error');
 148                                         return;
 149                                 }
 150                                 print OUT $text->get('0.0', 'end');
 151                                 close(OUT);
 152                         },
 153                 )->pack(@pack_opts);
 154
 155                 $self->{tk_debug_dialog} = $dialog;
 156                 $self->{tk_debug_text_wg} = $text;
 157         } else {
 158                 $dialog->deiconify() if $dialog->state() eq 'withdrawn';
 159         }
 160         my $text = $self->{tk_debug_text_wg};
 161         $text->insert('end', "$msg\n");
 162         $text->see('end');
 163 }
 164
 165 sub top_window ($) {
 166         return shift->{top_window};
 167 }
 168
 169 1;
 170
 171 __END__
 172
 173 =head1 NAME
 174
 175 FVWM::Module::Tk - FVWM::Module with the Tk widget library attached
 176
 177 =head1 SYNOPSIS
 178
 179 Name this module TestModuleTk, make it executable and place in ModulePath:
 180
 181     #!/usr/bin/perl -w
 182
 183     use lib `fvwm-perllib dir`;
 184     use FVWM::Module::Tk;
 185     use Tk;  # preferably in this order
 186
 187     my $top = new MainWindow(-name => "Simple Test");
 188     my $id = $top->wrapper->[0];
 189
 190     my $module = new FVWM::Module::Tk(
 191         TopWindow => $top,
 192         Mask => M_ICONIFY | M_ERROR,  # Mask may be omitted
 193         Debug => 2,
 194     );
 195     $top->Button(
 196         -text => "Close", -command => sub { $top->destroy; }
 197     )->pack;
 198
 199     $module->add_default_error_handler;
 200     $module->add_handler(M_ICONIFY, sub {
 201         my $id0 = $_[1]->_win_id;
 202         $module->send("Iconify off", $id) if $id0 == $id;
 203     });
 204     $module->track('Scheduler')->schedule(60, sub {
 205         $module->show_message("You run this module for 1 minute")
 206     });
 207
 208     $module->send('Style "*imple Test" Sticky');
 209     $module->event_loop;
 210
 211 =head1 DESCRIPTION
 212
 213 The B<FVWM::Module::Tk> class is a sub-class of B<FVWM::Module::Toolkit>
 214 that overloads the methods B<new>, B<event_loop>, B<show_message>,
 215 B<show_debug> and B<show_error> to manage Tk objects as well. It also adds new
 216 method B<top_window>.
 217
 218 This manual page details only those differences. For details on the
 219 API itself, see L<FVWM::Module>.
 220
 221 =head1 METHODS
 222
 223 Only overloaded or new methods are covered here:
 224
 225 =over 8
 226
 227 =item B<new> I<param-hash>
 228
 229 $module = new B<FVWM::Module::Tk> I<TopWindow> => $top, %params
 230
 231 Create and return an object of the B<FVWM::Module::Tk> class.
 232 This B<new> method is identical to the (grand-)parent class method, with the
 233 exception that a Tk top-level of some sort (MainWindow, TopLevel, Frame,
 234 etc.) may be passed in the hash of options using the I<TopWindow> named value.
 235 Other options in I<param-hash> are the same as described in L<FVWM::Module>.
 236
 237 If no top-level window is specified in the constructor, such dummy window
 238 is created and immediately withdrawn. This top-level window is needed to
 239 create Tk dialogs.
 240
 241 =item B<event_loop>
 242
 243 From outward appearances, this methods operates just as the parent
 244 B<event_loop> does. It is worth mentioning, however, that this version
 245 enters into the Tk B<MainLoop> subroutine, ostensibly not to return.
 246
 247 =item B<show_error> I<msg> [I<title>]
 248
 249 This method creates a dialog box using the Tk widgets. The dialog has
 250 three buttons labeled "Close", "Close All Errors" and "Exit Module".
 251 Selecting the "Close" button closes the dialog. "Close All Errors" closes
 252 all error dialogs that may be open on the screen at that time.
 253 "Exit Module" terminates your entire module.
 254
 255 Good for diagnostics of a Tk based module.
 256
 257 =item B<show_message> I<msg> [I<title>]
 258
 259 Creates a message window with one "Ok" button.
 260
 261 Useful for notices by a Tk based module.
 262
 263 =item B<show_debug> I<msg> [I<title>]
 264
 265 Creates a debug window with 3 buttons "Close", "Clear" and "Save".
 266 All debug messages are added to the debug window.
 267
 268 "Close" withdraws the window until the next debug message arrives.
 269
 270 "Clear" erases the current contents of the debug window.
 271
 272 "Save" dumps the current contents of the debug window to the selected file.
 273
 274 Useful for debugging a Tk based module.
 275
 276 =item B<top_window>
 277
 278 Returns the Tk toplevel that this object was created with.
 279
 280 =back
 281
 282 =head1 BUGS
 283
 284 Would not surprise me in the least.
 285
 286 =head1 AUTHOR
 287
 288 Mikhael Goikhman <migo@homemail.com>.
 289
 290 =head1 THANKS TO
 291
 292 Randy J. Ray <randy@byz.org>, author of the old classes
 293 B<X11::Fvwm> and B<X11::Fvwm::Tk>.
 294
 295 Scott Smedley <ss@aao.gov.au>.
 296
 297 Nick Ing-Simmons <Nick.Ing-Simmons@tiuk.ti.com> for Tk Perl extension.
 298
 299 =head1 SEE ALSO
 300
 301 For more information, see L<fvwm>, L<FVWM::Module> and L<Tk>.
 302
 303 =cut