FAQ Perl/TkConsultez toutes les FAQ

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
#!/usr/bin/perl 
use warnings; 
use strict; 
  
use Tk; 
use Tk::TableMatrix; 
use utf8; 
  
my $mw = MainWindow->new( 
  -title      => 'Tableau TableMatrix', 
  -background => 'snow', 
); 
$mw->Label( 
  -text       => "Tableau redimensionnable à l'aide de TableMatrix", 
  -background => 'snow', 
  -font       => '{arial} 12 bold' 
)->pack( -pady => 5 ); 
  
my $data = {}; 
  
# Création du tableau avec une ligne et une colonne 
my $table = $mw->Scrolled( 
  'TableMatrix', 
  -rows          => 1, 
  -cols          => 1, 
  -width         => 500, 
  -height        => 500, 
  -variable      => $data, 
  -rowtagcommand => \&type_row, 
  -background    => "#454545", 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -drawmode      => 'single', 
  -selectmode    => 'extended', 
  -scrollbars    => 'osoe', 
); 
  
# Insertion de données dans le tableau 
for my $row ( 0 .. 20 ) { 
  
  # Calcul du nombre de lignes dans le tableau 
  my $number_rows = $table->cget( -rows ); 
  
  # Insertion d'une ligne si nécessaire 
  $table->insertRows( 'end', 1 ) if ( $number_rows < $row + 1 ); 
  
  for my $col ( 0 .. 10 ) { 
  
    # Calcul du nombre de lignes dans le tableau 
    my $number_cols = $table->cget( -cols ); 
  
    # Insertion d'une colonne si nécessaire 
    $table->insertCols( 'end', 1 ) if ( $number_cols < $col + 1 ); 
  
    # Ligne de titre 
    if ( $row == 0 and $col != 0 ) { 
      $data->{"$row,$col"} = "Colonne $col"; 
    } 
  
    # Colonne de titre 
    elsif ( $col == 0 and $row != 0 ) { 
      $data->{"$row,$col"} = "Ligne $row"; 
    } 
    elsif ( $col == 0 and $row == 0 ) { 
  
      # rien ne se passe; 
    } 
  
    # Données 
    else { 
      $data->{"$row,$col"} = "($row,$col)"; 
    } 
  } 
} 
  
# Configuration des lignes paires et impaires 
$table->tagConfigure( 
  'pair_row', 
  -bg     => 'white', 
  -fg     => 'black', 
  -relief => 'sunken', 
  -state  => 'disabled' 
); 
$table->tagConfigure( 
  'impair_row', 
  -bg     => '#00C0E0', 
  -fg     => 'black', 
  -relief => 'sunken', 
  -state  => 'disabled' 
); 
$table->tagConfigure( 'title', -bg => '#F0E0FF', -fg => 'black', -relief => 'sunken' ); 
# Fusion des cellules 1,1 à 1,4 
$table->spans( '1,1' => '0,3' ); 
$table->pack(qw/ -fill both -expand 1 -padx 10 -pady 10 /); 
  
MainLoop; 
  
# Permet d'assigner un tag aux lignes paires et impaires 
sub type_row { 
  my $row = shift; 
  my $tag_row = ( $row > 0 && $row % 2 == 0 ) ? "pair_row" : "impair_row"; 
  
  return $tag_row; 
}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
#!/usr/bin/perl -w 
  
## THIS IS ONE OF THE TEST SCRIPTS THAT HANS PROVIDED WITH MLISTBOX 
## It IS STILL UNDERGOING EDITS BY ME - RCS 
  
## MListbox demonstration application. This is a simple directory browser 
## Original Author: Hans J. Helgesen, December 1999. 
## Modified by: Rob Seegel, to work in Win32 as well 
## Use and abuse this code. I did - RCS 
  
use File::stat; 
use Tk; 
use Tk::MListbox; 
  
## Create main perl/tk window. 
my $mw = MainWindow->new; 
  
## Create the MListbox widget. 
## Specify alternative comparison routine for integers and date. 
## frame, but since the "Show All" button references $ml, we have to create 
## it now. 
  
my %red   = qw(-bg red -fg white); 
my %green = qw(-bg green -fg white); 
my %white = qw(-fg black); 
  
my $ml = $mw->Scrolled( 
  'MListbox', 
  -scrollbars         => 'osoe', 
  -background         => 'white', 
  -foreground         => 'blue', 
  -textwidth          => 10, 
  -highlightthickness => 2, 
  -width              => 0, 
  -selectmode         => 'browse', 
  -bd                 => 2, 
  -relief             => 'sunken', 
  -columns            => [ 
    [ qw/-text Mode -textwidth 10/, %red ], 
    [ qw/-text NLink -textwidth 5/, %green, -comparecmd => sub { $_[0] <=> $_[1] } ], 
    [ qw/-text UID/,                %white ], 
    [ qw/-text GID/,                %green ], 
    [ qw/-text Size/,               %red,   -comparecmd => sub { $_[0] <=> $_[1] } ], 
    [ qw/-text Mtime/, %green, -comparecmd => \&compareDate ], 
    [ qw/-text Name/,  %white ] 
  ] 
); 
  
## Put the exit button and the "Show All" button in 
## a separate frame. 
my $f = $mw->Frame( 
  -bd     => 2, 
  -relief => 'groove' 
)->pack(qw/-anchor w -expand 0 -fill x/); 
  
$f->Button( 
  -text    => 'Exit', 
  -command => sub {exit} 
)->pack(qw/-side right -anchor e/); 
  
$f->Button( 
  -text    => 'Show All', 
  -command => sub { 
    foreach ( $ml->columnGet( 0, 'end' ) ) { 
      $ml->columnShow($_); 
    } 
  } 
)->pack(qw/-side left -anchor w/); 
  
# Put the MListbox widget on the bottom of the main window. 
$ml->pack( -expand => 1, -fill => 'both', -anchor => 'w' ); 
  
# Double clicking any of the data rows calls openFileOrDir() 
# (But only directories are handled for now...) 
$ml->bindRows( "<Double-Button-1>", \&openFileOrDir ); 
  
# Right-clicking the column heading creates the hide/show popup menu. 
$ml->bindColumns( "<Button-3>", [ \&columnPopup ] ); 
  
$ml->bindRows( 
  '<ButtonRelease-1>', 
  sub { 
    my ( $w, $infoHR ) = @_; 
    print "You selected row: " . $infoHR->{-row} . " in column: " . $infoHR->{-column} . "\n"; 
  } 
); 
  
# Start by showing the current directory. 
directory("."); 
  
MainLoop; 
  
