tests/perl/module-tkdesker

   1 #!/usr/bin/perl -w
   2
   3 #
   4 # A simpler version of the pager, that only switches between desktops without
   5 # the outlines of windows. Patterned after the built-in pager that comes with
   6 # tkGoodStuff.
   7 #
   8 # Randy J. Ray, adapted by Mikhael Goikhman.
   9 #
  10 # Usage:
  11 #
  12 #   *FvwmPerlTkDesker: Rows 2
  13 #   *FvwmPerlTkDesker: Background bisque
  14 #   *FvwmPerlTkDesker: Font 7x14
  15 #   *FvwmPerlTkDesker: Title Perl/Tk Desker
  16 #   Style *Desker Sticky
  17 #   /path/to/tests/perl/module-tkdesker 0 3
  18 #
  19
  20 use 5.003;
  21 use strict;
  22 use vars qw($TOP $desker %opts $current_desk $frame @buttons @desk_focus);
  23
  24 use lib `fvwm-perllib dir`;
  25 use FVWM::Module::Tk;
  26 use Tk;
  27
  28 my $TOP = new MainWindow;
  29 my $desker = new FVWM::Module::Tk($TOP,
  30         Name => "FvwmPerlTkDesker",
  31         Mask => (M_NEW_DESK | M_FOCUS_CHANGE | M_ERROR),
  32 );
  33 &read_desker_options($desker, $TOP);
  34
  35 $frame = $TOP->Frame;
  36 $TOP->title($opts{Title} || $desker->name);
  37 $TOP->geometry($opts{Geometry}) if (defined $opts{Geometry});
  38 &make_buttons($frame, $desker);
  39 $frame->pack(-expand => 1, -fill => 'both', -anchor => 'nw');
  40
  41 $desker->add_handler(M_NEW_DESK, sub {
  42         my ($self, $event) = @_;
  43         my $desk = $event->_desk;
  44
  45         &unhilite($current_desk);
  46         return if $desk < $opts{START} or $desk > $opts{'END'};
  47         $current_desk = $desk;
  48         &hilite($current_desk, $self);
  49 });
  50 $desker->add_handler(M_FOCUS_CHANGE, sub {
  51         my ($self, $event) = @_;
  52
  53         $desk_focus[$current_desk] = $event->_win_id;
  54 });
  55 $desker->add_default_error_handler;
  56
  57 #
  58 # Any signals we need to be wary of?
  59 #
  60 $SIG{PIPE} = sub { exit };
  61
  62 $current_desk = &current_desk($desker);
  63 &hilite($current_desk);
  64
  65 $desker->event_loop; # Never returns
  66
  67 exit;
  68
  69 sub read_desker_options ($$) {
  70         my $mod = shift;
  71         my $top = shift;
  72
  73         my @args = $mod->argv;
  74
  75         if (@args < 2) {
  76                 my $name = $mod->name;
  77                 $mod->show_error("$name requires start and end params");
  78                 die "Usage: $0 #start #end [ -name name_string ]\n";
  79         }
  80
  81         my $START = shift(@args);
  82         my $END   = shift(@args);
  83
  84         for ($START .. $END) { $desk_focus[$_] = undef }
  85
  86         if ($args[0] && $args[0] eq '-name' && $args[1]) {
  87                 $mod->name($args[1]);
  88         }
  89
  90         ### To fix
  91         %opts = ();  #$mod->get_config_info();
  92
  93         $top->optionAdd('*foreground', $opts{Foreground})
  94                 if (exists $opts{Foreground});
  95         $top->optionAdd('*background', $opts{Background})
  96                 if (exists $opts{Background});
  97         $top->optionAdd('*font', $opts{Font}) if (exists $opts{Font});
  98
  99         $opts{ROWS} = $opts{Rows} || 1;
 100         $opts{COLS} = $opts{Columns} || int(($END - $START + 1) / $opts{ROWS});
 101         $opts{START} = $START;
 102         $opts{'END'} = $END;
 103 }
 104
 105 sub make_buttons ($$) {
 106         my $top = shift;
 107         my $mod = shift;
 108
 109         my ($start, $end, $cols, $rows) =
 110                 ($opts{START}, $opts{'END'}, $opts{COLS},  $opts{ROWS});
 111         my ($x, $y, $text, $button, $frame, @labels);
 112
 113         die "Managed desks ($start to $end) must exactly fit in ${cols}x$rows "
 114                 . "space, stopped.\n"
 115                 if $cols * $rows != $end - $start + 1;
 116
 117         if (exists $opts{Label} and ref($opts{Label}) eq 'ARRAY') {
 118                 my ($each, $pos, $string);
 119
 120                 for $each (@{$opts{Label}}) {
 121                         ($pos, $string) = split(/ /, $each, 2);
 122                         $labels[$pos] = $string;
 123                 }
 124         }
 125
 126         for ($x = 0; $x < $cols; $x++) {
 127                 $frame = $top->Frame;
 128                 for ($y = 0; $y < $rows; $y++) {
 129                         my $pos = $start + $x + ($y * $cols);
 130
 131                         $button = $frame->Label(-relief => 'raised');
 132                         $button->bind('<1>', sub {
 133                                 $mod->send("Desk 0 $pos");
 134                         });
 135                         $text = $labels[$pos] || "Desk $pos";
 136                         $button->configure(-text => "$text")
 137                                 unless (exists $opts{NoLabels} and $opts{NoLabels} !~ /no/oi);
 138
 139                         $button->pack(-side => 'top', -expand => 1, -fill => 'both');
 140
 141                         # This index happens to match the desk #, for (un)hilite
 142                         $buttons[$pos] = $button;
 143                 }
 144                 $frame->pack(-side => 'left', -expand => 1, -fill => 'both');
 145         }
 146 }
 147
 148 sub hilite ($$) {
 149         my $desk = shift;
 150         my $mod = shift;
 151
 152         my $button = $buttons[$desk];
 153
 154         if (exists $opts{CurrentDeskBackground}) {
 155                 $button->configure(-background => $opts{CurrentDeskBackground});
 156                 $button->configure(-foreground => $opts{CurrentDeskForeground})
 157                         if exists $opts{CurrentDeskForeground};
 158         } else {
 159                 $button->configure(-relief => 'sunken');
 160         }
 161         #$mod->send("Focus", $desk_focus[$desk])
 162         #       if (defined $desk_focus[$desk]);
 163 }
 164
 165 sub unhilite ($) {
 166         my $desk = shift;
 167
 168         my $button = $buttons[$desk];
 169
 170         if (exists $opts{CurrentDeskBackground}) {
 171                 $button->configure(-background => $opts{Background});
 172                 $button->configure(-foreground => $opts{Foreground})
 173                         if exists $opts{CurrentDeskForeground};
 174         } else {
 175                 $button->configure(-relief => 'raised');
 176         }
 177 }
 178
 179 sub current_desk ($) {
 180         my $mod = shift;
 181
 182         # not implemented
 183
 184         return 0;
 185 }