view release on metacpan or  search on metacpan

lib/Tk/DBI/DBGrid.pm  view on Meta::CPAN

#	Database Grig - browsing database using "SELECT..." string
#
#	Testing on Windows/ActivePerl, Oracle
#
#	Author: Vadim Likhota, <vadim-lvv@yandex.ru>
#
# v.0.02 - 16.04.2005
#
# + rename colunm name
# + copy current row to clipboard (test with OpenOffice.org 1.1, Excel, Far; 
#   íî íå ðàçîáðàëñÿ êàê äëÿ win ñêîïèðîâàòü ñòðîêó â êèðèëèöå áåç ïåðåêîäèðîâêè - â Far'å
#   ïðè âñòàâêå èç áóôåðà ïðîáëåì íåò, à â òîò æå OOo Calc êîäîâàÿ òàáëèöà ïîðòèòñÿ)
# + not use system color for not win
# + refresh dbgrid
# + call function for encode database data ( example, db use cp1251, but gnome use utf8 )
#	* insfinc, updfinc, delfunc
# 
#	v.0.01 - 16.12.2004


package Tk::DBI::DBGrid;

use vars qw($VERSION);
$VERSION = '0.02';

use Tk;
use DBI;

use base qw/Tk::Frame Tk::Label Tk::Entry Tk::Scrollbar/;
use strict;

Construct Tk::Widget 'DBGrid';