#---------------------------------------------------------- 
# 
sub directory { 
  my ($dir) = @_; 
  
  chdir($dir); 
  
  my $pwd = `pwd`; 
  chomp $pwd; 
  $mw->title("Directory: $pwd"); 
  
  # Empty $ml 
  $ml->delete( 0, 'end' ); 
  
  opendir( DIR, "." ) or die "Cannot open '.': $!\n"; 
  
  foreach my $name ( readdir(DIR) ) { 
    my $st   = stat($name); 
    my $mode = $st->mode; 
  
    my $type = do { 
      if ( -l $name ) { 
        $mode = 0777; 
        'l'; 
      } 
      elsif ( -f $name ) { 
        '-'; 
      } 
      elsif ( -d $name ) { 
        'd'; 
      } 
      elsif ( -p $name ) { 
        'p'; 
      } 
      elsif ( -b $name ) { 
        'b'; 
      } 
      elsif ( -c $name ) { 
        'c'; 
      } 
      else { 
        ' '; 
      } 
    }; 
  
    my $mtime = localtime( $st->mtime ); 
    $mode = $type . convMode( $st->mode ); 
    $ml->insert( 'end', [ $mode, $st->nlink, $st->uid, $st->gid, $st->size, $mtime, $name ] ); 
  } 
} 
  
# This callback is called if the user double-clicks one of the rows in 
# the MListbox. If the selected file is a directory, open it. 
# 
sub openFileOrDir { 
  my @sel = $ml->curselection; 
  if ( @sel == 1 ) { 
    my ( $mode, $name ) = ( $ml->getRow( $sel[0] ) )[ 0, 6 ]; 
    if ( $mode =~ m/^d/ ) {    # Directory? 
      directory($name); 
    } 
  } 
} 
  
# This callback is called if the user right-clicks the column heading. 
# Create a popupmenu with hide/show options. 
sub columnPopup { 
  my ( $w, $infoHR ) = @_; 
  
  # Create popup menu. 
  my $menu = $w->Menu( -tearoff => 0 ); 
  my $index = $infoHR->{'-column'}; 
  
  # First item is "Hide (this column)". 
  # 
  $menu->add( 
    'command', 
    -label   => "Hide " . $w->columnGet($index)->cget( -text ), 
    -command => sub { 
      $w->columnHide($index); 
    } 
  ); 
  $menu->add('separator'); 
  
  # Create a "Show" entry for each column that is not currently visible. 
  # 
  foreach ( $w->columnGet( 0, 'end' ) ) {    # Get all columns from $w. 
    unless ( $_->ismapped ) { 
      $menu->add( 
        'command', 
        -label   => "Show " . $_->cget( -text ), 
        -command => [ $w => 'columnShow', $_, -before => $index ], 
      ); 
    } 
  } 
  $menu->Popup( -popover => 'cursor' ); 
} 
  
# Converts a numeric file mode to the format provided by the ls command. 
# 
sub convMode { 
  my $mode   = shift; 
  my $result = ''; 
  
  $result .= ( $mode & 0400 ) ? 'r' : '-'; 
  $result .= ( $mode & 0200 ) ? 'w' : '-'; 
  if ( $mode & 0100 ) { 
    if ( $mode & 04000 ) { 
      $result .= 's'; 
    } 
    else { 
      $result .= 'x'; 
    } 
  } 
  else { 
    $result .= '-'; 
  } 
  
  $result .= ( $mode & 040 ) ? 'r' : '-'; 
  $result .= ( $mode & 020 ) ? 'w' : '-'; 
  if ( $mode & 010 ) { 
    if ( $mode & 02000 ) { 
      if ( ( $mode & 02010 ) 
        || ( $mode & 02030 ) 
        || ( $mode & 02050 ) 
        || ( $mode & 02070 ) ) 
      { 
        $result .= 's'; 
      } 
      else { 
        $result .= 'l'; 
      } 
    } 
    else { 
      $result .= 'x'; 
    } 
  } 
  else { 
    $result .= '-'; 
  } 
  
  $result .= ( $mode & 04 ) ? 'r' : '-'; 
  $result .= ( $mode & 02 ) ? 'w' : '-'; 
  $result .= ( $mode & 01 ) ? 'x' : '-'; 
  
  return $result; 
} 
  
# Callback for date comparison. Expects that the dates are on the format 
# "day mon dd hh:mm:ss yyyy", for example "Tue Dec  7 12:13:11 1999". 
# 
sub compareDate { 
  my ( $d1, $d2 ) = @_; 
  convertDate($d1) cmp convertDate($d2); 
} 
  
sub convertDate { 
  my ($str) = @_; 
  my ( $wday, $mon, $day, $hour, $min, $sec, $year ) 
    = ( $str =~ m/(\S*)\s*(\S*)\s*(\d*)\s*(\d\d):(\d\d):(\d\d)\s*(\d\d\d\d)/ ); 
  
  my $month = 0; 
  foreach (qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/) { 
    if ( $mon eq $_ ) { 
      last; 
    } 
    else { 
      $month++; 
    } 
  } 
  return sprintf( "%04d%02d%02d%02d%02d%02d", $year, $month, $day, $hour, $min, $sec ); 
}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
#!/usr/bin/perl -w 
  
# MListbox demonstration application. 
  
# Author: Hans J. Helgesen, December 1999. 
# 
# Before March 2000: 
# 
# Please send comments, suggestions and error reports to 
# hans_helgesen@hotmail.com. 
# 
# From March 2000: hans.helgesen@novit.no 
# 
use Tk; 
use Tk::MListbox; 
use Tk::Pane; 
use DBI; 
  
my $intro = <<EOT; 
This is a very simple DBI application that demonstrates the use of MListbox $Tk::MListbox::VERSION. 
  
* To execute a query, type the query in the query window and click "GO". 
* To resize any of the columns, drag the vertical bar to the RIGHT of the column. 
* To move any of the columns, drag the column header left or right. 
* To sort the table, click on any of the column headers. A new click will reverse the sort order. 
  
Note that this program calls MListbox->insert, MListbox->see and MListbox->update once FOR EACH ROW  
fetched from the database. This is not very efficient, a better approach would be to store all rows  
in an array, and then call MListbox->insert once when the query is done. 
  
EOT 
  
my $status = 'Idle'; 
  
# Check argument. 
if ( @ARGV != 3 ) { 
  print STDERR "Usage: $0 source userid password\n"; 
  print STDERR "Example: $0 dbi:Oracle:oradb peter secretpwd\n"; 
  exit 1; 
} 
  
# Connect to the database. 
my $dbh = DBI->connect(@ARGV) or die "Can't connect: $DBI::errstr\n"; 
  
# Create Tk window... 
my $mw = new MainWindow; 
$mw->title("SQL $ARGV[1]\@$ARGV[0]"); 
  
