Perl/Tk Widgets - Tabellen erstellen

Widgets zur Darstellung von Tabellen

Tabellen in Perl/Tk kann man sich prinzipiell mittels des Geometriemanagers grid selbst erstellen. Das ist aber potentiell frickelig und außerdem bietet CPAN eine ganze Reihe an Modulen zur Erstellung von Tabellen bzw. tabellarischen Daten an:

Tk::Table
Tk::GridColumns
Tk::MListbox
Tk::TableMatrix
Tk::HList

Tk::Table

Tk::Table ist recht einfach in der Bedienung. In jede Zelle kann ein beliebiges Widget eingefügt werden. Die Zellen passen sich automatisch in der Größe an, wobei sie sich immer nach dem größten Inhalt richten. Es ist nicht möglich Zellen in ihrer Größe zu verändern. Für einfache Tabellen reicht das Widget Tk::Table jedoch voll und ganz aus.

Vorteile

Extrem einfach

Nachteile

Zellengröße kann nicht manipuliert werden
Speicherhungrig und nicht für größere Datenmengen geeignet

Kleiner Kalender für Perl/Tk

#!perl

use strict;
use warnings;
use Tk;
use Tk::Table;

my $mw = Tk::MainWindow->new(-width => 200, -height => 200,);
$mw->packPropagate(0);

my $t = $mw->Table(
    -width  => 100,
    -height => 150,
    -scrollbars => 'se',
);

for( my $c = 0; $c < 100; $c++ ) {
    for( my $j = 0; $j < 30; $j++ ) {
        $t->put($c, $j, $c+$j);
        $t->put($c, $j, $c+$j*100);
        $t->put($c, $j, $c+$j^17);
        $t->put($c, $j, $c+$j/5);
    }
}

$t->pack(-fill => 'both', -expand => 1,);

$mw->MainLoop();

Tk::GridColumns

Tk::GridColumns ist komfortabel für Tabellen, die vorwiegend Text beinhalten. Eine Sortierfunktion für die Spalten wird von Haus aus mitgeliefert. Die Dokumentation beinhaltet auch ein schönes Beispiel für eine Editierfunktion (das jQuery-Plugin DataTables bietet etwas Ähnliches namens editable rows).

Vorteile

Gute Beispiele in der Dokumentation
Eingebaute Funktionen zur Sortierung der Spalten

Sortierbare Tabelle mit Tk::GridColumns

#!perl

use strict;
use warnings;
use Tk;
use Tk::GridColumns;

my $mw = tkinit( -title => 'Tk::GridColumns example -- Simple' );

my $gc = $mw->GridColumns(
	-data => [ map { [ $_, chr 97 + rand $_*2 ] } 1 .. 10 ], # some data
	-columns => \my @columns, # need to define columns after creating the
                              # object, because of the sort '-command'
)->pack(
	-fill => 'both',
	-expand => 1,
);

@columns = (
	{
		-text => 'Number',
		-command => $gc->sort_cmd( 0, 'num' ),
	},
	{
		-text => 'String',
		-command => $gc->sort_cmd( 1, 'abc' ),
		-weight => 1, # this columns gets the remaining space
	},
);

$gc->refresh;

$mw->MainLoop;

Tk::MListbox

Noch ein kleines Bisschen besser ausgestattet als Tk::GridColumns ist Tk::MListbox. Neben der Sortierfunktion bringt das Tabellen-Widget zusätzlich Möglichkeiten mit, Spalten in ihrer Breite zu verändern, die Reihenfolge der Spalten zu ändern oder Spalten auszublenden.

Tabellen-Widget mit freier Anordnung der Spalten

#!perl

=comment

MListbox demonstration application: simple directory browser
Based on script from Hans J. Helgesen, December 1999.
Source: http://perl.developpez.com/faq/tk/?page=Tableaux (2013-11-11)

=cut

use strict;
use warnings;
use File::stat;
use Tk;
use Tk::MListbox;
use Cwd; # for portable pwd

## 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 = cwd();
  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 &amp; 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 );
}

Tk::TableMatrix

Eines der interessantesten Widgets zur Darstellung tabellarischer Daten ist Tk::TableMatrix. Es eignet sich gut für große Datenengen und ist auch sonst nicht besonders eingeschränkt. Leider muss man sich Sortierfunktionen selber schreiben. Dafür gibt es keine Restriktionen hinsichtlich der Inhalte der Zellen oder der Veränderlichkeit der Zellen-Dimensionen. Abgeleitete Widgets wie Tk::TableMatrix::Spreadsheet und Tk::TableMatrix::SpreadsheetHideRows fügen weitere Features hinzu, die einen Blick lohnen.

Vorteile

Sehr schnell, da in C geschrieben
Auch für große Tabellen bzw. größere Datenmengen geeignet

