package Tk::DBI::Table;
#------------------------------------------------
# automagically updated versioning variables -- CVS modifies these!
#------------------------------------------------
our $Revision = '$Revision: 1.8 $';
our $CheckinDate = '$Date: 2003/04/29 16:25:58 $';
our $CheckinUser = '$Author: xpix $';
# we need to clean these up right here
$Revision =~ s/^\$\S+:\s*(.*?)\s*\$$/$1/sx;
$CheckinDate =~ s/^\$\S+:\s*(.*?)\s*\$$/$1/sx;
$CheckinUser =~ s/^\$\S+:\s*(.*?)\s*\$$/$1/sx;
#-------------------------------------------------
#-- package Tk::DBI::Table -----------------------
#-------------------------------------------------
=head1 NAME
Tk::DBI::Table - Megawidget to display a sql-Statement in HList.
=head1 SYNOPSIS
use Tk;
use Tk::DBI::Table;
my $top = MainWindow->new;
my $tkdbi = $top->DBITable(
-sql => 'select * from table',
-dbh => $dbh,
-display_id => 0,
)->pack(expand => 1, -fill => 'both');
MainLoop;
=head1 DESCRIPTION
This is a megawidget that enables you to display sql statements from a database.
The features are:
=over 4
=item each column has a ResizeButton for flexible width
=item The user can activate any Button to sort the column in the directions 'ASC', 'Desc' or 'None'.
=item Sorted column can display with a extra style
=back
=cut
use Tk::HList;
use Tk::Compound;
use Tk::ResizeButton;
use Data::Dumper;
use base qw/Tk::Derived Tk::Frame/;
use strict;
Construct Tk::Widget 'DBITable';
my ($BITMAPDOWN, $BITMAPUP);
# ------------------------------------------
sub ClassInit
# ------------------------------------------
{
my($class,$mw) = @_;
unless(defined($BITMAPDOWN))
{
$BITMAPUP = __PACKAGE__ . "::uparrwow";
my $bits_up = pack("b10"x10,
"..........",
"..........",
"..........",
".....#....",
"....###...",
"...#####..",
"..#######.",
".#########",
"..........",
".........."
);
$mw->DefineBitmap($BITMAPUP => 10,10, $bits_up);
$BITMAPDOWN = __PACKAGE__ . "::downarrwow";
my $bits_down = pack("b10"x10,
"..........",
"..........",
"..........",
".#########",
"..#######.",
"...#####..",
"....###...",
".....#....",
"..........",
".........."
);
$mw->DefineBitmap($BITMAPDOWN => 10,10, $bits_down);
}
}
# ------------------------------------------
sub Populate {
# ------------------------------------------
my ($obj, $args) = @_;
=head1 WIDGET-SPECIFIC OPTIONS
=head2 -dbh => $dbh
A database handle, this will return a error if not defined.
=cut
$obj->{dbh} = delete $args->{'-dbh'} || return $obj->error("No DB-Handle!");
=head2 -sql => 'select * from table'
A sql statement, this will return an error if not defined.
=cut
$obj->{sql} = delete $args->{'-sql'} || return $obj->error("No SQL-Stm!");
=head2 -debug [I<0>|1]
This is a switch that turns on debug output to the normal console (STDOUT).
=cut
$obj->{debug} = delete $args->{'-debug'} || 0;
=head2 -display_id [I<Off>|On]
This is a switch for displaying the index column.
=cut
$obj->{display_id} = delete $args->{'-display_id'} || 0;
=head2 -columnWidths [colWidth_0, colWidth_1, colWidth_2, ...]
Default field column width.
=cut
$obj->{maxchars} = delete $args->{'-maxchars'};
=head2 -maxchars number or {col1 => number}
Maximum displaying chars in the cells. Global or only in named columns.
=cut
$obj->{columnWidths} = delete $args->{'-columnWidths'};
=head2 -srtColumnStyle(option => value)
Column sort style.
=cut
$obj->{srtColumnStyle} = delete $args->{'-srtColumnStyle'};
$obj->SUPER::Populate($args);
=head1 METHODS
These are the methods you can use with this Widget.
=cut
my %specs;
=head2 $dbitable->refresh( [to_sort_col_number] );
Refresh the table and sort (optional) the col number.
=cut
$specs{-refresh} = [qw/METHOD refresh Refresh/, undef];
=head2 $dbitable->sortcol( to_sort_col_number );
Refresh the table and sort the col number or return the actually col sort number.
=cut
$specs{-sortcol} = [qw/METHOD sortcol SortCol/, undef];
=head2 $dbitable->direction( ['NONE', 'ASC' or 'DESC'] );
Set a new sorting direction. no parameter will return the actual sort direction.
=cut
$specs{-direction} = [qw/METHOD direction Direction/, 'NONE'];
$obj->ConfigSpecs(%specs);
$obj->refresh();
} # end Populate
# Class private methods;
# ------------------------------------------
sub refresh {
# ------------------------------------------
my $obj = shift or return warn("No object");
my $sortcolumn = shift;
$obj->toogle_direction($sortcolumn)
if(defined $sortcolumn);
# get data
$obj->{data} = my $data = $obj->getSql($obj->{sql})
or return $obj->error('Problem in getSql');
my @fields = @{$obj->{fields}};
# Create HList
unless(defined $obj->{table}) {
my $cols = scalar @fields;
$obj->{table} = $obj->Scrolled('HList',
-scrollbars => 'osoe',
-columns => $cols,
-header => 1,
)->pack(-expand => 1,
-fill => 'both');
$obj->Advertise("table" => $obj->{table}); #TEXT PART.
}
my $hl = $obj->{table};
# create header
my $c = -1;
foreach my $field (@fields) {
$c++;
$obj->{header}->{$c} = $hl->ResizeButton(
-relief => 'flat',
-anchor => 'nw',
-border => -2,
-pady => -10,
-padx => 10,
-widget => \$hl,
-column => $c,
-command => [\&refresh, $obj, $c],
);
$obj->Advertise(sprintf("HB_%d", $c) => $obj->{header}->{$c}); #Buttons PART.
# create Images (Text)
my $img = $obj->{header}->{$c}->Compound;
$obj->{header}->{$c}->configure(-image => $img);
$img->Line;
$img->Text(-text => $field);
if(defined $sortcolumn and $sortcolumn == $c and ($obj->direction eq 'ASC' or $obj->direction eq 'DESC')) {
$img->Space(-width => 4);
$img->Bitmap(-bitmap => ($obj->direction eq 'ASC' ? $BITMAPUP : $BITMAPDOWN));
$img->Space(-width => 10);
} else {
$img->Space(-width => 24);
}
$hl->headerCreate($c,
-itemtype => 'window',
-widget => $obj->{header}->{$c},
);
$hl->columnWidth($c, $obj->{columnWidths}->[$c])
if(defined $obj->{columnWidths}->[$c]);
}
$hl->columnWidth(0, 0)
unless($obj->{display_id});
#printf("SortCol: %s, Type: %s, Direction: %s\n",
# (defined $sortcolumn ? $sortcolumn : 'undef'),
# (defined $sortcolumn ? $obj->type($sortcolumn) : 'undef'),
# (defined $sortcolumn ? $obj->direction : 'undef')
# );
# Rows ...
$hl->delete('all');
my $type = $obj->type($sortcolumn);
if(defined $sortcolumn and $type eq 'TXT' and $obj->direction eq 'ASC') {
foreach my $zeile (sort { $a->[$sortcolumn] cmp $b->[$sortcolumn] } @$data) {
$obj->draw_row($hl, $zeile, $sortcolumn);
}
} elsif(defined $sortcolumn and $type eq 'TXT' and $obj->direction eq 'DESC') {
foreach my $zeile (sort { $b->[$sortcolumn] cmp $a->[$sortcolumn] } @$data) {
$obj->draw_row($hl, $zeile, $sortcolumn);
}
} elsif(defined $sortcolumn and $type eq 'INT' and $obj->direction eq 'ASC') {
foreach my $zeile (sort { $a->[$sortcolumn] <=> $b->[$sortcolumn] } @$data) {
$obj->draw_row($hl, $zeile, $sortcolumn);
}
} elsif(defined $sortcolumn and $type eq 'INT' and $obj->direction eq 'DESC') {
foreach my $zeile (sort { $b->[$sortcolumn] <=> $a->[$sortcolumn] } @$data) {
$obj->draw_row($hl, $zeile, $sortcolumn);
}
} else {
foreach my $zeile (@$data) {
$obj->draw_row($hl, $zeile);
}
}
}
# ------------------------------------------
sub draw_row {
# ------------------------------------------
my ($obj, $hl, $zeile, $sortcolumn) = @_;
$hl->add($zeile->[0]);
my $c = -1;
foreach my $column (@$zeile) {
$c++;
my $maxchars =
(ref $obj->{maxchars} eq 'HASH'
? $obj->{maxchars}->{$obj->{fields}->[$c]}
: $obj->{maxchars}
) || 0;
$column = ' ' unless($column);
$column =~ s/(\r|\n)//sig;
$column = substr($column, 0, $maxchars).'...'
if($maxchars and length($column)>$maxchars);
$hl->itemCreate( $zeile->[0], $c,
-text => $column,
);
$hl->itemConfigure($zeile->[0], $c,
-style => $obj->{srtColumnStyle},
) if(defined $sortcolumn and defined $obj->{srtColumnStyle} and $sortcolumn == $c);
}
}
# ------------------------------------------
sub sortcol {
# ------------------------------------------
my $obj = shift or croak("No object");
$obj->{sortcol} = shift || $obj->{sortcol};
$obj->refresh($obj->{sortcol});
}
# ------------------------------------------
sub toogle_direction {
# ------------------------------------------
my $obj = shift or croak("No object");
my $sortcolumn = shift;
return $obj->direction('ASC') if(defined $sortcolumn and defined $obj->{sortcol} and $obj->{sortcol} != $sortcolumn);
return $obj->direction('ASC') if($obj->direction() eq 'NONE');
return $obj->direction('DESC') if($obj->direction() eq 'ASC');
return $obj->direction('NONE') if($obj->direction() eq 'DESC');
}
# ------------------------------------------
sub direction {
# ------------------------------------------
my $obj = shift or croak("No object");
$obj->{direction} = shift || return $obj->{direction};
}
# ------------------------------------------
sub type {
# ------------------------------------------
my $obj = shift or croak("No object");
my $snr = shift or return;
my $data = $obj->{data} || return;
my $type = 'INT';
foreach (@$data){
$_->[$snr] = ' ' unless(defined $_->[$snr]);
$type = 'TXT' if(defined $_->[$snr] and $_->[$snr] =~ /[^0-9]+/);
}
return $type;
}
# ------------------------------------------
sub getSql {
# ------------------------------------------
my $obj = shift or croak("No object");
my $sql = shift or return $obj->error('No Sql');
my $dbh = $obj->{dbh};
my $sth = $dbh->prepare($sql) or warn("$DBI::errstr - $sql");
$sth->execute or warn("$DBI::errstr - $sql");
$obj->{fields} = $sth->{'NAME'};
return $sth->fetchall_arrayref;
}
# ------------------------------------------
sub debug {
# ------------------------------------------
my $obj = shift;
my $msg = shift || return;
return unless $obj->{debug};
printf("\nInfo: %s\n", $msg);
}
# ------------------------------------------
sub error {
# ------------------------------------------
my $obj = shift;
my $msg = shift;
$obj->bell;
unless($msg) {
my $err = $obj->{error};
$obj->{error} = '';
return $err;
}
$obj->{error} = sprintf($msg, @_);
warn $obj->{error};
return undef;
}
1;
=head1 ADVERTISED WIDGETS
=head2 'table' => HList-Widget
This is a normal HList widget. I.e.:
$dbitable->Subwidget('table')->configure(
-command = sub{ printf "This is id: %s\n", $_[0] },
};
=head2 'HB_<column number>' => Button-Widget
This is a (Resize)Button widget. This displays a Compound image with text and image.
=head1 CHANGES
$Log: Table.pm,v $
Revision 1.8 2003/04/29 16:25:58 xpix
* reformat
Revision 1.6 2003/04/29 16:22:52 xpix
* chnages tag
=head1 AUTHOR
xpix@netzwert.ag
Copyright (C) 2003 , Frank (xpix) Herrmann. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 KEYWORDS
Tk::DBI::*, Tk::ResizeButton, Tk::HList