$mw->Label( -text => $intro, -justify => 'left' )->pack( -anchor => 'w' ); 
  
my $f = $mw->Frame->pack( -fill => 'x', -anchor => 'w' ); 
my $text = $f->Scrolled( 
  'Text', 
  -scrollbars => 'osoe', 
  -width      => 80, 
  -height     => 5 
  )->pack( 
  -side   => 'left', 
  -expand => 1, 
  -fill   => 'both' 
  ); 
  
$text->insert( 'end', "select * from all_objects where object_type='TABLE'" ); 
$f = $f->Frame->pack( -side => 'left' ); 
  
$f->Button( 
  -text    => 'Go', 
  -command => sub { 
    $mw->Busy( -recurse => 1 ); 
    execSQL(); 
    $mw->Unbusy; 
  } 
)->pack; 
  
$f->Button( 
  -text    => 'Clear', 
  -command => sub { 
    $text->delete( '0.0', 'end' ); 
  } 
)->pack; 
  
$f->Button( 
  -text    => 'Exit', 
  -command => sub { 
    $dbh->disconnect; 
    exit; 
  } 
)->pack; 
  
# Put the MListbox in a Pane, since the MListbox don't support horizontal 
# scrolling by itself. 
# 
$f = $mw->Frame->pack( -fill => 'x' ); 
$f->Label( -text => 'Status:' )->pack( -side => 'left' ); 
$f->Label( -textvariable => \$status )->pack( -side => 'left' ); 
  
my $ml = $mw->Scrolled( 'MListbox', -scrollbars => 'osoe' )->pack( -expand => 1, -fill => 'both' ); 
  
MainLoop; 
  
#-------------------------------------------------------------------- 
# 
sub execSQL { 
  
  # Get the query from the text widget. 
  my $sql = $text->get( '0.0', 'end' ); 
  
  $status = 'Call prepare()'; 
  $mw->update; 
  
  my $sth = $dbh->prepare($sql); 
  unless ( defined $sth ) { 
    $text->insert( 'end', "\nprepare() failed: $DBI::errstr\n" ); 
    return; 
  } 
  $status = 'Call execute()'; 
  $mw->update; 
  unless ( $sth->execute ) { 
    $text->insert( 'end', "\nexecute() failed: $DBI::errstr\n" ); 
    return; 
  } 
  
  # Query OK, delete all old columns in $ml. 
  # 
  $ml->columnDelete( 0, 'end' ); 
  my $headings_defined = 0; 
  $status = 'Call fetchrow()'; 
  $mw->update; 
  my $rowcnt = 0; 
  
  while ( my $hashref = $sth->fetchrow_hashref ) { 
    unless ($headings_defined) { 
      foreach ( sort keys %$hashref ) { 
        $ml->columnInsert( 'end', -text => $_ ); 
      } 
      $headings_defined = 1; 
    } 
    my @row = (); 
    foreach ( sort keys %$hashref ) { 
      push @row, $hashref->{$_}; 
    } 
    $ml->insert( 'end', [@row] ); 
    $ml->see('end'); 
    $rowcnt++; 
    $status = "$rowcnt rows fetched"; 
    $ml->update; 
  } 
  $status = 'Idle'; 
}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
#!/usr/bin/perl 
use warnings; 
use strict; 
use Tk; 
use Tk::TableMatrix; 
  
my $top = MainWindow->new; 
  
my $arrayVar = {}; 
for my $r ( 0 .. 7 ) { 
  for my $c ( 0 .. 7 ) { 
    $arrayVar->{"$r,$c"} = 'test'; 
  } 
} 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -variable   => $arrayVar, 
  -selectmode => 'extended', 
  -bg         => 'white', 
  -fg         => 'black', 
); 
  
$t->configure( 
  -browsecmd => sub { 
    my ( $previous_index, $current_index ) = @_; 
  
    if ( $previous_index =~ m{^\d+,\d+$} ) { 
      my $value_previous_cell = $t->get($previous_index); 
  
      # check and validation 
      if ( $value_previous_cell =~ s{^(\d+)/(\d+)$}{$1/$2/2010} ) { 
        $t->activate($previous_index); 
        $t->curvalue($value_previous_cell); 
        $t->activate($current_index); 
      } 
  
    } 
  }, 
); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
  
MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
## buttons.tcl 
## 
## demonstrates the simulation of a button array 
## 
## ellson@lucent.com 
## modifications made by jeff.hobbs@acm.org 
##  Mdofied by John Cerney for perl/tk 
  
use Tk; 
  
use Tk::TableMatrix; 
  
use Data::Dumper qw( DumperX); 
my $top = MainWindow->new; 
  
my $tab = {}; 
my ( $rows, $cols ) = ( 10, 10 );    # number of rows/cols 
  
# create the table 
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows        => $rows, 
  -cols        => $cols, 
  -titlerows   => 1, 
  -titlecols   => 1, 
  -roworigin   => -1, 
  -colorigin   => -1, 
  -colwidth    => 4, 
  -width       => 8, 
  -height      => 8, 
  -variable    => $tab, 
  -flashmode   => 'off', 
  -cursor      => 'top_left_arrow', 
  -borderwidth => 2, 
  -state       => 'disabled' 
); 
$t->pack; 
  
# set up tags for the various states of the buttons 
$t->tagConfigure( 'OFF', -bg => 'red',    -relief => 'raised' ); 
$t->tagConfigure( 'ON',  -bg => 'green',  -relief => 'sunken' ); 
$t->tagConfigure( 'sel', -bg => 'gray75', -relief => 'flat' ); 
  
# clean up if mouse leaves the widget 
$t->bind( 
  '<FocusOut>', 
  sub { 
    my $w = shift; 
    $w->selectionClear('all'); 
  } 
); 
  
# highlight the cell under the mouse 
$t->bind( 
  '<Motion>', 
  sub { 
    my $w  = shift; 
    my $Ev = $w->XEvent; 
    if ( $w->selectionIncludes( '@' . $Ev->x . "," . $Ev->y ) ) { 
      Tk->break; 
    } 
    $w->selectionClear('all'); 
    $w->selectionSet( '@' . $Ev->x . "," . $Ev->y ); 
    Tk->break; 
    ## "break" prevents the call to TableMatrixCheckBorder 
  } 
); 
  
# mousebutton 1 toggles the value of the cell 
# use of "selection includes" would work here 
$t->bind( 
  '<1>', 
  sub { 
    my $w = shift; 
    $w->focus; 
    my $dude = $w->curselection; 
    my ($rc) = @{ $w->curselection }; 
    my $var  = $w->cget( -var ); 
    if ( $var->{$rc} =~ /ON/ ) { 
      $var->{$rc} = 'OFF'; 
      $w->tagCell( 'OFF', $rc ); 
    } 
    else { 
      $var->{$rc} = 'ON'; 
      $w->tagCell( 'ON', $rc ); 
    } 
  } 
); 
  