sub Populate {
	my ($w, $args) = @_;
	$w->{dbh} = delete $args->{-dbh} or die "Tk:DBI:DBGrid: No -dbh\n";
	$w->{sql} = delete $args->{-sql} or die "Tk:DBI:DBGrid: No -sql\n";
	$w->{font} = exists $args->{-font} ? delete $args->{-font} : 'Courier 9';
	$w->{maxrow} = (exists $args->{-maxrow} ? delete $args->{-maxrow} : 10) - 1;
	if ( $Tk::platform eq 'MSWin32' ) {
		$w->{titlcolor} = exists $args->{-titlbg} ? delete $args->{-titlbg} : 'SystemButtonFace';
		$w->{seltitlcolor} = exists $args->{-seltitlbg} ? delete $args->{-seltitlbg} : 'SystemHighlight';
	}
	else {
		$w->{titlcolor} = exists $args->{-titlbg} ? delete $args->{-titlbg} : '#f0f0f0';
		$w->{seltitlcolor} = exists $args->{-seltitlbg} ? delete $args->{-seltitlbg} : 'gray';
	};
	$w->{edit} = exists $args->{-edit} ? delete $args->{-edit} : 0;
	$w->{tablename} = exists $args->{-tablename} ? delete $args->{-tablename} : '';
	$w->{pkey} = exists $args->{-pkey} ? delete $args->{-pkey} : undef;
	$w->{pkey} = $w->{pkey}[0] if $w->{pkey};
	$w->{cellformat} = exists $args->{-cellformat} ? delete $args->{-cellformat} : undef;
	$w->{encodes} = exists $args->{-encodes} ? delete $args->{-encodes} : undef;
	$w->{insfunc} = exists $args->{-insfunc} ? delete $args->{-insfunc} : undef;
	$w->{updfunc} = exists $args->{-updfunc} ? delete $args->{-updfunc} : undef;
	$w->{delfunc} = exists $args->{-delfunc} ? delete $args->{-delfunc} : undef;
	$w->{fkeys}->{fk} = exists $args->{-fkeys} ? delete $args->{-fkeys} : undef;
	$w->SUPER::Populate($args);

	$w->{vscroll} = $w->Scrollbar( -command => [vpos => $w] )->pack( -side => 'right', -fill => 'y' );
	$w->{frame} = $w->Frame( -bd => 1, -relief => 'sunken' )->pack( -fill => 'both', -expand => 1 );
	{
		my $sql = $w->{sql};
		$sql =~ tr/a-z/A-Z/;
		if ( $sql =~ /(INSERT|UPDATE|DELETE)/ ) {
			die "Tk:DBI:DBGrid: Working with SELECT-QUERY only (finding $1)\n";
		}
		if ( $w->{edit} and not $w->{tablename} and $sql =~ /FROM (\w+)/) {

lib/Tk/DBI/DBGrid.pm  view on Meta::CPAN

						$w->{rowframee}->[$en->{v}+1][$en->{h}]->focus;
					}
					elsif ( $w->{pos}->{curv} < $w->{table}->{numrows} ) {
						$w->{pos}->{prev} = $w->{pos}->{curv};
						$w->{pos}->{curv}++;
						$w->{rowframel}->[$w->{pos}->{prev} - $w->{pos}->{visb}]->configure( -bg => $w->{titlcolor} );
						$w->{vscroll}->set($w->{table}->{numrows}, $w->{maxrow}, $w->{pos}->{curv}, $w->{pos}->{curv});
						$w->vlist;
						$w->{rowframel}->[$w->{pos}->{curv} - $w->{pos}->{visb}]->configure( -bg => $w->{seltitlcolor} );
					}
				} );

				if ( $w->{insfunc} ) {
					$w->{rowframee}->[$j][$k]->bind('<'.$w->{fkeys}->{ins}.'>' => sub {
						my $en = shift;
						# xrefreshdb($w) if &{$w->{insfunc}}("error", "for future reliase", "åùå íå ðàáîòàåò");
						$w->{table}->{numrows}++;
						foreach ( 0..$w->{table}->{numfields} ) {
							$w->{table}->{data}->[$w->{table}->{numrows}][$_] = '';
						}
						$w->{table}->{data}->[$w->{table}->{numrows}][$w->{pkeynum}] = 0;
						$w->{table}->{visrows} = $w->{table}->{numrows} < $w->{maxrow} ? $w->{table}->{numrows} : $w->{maxrow};
						$w->{pos}->{visb} = $w->{table}->{numrows} - $w->{maxrow} if $w->{table}->{numrows} > $w->{maxrow};
						refreshgrid($w, 1);
						$w->{pos}->{vise} = $w->{table}->{numrows} - $w->{pos}->{visb}; 
						print "$w->{pos}->{vise}\n";
						$w->{rowframee}->[$w->{pos}->{vise}][$en->{h}]->focus;
						$w->{table}->{ins} = 1;
					});
				}

				if ( $w->{delfunc} ) {
					$w->{rowframee}->[$j][$k]->bind('<'.$w->{fkeys}->{del}.'>' => sub {
						my $en = shift;
						if ( &{$w->{delfunc}}($w->{table}->{data}->[$w->{pos}->{curv}][$w->{pkeynum}]) ) {
							refreshdb($w);
						}
						else {
							splice @{$w->{table}->{data}}, $w->{pos}->{curv}, 1;
							$w->{table}->{numrows}--;
							$w->{table}->{visrows} = $w->{table}->{numrows} < $w->{maxrow} ? $w->{table}->{numrows} : $w->{maxrow};
							$w->{pos}->{visb}-- if $w->{pos}->{visb} > 0 and $w->{pos}->{visb} + $w->{maxrow} > $w->{table}->{numrows};
							$w->{pos}->{vise} = $w->{pos}->{visb} + $w->{table}->{visrows};
							refreshgrid($w, $en);
							$w->{rowframee}->[$en->{v} - 1][$en->{h}]->focus if $en->{v} > 1 and not exists $w->{table}->{data}->[$en->{v}+$w->{pos}->{visb}][$w->{pkeynum}];
						}
					});
				}

				$w->{rowframee}->[$j][$k]->eventAdd('<<copykey>>' => '<'.$w->{fkeys}->{copy}.'>');
				$w->{rowframee}->[$j][$k]->eventAdd('<<copykey>>' => '<'.$w->{fkeys}->{copy2}.'>');
				$w->{rowframee}->[$j][$k]->eventAdd('<<copykey>>' => '<'.$w->{fkeys}->{copy3}.'>');
				$w->{rowframee}->[$j][$k]->bind('<<copykey>>' => sub {
					my $en = shift;
					my $row = $w->{table}->{data}->[$en->{v}][0];
					foreach my $o (1..$w->{table}->{numfields}) {
						$row = "$row\t";
						$row .= $w->{table}->{data}->[$en->{v}][$o] if $w->{table}->{data}->[$en->{v}][$o];
					};
					# $row =~ tr/ÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäå¸æçèéêëìíîïðñòóôõö÷øùúûüýþÿ/€‚ƒ„…ð†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥ñ¦§¨©ª«¬­®¯àáâãäåæçèéêëìíîï/ if $Tk::platform eq 'MSWin32';
					$w->clipboardClear;
					$w->clipboardAppend($row);
				});
			}
			else { # edit == 0
				$w->{rowframee}->[$j][$k] = $w->{rowframe}->[$j]->Label( -font => $w->{font}, -width => $w->{table}->{lenth}->[$k], -bd => 1, -relief => 'groove', -bg => 'white' )->pack( -side => 'left');
				$w->{rowframee}->[$j][$k]->configure( -text => $w->{table}->{data}->[$j][$k] ) if exists $w->{table}->{data}->[$j][$w->{pkeynum}];
			}
		}		# $k
	}		# $j


	$w->Advertise('frame' => $w->{frame});
	$w->Advertise('vscroll' => $w->{vscroll});
	$w->Delegates(DEFAULT => $w->{frame});
	$w->ConfigSpecs(
	  -vpos      => [qw/CALLBACK vpos Vpos/, 0],
	  -vlist     => [qw/METHOD vlist Vlist/, undef],
	  -refreshdb => [qw/METHOD refreshdb Refreshdb/, undef],
	  -refreshgrid => [qw/METHOD refreshgrid Refreshgrid/, undef],
		'DEFAULT'  => [$w->{frame}]
	);

	return $w;
} # end Populate