Nachteile

Die Dokumentation erschwert den Einstieg

Tk::TableMatrix - Beispiel

#!perl

use strict;
use warnings;
use utf8;
use Tk;
use Tk::TableMatrix::Spreadsheet;

my $mw = Tk::MainWindow->new();
$mw->configure(-title => "ID3 Tag Genre and Year Fixer");
$mw->minsize(qw(500 200));

my $menu = $mw->Frame()->pack(-side => "top", -fill => 'x');
my $menu_file = $menu->Menubutton(
	-text => "File",
	-tearoff => "false",
)->pack(-side => "left");
$menu_file->command(
	-label => "Exit",
	-command => sub{ $mw->destroy(); },
);

my $frame = $mw->Frame(
	-height 		=> 10,
	-width			=> 30,
	-relief			=> "groove",
	-borderwidth	=> 3,
)->pack(-fill => 'x', -pady => 0);

my @border = (0,0,0,1);

my %table_data = (
	'0,0' => '%',
	'0,1' => 'Artist',
	'0,2' => 'Album',
	'0,3' => 'Year',
	'0,4' => 'Genre',
	
	# fill field
	'3,3' => 'Test',
);

my $table = $frame->Scrolled("Spreadsheet",
	-scrollbars		=> 'se',
	-cols 			=> 5,
	-width 			=> 5,
	-height 		=> 6,
	-titlerows 		=> 1,
	-variable		=> \%table_data,
	-selectmode		=> 'multiple',
	-selecttype		=> 'row',
	-resizeborders	=> 'col',
	-bg 			=> 'white',
	-rowheight 		=> 2,
	-bd 			=> \@border,
	-justify 		=> 'left',
	-drawmode 		=> 'compatible',
	-wrap 			=> 0,
	-relief 		=> 'solid'
)->pack(-fill => 'both');

$table->rowHeight(0,1);
$table->tagRow('title',0);
$table->tagConfigure('title', -bd => 2, -relief => 'raised');
$table->colWidth(0,5,3,6,4,10);

insert_data($table);

$mw->MainLoop();

exit(0);

=head1 SUBS

=head2 insert_data( $table_object )

=cut

sub insert_data {
	my $tbl = shift;
	
	# usage: $table->set(?row|col?, index, ?value?, ?index, value, ...?)
	# Sets the specified index to the associated value.
	$tbl->set(
		'1,0' => '46%',
		'1,1' => 'Eminem',
		'1,2' => 'The Eminem Show',
		'1,3' => 2002,
		'1,4' => 'Hardcore Rap',
	);
	
	# set a single field
	$tbl->set('2,0' => '0%');
	
	return;
} # /insert_data

Tk::HList

Tk::HList erfordert vom Programmierer einiges an Geduld und Experimentierfreudigkeit. Dafür kann es auch was. Tabellarische Daten können in diesem Widget genauso abgebildet werden wie hierarchische Daten. Die angezeigten Widgets sind frei wählbar.

Vorteile

Beliebige Widgets als Kind-Elemente
Darstellung von tabellarischen und hierarchischen Daten

Nachteile

Unzureichende Dokumentation

Tk::HList ohne schwarzen Markierungsrahmen

#!perl

use strict;
use warnings;
use utf8;
use Tk;
use Tk::HList;

my $mw = tkinit();

# -- create a Tk::HList
my $scrolled_hlist = $mw->Scrolled('HList',
	-scrollbars => 'se',
	-columns => 2,
	-header => 1,
	-width => 50,
	-height => 20,
	# hide black border around HList when it's active
	-highlightthickness => 0,
	-selectborderwidth => 1,
	-selectmode => 'single',
)->pack(-fill => 'y', -expand => 1,);

my $real_hlist = $scrolled_hlist->Subwidget('scrolled');
$real_hlist->configure(
	-browsecmd => [ sub{ $_[0]->anchorClear(); }, $real_hlist],
);

# -- add HList header colums
$real_hlist->header(
	'create', 0,
	-text   => 'first column',
);

$real_hlist->header(
	'create', 1,
	-text   => 'second column',
);


# -- add some entries to the HList
$real_hlist->add(1);
$real_hlist->item('create', 1, 0, -text => 'first row, 1st col');
$real_hlist->item('create', 1, 1, -text => 'first row, 2nd col');

$real_hlist->add(2);
$real_hlist->item('create', 2, 0, -text => '2nd row, 1st col');
$real_hlist->item('create', 2, 1, -text => 'second row, 2nd col');


# -- set selection *** without dashed line border ***
$real_hlist->selectionSet(2);

$mw->MainLoop();
exit(0);

Quellen

perl.developpez.com, abgerufen am 11.11.2013