# inititialize the array, titles, and celltags 
for ( $i = 0; $i < $rows; $i++ ) { 
  $tab->{"$i,-1"} = $i; 
  for ( $j = 0; $j < $cols; $j++ ) { 
    unless ($i) { $tab->{"-1,$j"} = $j; } 
    $tab->{"$i,$j"} = "OFF"; 
    $t->tagCell( 'OFF', "$i,$j" ); 
  } 
} 
  
Tk::MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
## command.tcl 
## 
## This demo shows the use of the table widget's -command options 
## 
## jeff.hobbs@acm.org 
##  Converted to perl/tk by John Cerney 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my ( $rows, $cols ) = ( 10, 10 );    # number of rows/cols 
my $top = MainWindow->new; 
  
# Sub to fill the array variable 
sub fill { 
  
  my ( $array, $x, $y ) = @_; 
  my ( $i, $j ); 
  for ( $i = -$x; $i < $x; $i++ ) { 
    for ( $j = -$y; $j < $y; $j++ ) { 
      $array->{"$i,$j"} = "$i x $j"; 
    } 
  } 
} 
  
## Test out the use of a callback to define tags on rows and columns 
sub rowSub { 
  my $row = shift; 
  return "OddRow" if ( $row > 0 && $row % 2 ); 
} 
  
sub colSub { 
  my $col = shift; 
  return "OddCol" if ( $col > 0 && $col % 2 ); 
} 
  
sub tblCmd { 
  my ( $array, $set, $row, $col, $val ) = @_; 
  
  # my @args = @_; 
  # print "In Table Command, Args = '".join("', '",@args)."'\n"; 
  
  my $index = "$row,$col"; 
  if ($set) { 
    $array->{$index} = $val; 
  } 
  else { 
    if ( defined( $array->{$index} ) ) { 
      return $array->{$index}; 
    } 
    else { 
      return ''; 
    } 
  } 
} 
  
my $label = $top->Label( -text => "TableMatrix -command Example" ); 
  
# Label the changes with the value of currentTest 
my $currentText = ''; 
my $currentLabel = $top->Label( -textvariable => \$currentText ); 
  
# Entry that changes with the value of activeText 
my $activeText = ''; 
my $activeEntry = $top->Entry( -textvariable => \$activeText ); 
  
my $arrayVar = {}; 
  
fill( $arrayVar, $rows, $cols );    # fill up the array variable 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => $rows, 
  -cols          => $cols, 
  -width         => 6, 
  -height        => 6, 
  -titlerows     => 1, 
  -titlecols     => 2, 
  -command       => [ \&tblCmd, $arrayVar ], 
  -roworigin     => -1, 
  -colorigin     => -2, 
  -rowtagcommand => \&rowSub, 
  -coltagcommand => \&colSub, 
  -selectmode    => 'extended', 
  -flashmode     => 'on', 
  -variable      => $arrayVar, 
  
); 
  
$t->configure( 
  -browsecommand => sub { 
    my ($index) = @_; 
    $currentText = $index; 
    $activeText  = $t->get($index); 
  } 
); 
  
$t->configure( 
  -validate        => 1, 
  -validatecommand => sub { 
    my ( $row, $col, $old, $new, $index ) = @_; 
    $activeText = $new; 
    return 1; 
  } 
); 
$t->configure( 
  -selectioncommand => sub { 
    my ( $NumRows, $Numcols, $selection, $noCells ) = @_; 
    my @args = @_; 
    print "In Selection Command, Args = '" . join( "', '", @args ) . "'\n"; 
    return $selection; 
  } 
); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'OddRow', -bg => 'orange', -fg => 'purple' ); 
$t->tagConfigure( 'OddCol', -bg => 'brown',  -fg => 'pink' ); 
  
$t->colWidth( -2 => 7, -1 => 7, 1 => 5, 2 => 8, 4 => 14 ); 
  
$label->pack( -expand => 1, -fill => 'both' ); 
$currentLabel->pack( -expand => 1, -fill => 'both' ); 
$activeEntry->pack( -expand => 1, -fill => 'both' ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
  
Tk::MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
## version2.tcl 
## 
## This demo uses most features of the table widget 
## 
## jeff.hobbs@acm.org 
##  Converted to perl/tk by John Cerney 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my ( $rows, $cols ) = ( 25, 20 );    # number of rows/cols 
my $top = MainWindow->new; 
  
# Sub to fill the array variable 
sub fill { 
  
  my ( $array, $x, $y ) = @_; 
  my ( $i, $j ); 
  for ( $i = -$x; $i < $x; $i++ ) { 
    for ( $j = -$y; $j < $y; $j++ ) { 
      $array->{"$i,$j"} = "r$i,c$j"; 
    } 
  } 
} 
  
## Test out the use of a callback to define tags on rows and columns 
sub colSub { 
  my $col = shift; 
  return "OddCol" if ( $col > 0 && $col % 2 ); 
} 
  
my $label = $top->Label( -text => "TableMatrix v2 Example" ); 
  
my $arrayVar = {}; 
  
fill( $arrayVar, $rows, $cols );    # fill up the array variable 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => $rows, 
  -cols          => $cols, 
  -variable      => $arrayVar, 
  -width         => 6, 
  -height        => 8, 
  -titlerows     => 1, 
  -titlecols     => 2, 
  -roworigin     => -5, 
  -colorigin     => -2, 
  -coltagcommand => \&colSub, 
  -selectmode    => 'extended', 
  -selecttitles  => 0, 
  -drawmode      => 'single', 
  
); 
  
my $button = $top->Button( -text => "Exit", -command => sub { $top->destroy } ); 
$label->pack( -expand => 1, -fill => 'both' ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
$button->pack( -expand => 1, -fill => 'both' ); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'OddCol', -bg => 'brown', -fg => 'pink' ); 
$t->tagConfigure( 'title', -bg => 'red', -fg => 'blue', -relief => 'sunken' ); 
$t->tagConfigure( 'dis', -state => 'disabled' ); 
  
my $i     = -1; 
my $first = $t->cget( -colorigin ); 
my $anchor; 
foreach $anchor (qw/ n s e w nw ne sw se c /) { 
  $t->tagConfigure( $anchor, -anchor => $anchor ); 
  $t->tagRow( $anchor, ++$i ); 
  $t->set( "$i,$first", $anchor ); 
} 
$top->fontCreate( 'courier', -family => 'courier', -size => 10 ); 
$t->tagConfigure( 's', -font => 'courier', -justify => 'center' ); 
  