sub vpos {
	my ($w, $addpos) = @_;
	$addpos = 0 if $addpos < 0;
	$addpos = $w->{table}->{numrows} if $addpos > $w->{table}->{numrows};
	if ( ($addpos-$w->{pos}->{visb}) >= 0 and ($addpos-$w->{pos}->{visb}) <= $w->{table}->{visrows} ) {
		$w->{rowframee}->[$addpos-$w->{pos}->{visb}][$w->{pos}->{curh}]->focus;
	}
	else {
		$w->{pos}->{prev} = $w->{pos}->{curv};
		$w->{pos}->{curv} = $addpos;
		$w->{rowframel}->[$w->{pos}->{prev} - $w->{pos}->{visb}]->configure( -bg => $w->{titlcolor} );
		$w->{vscroll}->set($w->{table}->{numrows}, $w->{maxrow}, $w->{pos}->{curv}, $w->{pos}->{curv});
		$w->vlist;
		$w->{rowframel}->[$w->{pos}->{curv} - $w->{pos}->{visb}]->configure( -bg => $w->{seltitlcolor} );
	}
} # end vpos



sub vlist {
	my ( $w ) = @_;

	if ( $w->{pos}->{curv} < $w->{pos}->{visb} or $w->{pos}->{curv} > $w->{pos}->{vise} ) {
		my $addlist;
		if ( $w->{pos}->{curv} < $w->{pos}->{visb} ) {
			$addlist = $w->{pos}->{curv};
		}
		else {
			$addlist = $w->{pos}->{curv} - $w->{table}->{visrows};
		}
		$w->{pos}->{visb} = $addlist;
		$w->{pos}->{vise} = $addlist + $w->{table}->{visrows};
		foreach my $i ( 0..$w->{table}->{visrows} ) {
			foreach my $j ( 0..$w->{table}->{numfields}) {