# $initWindow->Label(-image => $top->Photo(-file => Tk->findINC('Xcamel.gif')))->pack; 
  
my $perltkLogo = $top->Photo( -file => Tk->findINC('Xcamel.gif') ); 
  
$t->tagConfigure( 'logo', -image => $perltkLogo, -showtext => 1 ); 
$t->tagCell( 'logo', '1,2', '2,3',  '4,1' ); 
$t->tagCell( 'dis',  '2,1', '1,-1', '3,0' ); 
$t->colWidth(qw/ -2 8 -1 9 0 12 4 14/); 
  
$t->set( 
  '1,1' => "multi-line\ntext\nmight be\ninteresting", 
  '3,2' => "more\nmulti-line\nplaying\n", 
  '2,2' => "null\0byte" 
); 
  
$i = -1; 
  
# This is in the row span 
my $l = $top->Label( -text => "Window s", -bg => 'yellow' ); 
$t->windowConfigure( "6,0", -sticky => 's', -window => $l ); 
  
# This is in the row titles 
$l = $top->Label( -text => "Window ne", -bg => 'yellow' ); 
$t->windowConfigure( "4,-1", -sticky => 'ne', -window => $l ); 
  
# This will get swallowed by a span 
$l = $top->Label( -text => "Window ew", -bg => 'yellow' ); 
$t->windowConfigure( "5,3", -sticky => 'ew', -window => $l ); 
  
# This is in the col titles 
$l = $top->Label( -text => "Window nsew", -bg => 'yellow' ); 
$t->windowConfigure( "-5,1", -sticky => 'nsew', -window => $l ); 
  
$l = $t->parent->Label( -text => "Sibling l", -bg => 'orange' ); 
$t->windowConfigure( "5,1", -sticky => 'nsew', -window => $l ); 
  
$t->spans( '-1,-2' => '0,3', '1,2' => '0,5', '3,2' => '2,2', '6,0' => '4,0' ); 
  
Tk::MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
## edit_styles.pl 
## 
## demonstrates different edit styles within cells 
## 
## ewaldhei@idd.com 
  
## This script uses tags and some logic to simulate check 
##  buttons, browseEntries, etc in cells. This approach is 
##  faster than using embedded windows, especially for large 
##  tables. 
  
use Tk; 
use Tk::TableMatrix; 
  
main(); 
  
sub main { 
  my $top = MainWindow->new; 
  
  my $_data = {}; 
  my ( $rows, $cols ) = ( 12, 7 );    # number of rows/cols 
  
  # create the table 
  my $t = $top->Scrolled( 
    TableMatrix  => -rows => $rows, 
    -cols        => $cols, 
    -titlerows   => 1, 
    -titlecols   => 1, 
    -width       => 8, 
    -height      => 8, 
    -colwidth    => 11, 
    -variable    => $_data, 
    -cursor      => 'top_left_arrow', 
    -borderwidth => 2, 
    -ipadx       => 15, 
    -scrollbars  => 'se', 
  )->pack(qw/-expand 1 -fill both/); 
  
  my $tm = $t->Subwidget('scrolled'); 
  
  $tm->{columneditstyles} = { 
    qw(1 readonly 
      2 editable 
      3 button 
      4 optionmenu 
      5 browseentry 
      6 checkbutton 
      ) 
  }; 
  
  # set up tags for the various states of the buttons 
  $t->tagConfigure( 'OFF', -bg => 'gray60', -relief => 'raised' ); 
  $t->tagConfigure( 'ON',  -bg => 'gray80', -relief => 'sunken' ); 
  $t->tagConfigure( 'sel', -bg => 'gray70', -relief => 'flat' ); 
  $t->tagConfigure( 'readonly', -relief => 'groove' ); 
  
  my %images = define_bitmaps($top); 
  $t->tagConfigure( 
    'optionmenu', 
    -image    => $images{optionmenu}, 
    -anchor   => 'e', 
    -showtext => 1, 
  ); 
  $t->tagConfigure( 
    'browseentry', 
    -image    => $images{browseentry}, 
    -anchor   => 'e', 
    -showtext => 1 
  ); 
  $t->tagConfigure( 'checkbutton0', -image => $images{checkbutton0} ); 
  $t->tagConfigure( 'checkbutton1', -image => $images{checkbutton1} ); 
  
  $t->bind( '<Key-Escape>' => \&end_edit ); 
  
  # clean up if mouse leaves the widget 
  $t->bind( 
    '<FocusOut>', 
    sub { 
      my $w = shift; 
      $w->selectionClear('all'); 
      $w->configure( -state => 'disabled' ); 
    } 
  ); 
  
  # highlight the cell under the mouse 
  $t->bind( 
    '<Motion>', 
    sub { 
      my $w  = shift; 
      my $Ev = $w->XEvent; 
      if ( $w->selectionIncludes( '@' . $Ev->x . "," . $Ev->y ) ) { 
        Tk->break; 
      } 
      $w->selectionClear('all'); 
      $w->selectionSet( '@' . $Ev->x . "," . $Ev->y ); 
      Tk->break; 
      ## "break" prevents the call to TableMatrixCheckBorder 
    } 
  ); 
  
  # mousebutton 1 edits the cell (or not) appropriately 
  $t->bind( 
    '<1>', 
    sub { 
      my ($w) = @_; 
      withdraw_edit_widgets($w); 
      my $Ev = $w->XEvent; 
      my ( $x, $y ) = ( $Ev->x, $Ev->y ); 
      my $rc  = $w->index("\@$x,$y"); 
      my $var = $w->cget( -var ); 
      my ( $r, $c ) = split( /,/, $rc ); 
      $r && $c || return; 
      $w->{_b1_row_col} = "$r,$c"; 
      set_style_state($w); 
      my $style = $w->{columneditstyles}{$c} || 'editable'; 
  
      if ( $style eq 'optionmenu' || $style eq 'browseentry' ) { 
        setup_toplevel_lbox( $w, $r, $c ); 
      } 
      elsif ( $style eq 'button' ) { 
        my $newval = $var->{$rc} =~ /ON/ ? 'OFF' : 'ON'; 
        $var->{$rc} = $newval; 
        $w->tagCell( $newval, $rc ); 
      } 
      elsif ( $style eq 'checkbutton' ) { 
        $var->{$rc} = !$var->{$rc}; 
        my $tag = $var->{$rc} ? 'checkbutton1' : 'checkbutton0'; 
        $w->tagCell( $tag, $rc ); 
      } 
    } 
  ); 
  
  # replace std b1-release 
  $t->bind( 'Tk::TableMatrix' => '<ButtonRelease-1>', \&set_style_state ); 
  
  # inititialize the array, titles, and celltags 
  for ( my $r = 0; $r < $rows; $r++ ) { 
    for ( my $c = 0; $c < $cols; $c++ ) { 
      my $rc = "$r,$c"; 
      if ( !$r || !$c ) { 
        $_data->{$rc} = $r || $tm->{columneditstyles}{$c} || ""; 
      } 
      else { 
        $_data->{$rc} = $rc; 
        my $style = $tm->{columneditstyles}{$c} || 'editable'; 
        if ( $style eq 'readonly' ) { 
          $t->tagCell( 'readonly', $rc ); 
        } 
        if ( $style eq 'optionmenu' ) { 
          $_data->{$rc} = "$r options"; 
          $t->tagCell( 'optionmenu', $rc ); 
        } 
        elsif ( $style eq 'browseentry' ) { 
          $_data->{$rc} = "browse$r"; 
          $t->tagCell( 'browseentry', $rc ); 
        } 
        elsif ( $style eq 'button' ) { 
          $_data->{$rc} = $r % 4 ? 'ON' : 'OFF'; 
          $t->tagCell( $_data->{$rc}, $rc ); 
        } 
        elsif ( $style eq 'checkbutton' ) { 
          $_data->{$rc} = $r % 3 ? 0 : 1; 
          $t->tagCell( 'checkbutton' . $_data->{$rc}, $rc ); 
        } 
      } 
    } 
  } 
  
  Tk::MainLoop; 
} 
  
sub set_style_state { 
  my ($w) = @_; 
  my ( $r, $c ) = split( /,/, $w->{_b1_row_col} ); 
  if ( 
    grep( !$w->{columneditstyles}{$c} || $_ eq $w->{columneditstyles}{$c}, 
      qw(optionmenu readonly button checkbutton) ) 
    ) 
  { 
    $w->selectionClear('all'); 
    $w->configure( state => 'disabled' ); 
  } 
  else { 
    $w->configure( state => 'normal' ); 
    $w->activate( $w->{_b1_row_col} ); 
  } 
} 
  
sub end_edit { 
  my ($w) = @_; 
  $w->configure( -state => 'disabled' ); 
  $w->selectionClear('all'); 
} 
  
sub setup_toplevel_lbox { 
  my ( $w, $r, $c ) = @_; 
  
  my $toplevel = $w->{toplevel} ||= $w->Toplevel( -bd => 2, -relief => 'raised' ); 
  my $lbox = $toplevel->{lbox}; 
  $lbox->destroy() if $lbox; 
  $toplevel->overrideredirect(1); 
  
  my @options = map( chr( ord('A') + $_ - 1 ) x $_, 1 .. $r ); 
  my $height = @options > 8 ? 8 : ( @options || 1 ); 
  my $width = 2; 
  foreach (@options) { $width = length($_) if length($_) > $width; } 
  $lbox = $toplevel->{lbox} = $toplevel->Scrolled( 
    Listbox             => -height => $height, 
    -width              => $width + 1, 
    -relief             => 'raised', 
    -borderwidth        => 1, 
    -highlightthickness => 0, 
    -bg                 => $w->cget('bg'), 
    -scrollbars         => 'oe', 
  )->pack( -side => 'left' ); 
  
  $lbox->Subwidget('scrolled')->{_table_matrix} = $w; 
  
  $lbox->delete( 0, 'end' ); 
  $lbox->insert( 0, @options ); 
  
  my ( $gx, $gy ) = ( $w->rootx(), $w->rooty() ); 
  my @bbox = $w->bbox("$r,$c"); 
  my ( $mx, $my ) = ( int( $gx + $bbox[0] + $bbox[2] ), int( $gy + $bbox[1] ) ); 
  
  my $toplevel_ypixels 
    = $height * $bbox[3] + $toplevel->cget("-bd") * 2 + $toplevel->cget("-highlightthickness"); 
  
  my $y2 = $my + $toplevel_ypixels; 
  $my = $w->vrootheight - $toplevel_ypixels if ( $y2 > $w->vrootheight ); 
  
  $toplevel->transient( $w->toplevel() ); 
  $toplevel->geometry("+$mx+$my"); 
  $toplevel->deiconify(); 
  $toplevel->raise(); 
  
  $lbox->bind( 
    '<ButtonRelease-1>', 
    sub { 
      my ($lbox) = @_; 
      my $i      = $lbox->curselection(); 
      my $val    = $lbox->get($i); 
      my $w      = delete $lbox->{_table_matrix}; 
      my $rc     = delete $w->{_b1_row_col}; 
      my $var    = $w->cget( -var ); 
      $var->{$rc} = $val; 
      $w->set( $rc => $val ); 
      $w->selectionClear('all'); 
      $w->configure( -state => 'disabled' ); 
      withdraw_edit_widgets($w); 
    } 
  ); 
} 
  
sub withdraw_edit_widgets { 
  my ($w) = @_; 
  my $toplevel = $w->{toplevel}; 
  if ( $toplevel && $toplevel->state eq 'normal' ) { 
    $toplevel->withdraw(); 
  } 
} 
  
#-------------------------------------------------------------- 
  
sub define_bitmaps { 
  my ($w) = @_; 
  
  my $optionmenu = ' 
/* XPM */ 
static char * xpm[] = { 
"11 5 3 1", 
" 	c None", 
"+	c #D0D0D0", 
"@	c #555555", 
"+++++++++++", 
"++++++++++@", 
"++       @@", 
"++@@@@@@@@@", 
"+@@@@@@@@@@"}; 
'; 
  
  my $browseentry = ' 
/* XPM */ 
static char * xpm[] = { 
"11 7 3 1", 
" 	c None", 
"+	c #D0D0D0", 
"@	c #555555", 
"+++++++++++", 
"++++++++++@", 
"+++     @@@", 
" +++   @@@ ", 
"  +++ @@@  ", 
"   ++@@@   ", 
"    @@@    ", 
}; 
'; 
  
  my $cbutton0 = ' 
/* XPM */ 
static char * xpm[] = { 
"9 8 3 1", 
" 	c None", 
"@	c #B8B8B8", 
"+	c #555555", 
"+++++++++", 
"++++++++@", 
"++     @@", 
"++     @@", 
"++     @@", 
"++     @@", 
"++@@@@@@@", 
"+@@@@@@@@"}; 
}; 
'; 
  
  my $cbutton1 = ' 
/* XPM */ 
static char * xpm[] = { 
"9 8 4 1", 
" 	c None", 
"@	c #B8B8B8", 
"+	c #555555", 
".	c #FF0000", 
"+++++++++", 
"++++++++@", 
"++.....@@", 
"++.....@@", 
"++.....@@", 
"++.....@@", 
"++@@@@@@@", 
"+@@@@@@@@"}; 
}; 
'; 
  
  my %images; 
  $images{optionmenu}   = $w->Pixmap( 'optionmenu',  -data => $optionmenu ); 
  $images{browseentry}  = $w->Pixmap( 'browseentry', -data => $browseentry ); 
  $images{checkbutton0} = $w->Pixmap( 'cbutton0',    -data => $cbutton0 ); 
  $images{checkbutton1} = $w->Pixmap( 'cbutton1',    -data => $cbutton1 ); 
  %images; 
}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
########## 
### Demo of using embedded windows in TableMatrix 
  
###  This works well, but can be slow for very large tables with many 
###   windows. 
### 
###  See edit_styles.pl for an alternative that is faster for larger 
###    tables 
  
use Tk; 
use Tk::BrowseEntry; 
use Tk::TableMatrix; 
  
use Data::Dumper qw( DumperX); 
my $top = MainWindow->new; 
  
my $arrayVar = {}; 
  
foreach my $row ( 0 .. 20 ) { 
  foreach my $col ( 0 .. 10 ) { 
    $arrayVar->{"$row,$col"} = "r$row, c$col"; 
  } 
} 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => 21, 
  -cols          => 11, 
  -width         => 6, 
  -height        => 6, 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -variable      => $arrayVar, 
  -selectmode    => 'extended', 
  -resizeborders => 'both', 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -bg            => 'white', 
  
  #  -state => 'disabled' 
  #  -colseparator => "\t", 
  #  -rowseparator => "\n" 
); 
  
$t->tagConfigure( 'active', -bg => 'gray90', -relief => 'sunken' ); 
$t->tagConfigure( 'title', -bg => 'gray85', -fg => 'black', -relief => 'sunken' ); 
  
################ Put in some embedded windows ################ 
my $l = $top->Checkbutton( -text => 'CheckButton' ); 
$t->windowConfigure( "3,3", -sticky => 's', -window => $l ); 
  
my $c = $top->BrowseEntry( -label => "Month:" ); 
$c->insert( "end", "January" ); 
$c->insert( "end", "February" ); 
$c->insert( "end", "March" ); 
$c->insert( "end", "April" ); 
$c->insert( "end", "May" ); 
$c->insert( "end", "June" ); 
$c->insert( "end", "July" ); 
$c->insert( "end", "August" ); 
$c->insert( "end", "September" ); 
$c->insert( "end", "October" ); 
$c->insert( "end", "November" ); 
$c->insert( "end", "December" ); 
  
$t->windowConfigure( "2,2", -sticky => 'ne', -window => $c ); 
  
# Leave enough room for the windows 
$t->colWidth( 2, 20 ); 
$t->colWidth( 3, 20 ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
  
Tk::MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
## maxsize.tcl 
## 
## This demo uses a really big table.  The big startup time is in 
## filling the table's Tcl array var. 
## 
## jeff.hobbs@acm.org 
## Converted to perl/tk by John Cerney 7/24/00 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my $top = MainWindow->new; 
  
my $arrayVar = {}; 
  
print "Filling Array...\n"; 
my ( $rows, $cols ) = ( 40000, 10 ); 
foreach my $row ( 0 .. ( $rows - 1 ) ) { 
  foreach my $col ( 0 .. ( $cols - 1 ) ) { 
    $arrayVar->{"$row,$col"} = "$row,$col"; 
  } 
} 
  
print "Creating Table...\n"; 
## Test out the use of a callback to define tags on rows and columns 
sub colSub { 
  my $col = shift; 
  return "OddCol" if ( $col > 0 && $col % 2 ); 
} 
  
my $label = $top->Label( -text => "TableMatrix v2 Example" ); 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows           => $rows, 
  -cols           => $cols, 
  -width          => 6, 
  -height         => 6, 
  -titlerows      => 1, 
  -titlecols      => 1, 
  -variable       => $arrayVar, 
  -coltagcommand  => \&colSub, 
  -colstretchmode => 'last', 
  -rowstretchmode => 'last', 
  -selectmode     => 'extended', 
  -selecttitles   => 0, 
  -drawmode       => 'slow', 
); 
  
my $button = $top->Button( -text => "Exit", -command => sub { $top->destroy } ); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'OddCol', -bg => 'brown', -fg => 'pink' ); 
$t->tagConfigure( 'title', -bg => 'red', -fg => 'blue', -relief => 'sunken' ); 
$t->tagConfigure( 'dis', -state => 'disabled' ); 
  
my $i     = -1; 
my $first = $t->cget( -colorigin ); 
my $anchor; 
foreach $anchor (qw/ n s e w nw ne sw se c /) { 
  $t->tagConfigure( $anchor, -anchor => $anchor ); 
  $t->tagRow( $anchor, ++$i ); 
  $t->set( "$i,$first", $anchor ); 
} 
$top->fontCreate( 'courier', -family => 'courier', -size => 10 ); 
$t->tagConfigure( 's', -font => 'courier', -justify => 'center' ); 
  
$t->colWidth( -2 => 8, -1 => 9, 0 => 12, 4 => 14 ); 
  
$label->pack( -expand => 1, -fill => 'both' ); 
  
$t->pack( -expand => 1, -fill => 'both' ); 
$button->pack( -expand => 1, -fill => 'both' ); 
  
Tk::MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
## spreadsheet.tcl 
## 
## This demos shows how you can simulate a 3D table 
## and has other basic features to begin a basic spreadsheet 
## 
## jeff.hobbs@acm.org 
##  Converted to perl/tk by John Cerney 
  
use Tk; 
  
use Tk::TableMatrix; 
  
my ( $rows, $cols ) = ( 10, 10 );    # number of rows/cols 
my $page    = 'AA'; 
my $oldPage = ''; 
  
my $tableColors = { default => 'pink', AA => 'orange', BB => 'blue', CC => 'green' }; 
  
my $top = MainWindow->new; 
  
sub colorize { 
  my ($num) = @_; 
  return 'colored' if ( $num > 0 && $num % 2 ); 
  return ''; 
} 
  
# Sub to fill the array variable 
sub fill { 
  
  my ( $name, $array, $r, $c ) = @_; 
  my ( $i, $j ); 
  $r ||= $rows; 
  $c ||= $cols; 
  for ( $i = 0; $i < $r; $i++ ) { 
    for ( $j = 0; $j < $c; $j++ ) { 
      if ( $j && $i ) { 
        $array->{"$i,$j"} = "$name $i,$j"; 
      } 
      elsif ($i) { 
        $array->{"$i,$j"} = "$i"; 
      } 
      elsif ($j) { 
        $array->{"$i,$j"} = sprintf( "%c", ( $j + 64 ) ); 
      } 
    } 
  } 
} 
  
my $arrayVar = { 
  AA => {}, 
  BB => {}, 
  CC => {} 
}; 
  
fill( 'AA', $arrayVar->{AA}, $rows,     $cols );        # fill up the array variable 
fill( 'BB', $arrayVar->{BB}, $rows / 2, $cols / 2 );    # fill up the array variable 
  
my $t = $top->Scrolled( 
  'TableMatrix', 
  -rows          => $rows, 
  -cols          => $cols, 
  -width         => 5, 
  -height        => 5, 
  -titlerows     => 1, 
  -titlecols     => 1, 
  -coltagcommand => \&colorize, 
  -selectmode    => 'extended', 
  -flashmode     => 'on', 
  -variable      => $arrayVar->{$page}, 
  
); 
  
my $label = $top->Label( -text => "TableMatrix vs Spreadsheet Example" ); 
  
# Label the changes with the value of currentTest 
my $currentText = ''; 
my $currentLabel = $top->Label( -textvariable => \$currentText ); 
  
# Entry that changes with the value of activeText 
my $activeText = ''; 
my $activeEntry = $top->Entry( -textvariable => \$activeText ); 
  
my $pageLabel = $top->Label( -text => 'PAGE:', -width => 6, -anchor => 'e' ); 
my $pageSelect = $top->Optionmenu( 
  -options  => [qw/ AA BB CC/], 
  -variable => \$page, 
  -command  => [ \&changepage ] 
); 
  
sub changepage { 
  
  my ($newPage) = @_; 
  
  if ( $newPage ne $oldPage ) { 
  
    $t->selectionClear('all'); 
    $t->activate('');    # unactivate anything 
    $t->configure( -variable => $arrayVar->{$newPage} ); 
  
    # $e config -textvar ${i}(active) 
    $t->activate('origin'); 
    if ( exists $tableColors->{$newPage} ) { 
      $t->tagConfigure( 'colored', -bg => $tableColors->{$newPage} ); 
    } 
    else { 
      $t->tagConfigure( 'colored', -bg => $tableColors->{'default'} ); 
    } 
    $t->see('active'); 
    $oldPage = $newPage; 
  } 
} 
  
$t->configure( 
  -browsecommand => sub { 
    my ( $oldindex, $index ) = @_; 
    $currentText = $index; 
    $activeText  = $t->get($index); 
  } 
); 
  
# hideous Color definitions here: 
$t->tagConfigure( 'colored', -bg => $tableColors->{$page} ); 
$t->tagConfigure( 'title',   -fg => 'red', -relief => 'groove' ); 
$t->tagConfigure( 'blue',    -bg => 'blue' ); 
$t->tagConfigure( 'green',   -bg => 'green' ); 
  
$t->tagCell( 'green', '6,3', '5,7', '4,9' ); 
$t->tagCell( 'blue', '8,8' ); 
$t->tagRow( 'blue', 7 ); 
$t->tagCol( 'blue', 6, 8 ); 
  
$t->colWidth( 0 => 3, 2 => 7 ); 
  
$label->grid( '-', '-', '-', '-', '-sticky' => 'ew' ); 
$currentLabel->grid( $currentLabel, $activeEntry, $pageLabel, $pageSelect, '-', '-sticky' => 'ew' ); 
$t->grid( '-', '-', '-', '-', '-sticky' => 'nsew' ); 
$top->gridColumnconfigure( 1, -weight => 1 ); 
$top->gridRowconfigure( 2, -weight => 1 ); 
  
Tk::MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
# Script show tag merging behavior with an option set in the 
#  option database. 
# 
#   Should display with one row hightlighted red and a cell in the row left-justified 
  
use Tk; 
use Tk::TableMatrix; 
  
use strict; 
  
my $mw = MainWindow->new; 
  
#$mw->optionAdd('*background', 'blue', 'interactive'); 
$mw->optionAdd( '*tablematrix*background', 'skyblue' ); 
  
my $table = $mw->TableMatrix( 
  -rows  => 5, 
  -cols  => 8, 
  -cache => 1, 
  
  #-bg => 'blue', 
); 
$table->pack( -expand => 1, -fill => 'both' ); 
  
foreach my $row ( 0 .. 4 ) { 
  
  #$table->tagRow('invalid', $row);                # swap 
  foreach my $column ( 0 .. 7 ) { 
    $table->set( "$row,$column", "hello" ); 
  
    #$table->tagCell('left', "$row,$column");    # swap 
  } 
} 
  
# 'invalid' tag takes priority of 'left' tag, because it is created first, 
#     so the cell 2,3 should be red and center anchored, but see below... 
$table->tagConfigure( "invalid", -background => 'red',   -anchor => 'center' ); 
$table->tagConfigure( "left",    -background => 'green', -anchor => 'w' ); 
  
$table->tagCell( 'left', '2,3' ); 
$table->tagRow( 'invalid', 2 ); 
  
#  The tag priority is changed, so the cell 2,3 will be gree and 'w' achored. 
$table->tagRaise( 'left', 'invalid' ); 
  
# This would have the same effect as the above tagRaise 
#$table->tagLower('invalid', 'left'); 
  
MainLoop;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
# Script show the new multi-number borderwidth option for tags 
#   Borderwidth can be specified as a space separated list of 
#     4 numbers representing left right top bottom borders drawn in a cell 
# 
#   In this example, the tag'ed row will have a large top/bottom border, and a normal 
#     size left/right border 
  
use Tk; 
use Tk::TableMatrix; 
  
use strict; 
  
my $mw = MainWindow->new; 
  
#$mw->optionAdd('*background', 'blue', 'interactive'); 
$mw->optionAdd( '*tablematrix*background', 'skyblue' ); 
  
my $table = $mw->TableMatrix( 
  -rows  => 5, 
  -cols  => 8, 
  -cache => 1, 
  
  #-bg => 'blue', 
); 
$table->pack( -expand => 1, -fill => 'both' ); 
  
$table->tagConfigure( "invalid", -background => 'red', -relief => 'raised', -bd => '1 1 5 5' ); 
$table->tagConfigure( "left", -anchor => 'w' ); 
  
foreach my $row ( 0 .. 4 ) { 
  
  #$table->tagRow('invalid', $row);                # swap 
  foreach my $column ( 0 .. 7 ) { 
    $table->set( "$row,$column", "hello" ); 
  
    #$table->tagCell('left', "$row,$column");    # swap 
  } 
} 
  
$table->tagCell( 'left', '2,3' ); 
$table->tagRow( 'invalid', 2 ); 
  
MainLoop;