/usr/local/CPAN/Tk-TM/Tk/TM/DataObject.pm
#!perl -w
#
# Tk Transaction Manager.
# Data Object.
#
# makarow, demed
#
package Tk::TM::DataObject;
require 5.000;
use strict;
use Tk;
use Tk::TM::Common;
use Tk::TM::Lang;
use Tk::TM::DataObjSet;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = '0.53';
use vars qw($Current @Available $Error $Search);
$Current =''; # Current DO
@Available =(); # All available DOs
$Error =''; # Error if occured
$Search =''; # Search for
1;
#######################
sub new {
my $class=shift;
my $self ={};
bless $self,$class;
$self->initialize(@_);
}
#######################
sub initialize {
my $self =shift;
$self->{-wgtbl} =undef; # WG screen table # configurable
$self->{-wgbln} =undef; # WG screen blank # configurable
$self->{-wgarr} =[]; # WG widget list # configurable
$self->{-wgscr} =undef; # WG parent screen widget # configurable
$self->{-wgmnu} = # WG navigator widget # configurable
ref($Tk::TM::DataObjSet::Current) && ($Tk::TM::DataObjSet::Current->set(-dos) eq \@Available) ? $Tk::TM::DataObjSet::Current : undef;
$self->{-wgind} = # WG widget for indicator # configurable
ref($Tk::TM::DataObjSet::Current) ? $Tk::TM::DataObjSet::Current->set(-wgind) : undef;
$self->{-mdedt} = # MD edit mode on # configurable
$Tk::TM::Common::Edit;
$self->{-dsdta} =[]; # DS retrieved data store
$self->{-dsdtm} =1000; # DS data store margin; # configurable
$self->{-dsslp} =undef; # DS sleep flag
$self->{-dsrid} =0; # DS current row id
$self->{-dsrsd} =0; # DS current screen row id
$self->{-dsrfd} =undef; # DS current field no
$self->{-dsrwd} =undef; # DS current widget id
$self->{-dsrwt} =0; # DS current widget is table?
$self->{-dsrnw} =0; # DS current row new?
$self->{-dsrch} =0; # DS current row changed?
$self->{-dsrd0} =[]; # DS current row presaved data
# configurable
$self->{-cbcmd} =\&doDefault; # CB routine;
#$self->{-cbXXX} # CB routines for operations instead of '-cbcmd'
$self->{-dbh} =undef; # DBI database handle # configurable
$self->{-dbfds} =[]; # DBI field descriptions
$self->{-dbfnm} ={}; # DBI field names
$self->{-dbfaw} =50; # DBI field adapt width # configurable
# configurable
$self->{-sqlsel}=undef; # SQL select template
$self->{-sqlins}=undef; # SQL insert template
$self->{-sqlupd}=undef; # SQL update template
$self->{-sqldel}=undef; # SQL delete template
# configurable
$self->{-sqgscr}=undef; # screen to generate widgets on - generate trigger
$self->{-sqgfd} =undef; # [['cruvpktb', table, field, filter value, helper select, ?inccol, label, ?colSpan, ?rowSpan, wgType, ?wgOpt]]
$self->{-sqgsf} =undef; # select from clause
$self->{-sqgsj} =undef; # select where/join subclause
$self->{-sqgsc} =undef; # select where/condition part ['condition',values]
$self->{-sqgso} =undef; # select order by clause
$self->{-sqgpt} =undef; # parameters for table widget
$self->{-sqgpb} =undef; # parameters for blank widget
# configurable
$self->{-parm} ={}; # Programmer`s parameters
$self->{-parmc} = # Common programmer`s parameters
$self->{-wgmnu} ? $self->{-wgmnu}->{-parm} : {};
$Current =$self;
push(@Available, $self);
$self->set(-mdedt=>$self->{-mdedt},@_);
$self;
}
#######################
sub destroy {
my $self =$_[0];
print "destroy($self)\n" if $Tk::TM::Common::Debug;
$self->Stop('#force#end');
@Available = grep($self ne $_, @Available);
$self->{-wgtbl} =undef;
$self->{-wgbln} =undef;
$self->{-wgmnu} =undef;
$self;
}
#######################
sub DESTROY {
my $self =$_[0];
print "DESTROY($self)\n" if $Tk::TM::Common::Debug;
}
#######################
sub set {
return(keys(%{$_[0]})) if scalar(@_) ==1;
return($_[0]->{$_[1]}) if scalar(@_) ==2;
my ($self, %opt) =@_;
foreach my $k (keys(%opt)) {
$self->{$k} =$opt{$k};
}
if ($opt{-wgtbl}) {
$self->{-wgtbl}->set(-do=>$self);
$self->{-dsrwt} =1;
}
if ($opt{-wgbln}) {
$self->{-wgbln}->set(-do=>$self);
$self->{-dsrwt} =0 if !$self->{-wgtbl};
}
if ($opt{-wgarr}) {
my $fld =-1;
foreach my $wg (@{$self->{-wgarr}}) {
$fld++;
next if !$wg || ref($wg) eq 'Tk::Label';
my $tv;
$wg->configure(-textvariable=>\$tv);
$wg->bind('<Key-Prior>' ,sub{$self->RowGo('prev')});
$wg->bind('<Key-Next>' ,sub{$self->RowGo('next')});
$wg->bind('<Control-Home>',sub{$self->RowGo('top')});
$wg->bind('<Control-End>' ,sub{$self->RowGo('bot')});
my $fld1 =$fld;
$wg->bind('<FocusIn>' ,sub{$self->wgFldFocusIn ($wg, $fld1)});
$wg->bind('<FocusOut>',sub{$self->wgFldFocusOut($wg, $fld1)});
# $wg->bind('<Key-F4>' ,sub{$self->wgFldHelper ($wg, $fld1)});
}
$self->{-dsrwt} =0 if !$self->{-wgtbl};
}
if (!$self->{-wgscr}) {
$self->{-wgscr} =($self->{-wgtbl}
? $self->{-wgtbl}
: $self->{-wgbln}
? $self->{-wgbln}
: $self->{-wgarr}->[0]);
$self->{-wgscr} =$self->{-wgscr}->parent if $self->{-wgscr};
}
if (ref($opt{-wgmnu}) || (exists($opt{-mdedt}) && ref($self->{-wgmnu}))) {
$self->{-wgmnu}->setpush(-dos => $self) if ref($opt{-wgmnu}) && !grep {$_ eq $self} @{$self->{-wgmnu}->set(-dos)};
$self->{-wgmnu}->set(-mdedt => $self->{-mdedt}) if $self->{-wgmnu}->DataObject() eq $self;
$self->{-parmc}=$self->{-wgmnu}->{-parm};
}
if (($opt{-sqgfd} || $opt{-sqgsf}) && defined($self->{-sqgfd}) && defined($self->{-sqgsf})) {
my $tbl =$1 if defined($self->{-sqgsf}) && $self->{-sqgsf} =~/^ *([^ ,]+)/;
foreach my $f (@{$self->{-sqgfd}}) {
$tbl =$f->[1] if defined($f->[1]) && $f->[1] ne '';
$f->[1] =$tbl if defined($f->[1]) && $f->[1] eq '';
}
}
if (($opt{-sqgscr} || defined($opt{-sqgfd})) && ref($self->{-sqgscr}) && defined($self->{-sqgfd})) {
$self->{-sqgsf} ='' if !defined($self->{-sqgsf});
$self->{-dsrwd} =undef;
my ($ta, $tf, $ba, $bf) =([],0,[],0);
foreach my $f (@{$self->{-sqgfd}}) {
if ($f->[0] =~/t/i) { push @$ta, [@{$f}[5..$#{@$f}]]; $tf =1}
else { push @$ta, undef }
if ($f->[0] =~/b/i) { push @$ba, [@{$f}[5..$#{@$f}]]; $bf =1}
else { push @$ba, undef }
}
my $wg; eval('use Tk::TM::wgTable; use Tk::TM::wgBlank');
if ($tf && $bf) {
if (Exists($self->{-wgtbl}) && Exists($self->{-wgbln})) {
$tf =$self->{-wgtbl};
$bf =$self->{-wgbln};
$wg =$tf->parent;
}
else {
$self->{-wgtbl}->destroy() if Exists($self->{-wgtbl});
$self->{-wgbln}->destroy() if Exists($self->{-wgbln});
$self->{-wgtbl} =$self->{-wgbln} =undef;
$wg =$self->{-sqgscr}->Frame();
$tf =$wg->tmTable()->pack(-anchor=>'nw');
$bf =$wg->tmBlank()->pack(-anchor=>'nw');
eval{$wg->{-do} =$self};
}
$tf->set(-colspecs=>$ta, ($self->{-sqgpt} ? @{$self->{-sqgpt}} : ()))->pack(-anchor=>'nw')->Remake();
$bf->set(-wgspecs =>$ba, ($self->{-sqgpb} ? @{$self->{-sqgpb}} : ()))->pack(-anchor=>'nw')->Remake();
$self->set(-wgtbl=>$tf,-wgbln=>$bf);
}
elsif ($tf) {
$self->{-wgbln}->destroy() if Exists($self->{-wgbln});
$self->{-wgbln} =undef;
$wg =Exists($self->{-wgtbl}) ? $self->{-wgtbl} : $self->{-sqgscr}->tmTable();
$wg->set(-colspecs=>$ta, ($self->{-sqgpt} ? @{$self->{-sqgpt}} : ()))->Remake();
$self->set(-wgtbl=>$wg);
}
elsif ($bf) {
$self->{-wgtbl}->destroy() if Exists($self->{-wgtbl});
$self->{-wgtbl} =undef;
$wg =Exists($self->{-wgbln}) ? $self->{-wgbln} : $self->{-sqgscr}->tmBlank();
$wg->set(-wgspecs=>$ba, ($self->{-sqgpb} ? @{$self->{-sqgpb}} : ()))->Remake();
$self->set(-wgbln=>$wg);
}
return($wg)
}
$self;
}
#######################
sub setpush {
my ($self, $opt) =(shift,shift);
if ($opt =~/-wgarr/) {
$self->set(-wgarr => [$self->set(-wgarr),@_]);
}
elsif (ref($self->{$opt}) eq 'ARRAY') {
push(@{$self->{$opt}}, @_)
}
elsif (ref($self->{$opt}) eq 'HASH') {
my %v =@_;
foreach my $k (keys(%v)) { $self->{$opt}->{$k} =$v{$k} }
}
scalar(@_) ==1 ? $_[0] : @_;
}
#######################
# Widget Data System Dependent Functions
#######################
sub dsAdapt { # Adapt Widgets
my $self =shift;
return $self if !$self->{-dbfaw};
$self->{-wgtbl}->Adapt() if $self->{-wgtbl};
$self->{-wgbln}->Adapt() if $self->{-wgbln};
$self
}
sub dsDisplay { # Display data
$_[0]->{-wgtbl}->Display() if $_[0]->{-wgtbl};
$_[0]->dsDispWg();
return $_[0];
}
sub dsDispWg { # Display data in widgets and blank widget
my $self =shift;
my $fld =-1;
$self->{-wgbln}->Display() if $self->{-wgbln};
foreach my $wg (@{$self->{-wgarr}}) {
$fld++;
next if !Exists($wg) || ref($wg) eq 'Tk::Label';
eval{
${$wg->cget(-textvariable)} =undef;
${$wg->cget(-textvariable)} =($self->{-dsdta}->[$self->{-dsrid}]->[$fld]) if $self->{-dsdta}->[$self->{-dsrid}];
}
}
$self
}
sub dsFldDta { # Get specified field current data; Silent
my ($self, $wg) =@_;
my $ret;
if (defined($wg) && !ref($wg)) {
$ret =$wg =~/^([\d]+)$/
? $self->{-dsdta}->[$self->{-dsrid}]->[$wg]
: $self->{-dsdta}->[$self->{-dsrid}]->[$self->{-dbfnm}->{$wg}]
}
elsif (defined($wg) && Exists($wg)) {
$ret =${$wg->cget(-textvariable)}
}
elsif ($self->{-dsrwd} && Exists($self->{-dsrwd})) {
$ret =${$self->{-dsrwd}->cget(-textvariable)}
}
# !defined($ret) ? '' : $ret;
$ret
}
sub dsFldUpd { # Replace specified field data; Display
my ($self, $fld, $data) =@_;
my $wg;
if (!defined($fld) || $fld eq '') {$fld =$self->{-dsrfd} || 0}
elsif ($fld !~/^([\d]+)$/) {$fld =$self->{-dbfnm}->{$fld}}
$wg =$self->{-wgtbl}->set('-widgets')->[$self->{-dsrsd}]->[$fld] if $self->{-wgtbl};
if ($wg){
${$wg->cget(-textvariable)} =$data;
}
$wg =undef;
$wg =$self->{-wgbln}->set('-widgets')->[$fld] if $self->{-wgbln};
if ($wg){
${$wg->cget(-textvariable)} =$data;
}
$wg =undef;
$wg =${$self->{-wgarr}}[$fld];
if ($wg){
${$wg->cget(-textvariable)} =$data;
}
$self->{-dsdta}->[$self->{-dsrid}]->[$fld] =$data;
return 1;
}
sub dsFocus { # Set focus to current row & widget
if ($_[0]->{-dsrwt} && $_[0]->{-wgtbl}) {$_[0]->{-wgtbl}->Focus()}
elsif ($_[0]->{-wgbln}) {$_[0]->{-wgbln}->Focus()}
elsif ($_[0]->{-dsrwd}) {$_[0]->{-dsrwd}->focusForce()}
$_[0];
}
sub dsReset { # Reset data system, before retrieving; Silent
if (!$_[1]) { # usual
$_[0]->{-dsdta} =[];
}
else { # sleep
$_[0]->{-dsslp} =$_[0]->{-dsrid};
$_[0]->{-dsdta} =[$_[0]->dsRowDta()];
}
$_[0]->{-dsrid} =0;
$_[0]->{-dsrd0} =[];
return $_[0];
}
sub dsRowCount { # Number of data rows
return (scalar(@{$_[0]->{-dsdta}}) || 0);
}
sub dsRowDel { # Delete current row in data system; Display
my $self =shift;
splice(@{$self->{-dsdta}}, $self->{-dsrid}, 1);
$self->{-dsrid} =$#{$self->{-dsdta}} if $self->{-dsrid} >$#{$self->{-dsdta}};
$self->{-dsrid} =0 if $self->{-dsrid} <0;
$self->dsDisplay();
return 1;
}
sub dsRowDta { # Get current row data from store; Silent
my ($self, $row) =@_;
$row =$self->{-dsrid} if !defined($row);
return (defined($self->{-dsdta}->[$row]) ? $self->{-dsdta}->[$row] : []);
}
sub dsRowFeed { # Feed row into data system store; Silent
return 0 if defined($_[0]->{-dsdtm}) && scalar(@{$_[0]->{-dsdta}}) >$_[0]->{-dsdtm};
push(@{$_[0]->{-dsdta}}, $_[1]);
return 1;
}
sub dsRowFeedAll { # Feed all rows into data system store; Silent
$_[0]->{-dsdta} =$_[1];
splice(@{$_[0]->{-dsdta}},$_[0]->{-dsdtm}) if defined($_[0]->{-dsdtm});
$_[0]->{-dsdta}
}
sub dsRowGo { # Go to specified row in data system; Display
my ($self, $row) =@_;
my $tbldraw =0;
if (!defined($row)) {
if (!$self->{-wgtbl}) {}
elsif ($self->{-dsrsd} >$self->{-dsrid}) {$self->{-dsrsd} =$self->{-dsrid}};
$tbldraw =1 if $self->{-wgtbl};
}
elsif ($row eq 'next') {
if (!$self->{-wgtbl}) {}
elsif ($self->{-wgtbl}->set('-rowcount')-1 >$self->{-dsrsd}
&& $self->{-dsrid} <$#{$self->{-dsdta}}) {$self->{-dsrsd}+=1}
else {$tbldraw =1};
$self->{-dsrid} +=1 if $self->{-dsrid} <$#{$self->{-dsdta}};
}
elsif ($row eq 'prev') {
if (!$self->{-wgtbl}) {}
elsif ($self->{-dsrsd} >0) {$self->{-dsrsd}-=1}
else {$tbldraw =1};
$self->{-dsrid} -=1 if $self->{-dsrid} >($self->{-dsrsd}||0);
}
elsif ($row eq 'pgdn') {
return $self->dsRowGo('next') if !$self->{-wgtbl} || !$self->{-dsrwt};
return $self->dsRowGo('bot') if $self->{-wgtbl}->set('-rowcount') >$self->dsRowCount() -$self->{-dsrid} -1;
$self->{-dsrid} +=$self->{-wgtbl}->set('-rowcount') -1;
$tbldraw =1
}
elsif ($row eq 'pgup') {
return $self->dsRowGo('prev') if !$self->{-wgtbl} || !$self->{-dsrwt};
return $self->dsRowGo('top') if $self->{-wgtbl}->set('-rowcount') >$self->{-dsrid};
$self->{-dsrid} -=$self->{-wgtbl}->set('-rowcount') -1;
$tbldraw =1
}
elsif ($row eq 'top') {
$self->{-dsrsd} =0;
$tbldraw =1 if $self->{-wgtbl};
$self->{-dsrid} =($self->{-dsrsd}||0);
}
elsif ($row eq 'bot') {
if ($self->{-wgtbl}) {
$self->{-dsrsd} =$self->{-wgtbl}->set('-rowcount');
$self->{-dsrsd} =$self->dsRowCount() if $self->dsRowCount() <$self->{-dsrsd};
$self->{-dsrsd} -=1 if $self->{-dsrsd};
$tbldraw =1
}
$self->{-dsrid} =$#{$self->{-dsdta}};
}
else {
if ($row <0) { $row =0}
elsif ($row >$#{$self->{-dsdta}}) {$row =$#{$self->{-dsdta}}}
if (!$self->{-wgtbl}) {}
elsif ($self->{-dsrsd} >$row) {$self->{-dsrsd} =$row}
$tbldraw =1 if $self->{-wgtbl};
$self->{-dsrid} =$row;
}
$self->{-dsrid} =0 if $self->{-dsrid} <0;
$self->{-dsrsd} =0 if $self->{-dsrsd} <0;
$self->{-wgtbl}->Display() if $tbldraw;
$self->dsDispWg();
$self->dsFocus();
return 1;
}
sub dsRowNew { # Create new row in data system; Display
my ($self, $place) =@_;
push(@{$self->{-dsdta}}, []);
$self->{-dsrid} =$#{$self->{-dsdta}};
$self->{-dsrsd}+=1 if $self->{-wgtbl} && $self->{-dsrid} >0 && $self->{-wgtbl}->set('-rowcount')-1 >$self->{-dsrsd};
$self->dsDisplay();
$self->dsFocus();
return 1;
}
sub dsRowUpd { # Replace current row in data system; Display
my ($self, $data) =@_;
my $fld;
$fld =-1;
foreach my $dt (@$data) {
$fld++;
$self->{-dsdta}->[$self->{-dsrid}]->[$fld] =$dt;
}
$self->dsDisplay();
return 1;
}
#######################
# Abstract Functions: Widget Level
#######################
sub wgFldFocusIn { # Field got focus; internally used by ds
my ($self, $wg, $fld, $row) =@_;
my ($rowchg, $tblin) =(0, defined($row));
print "wgFldFocusIn(",join(', ',map {defined($_) ? $_ : 'null'} @_),"; ",$self->dsRowCount(),")\n" if $Tk::TM::Common::Debug;
if ($Current ne $self) {$Current =$self; $self->{-wgmnu}->set(-mdedt=>$self->{-mdedt}) if ref($self->{-wgmnu})}
$wg =$self->{-dsrwd} ||return(0) if !defined($wg);
$fld =$self->{-dsrfd} ||0 if !defined($fld);
$row =$self->{-dsrsd} ||0 if !defined($row);
# print "wgFldFocusIn1($wg,$fld,$row)\n" if $Tk::TM::Common::Debug;
if ($row ne $self->{-dsrsd}) {
# print "wgFldFocusIn2($wg,$fld,$row -> ",$self->{-dsrsd},")\n" if $Tk::TM::Common::Debug;
if (!$self->Stop('#save'))
{$self->{-dsrwd}->focusForce(); $self->wgIndicate(); return(0)}
if ($self->{-dsrid} +$row -$self->{-dsrsd} >$self->dsRowCount()-1)
{ref($self->{-dsrwd}) ? $self->{-dsrwd}->focusForce() : $self->dsFocus(); return(0)};
$self->{-dsrid} =$self->{-dsrid} +$row -$self->{-dsrsd};
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$rowchg =1;
}
$self->{-dsrwd} =$wg;
$self->{-dsrwt} =$tblin;
$self->{-dsrfd} =$fld;
$self->{-dsrsd} =$row;
if ($rowchg) { $self->dsDispWg() }
&{$self->{-cbcmd}}($self,'fdChg1','',$self->{-dsrid},$fld,$wg);
$self->wgIndicate();
}
sub wgFldFocusOut { # Field lost focus; internally used by ds
my ($self, $wg, $fld, $row) =@_;
print "wgFldFocusOut(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
if ($Current ne $self) {$Current =$self; $self->{-wgmnu}->set(-mdedt=>$self->{-mdedt}) if ref($self->{-wgmnu})}
$wg =$self->{-dsrwd} ||return(0) if !defined($wg);
$fld =$self->{-dsrfd} ||0 if !defined($fld);
$row =$self->{-dsrsd} ||0 if !defined($row);
return(0) if $row ne $self->{-dsrsd} || !Exists($wg);
my $old =$self->{-dsrd0}->[$self->{-dsrfd} ||0];
$old ='' if !defined($old);
my $new =$self->dsFldDta();
$new ='' if !defined($new);
# print "wgFldFocusOut1($wg,f=$fld->",$self->{-dsrfd},",r=$row->",$self->{-dsrsd},"; d=",$new,"->",$old,")\n" if $Tk::TM::Common::Debug;
if ( $old ne $new ) {
if ( !$self->{-mdedt}
|| ( !$self->{-dsrch}
&& !$self->Try($self->{-cbcmd},$self,'rwUpd0','',$self->{-dsrid}))
|| !&{$self->{-cbcmd}}( $self, 'fdUpd0'
, ''
, $self->{-dsrid}
, $self->{-dsrfd}
, $self->{-dsrwd})
|| !&{$self->{-cbcmd}}( $self, 'fdUpd1'
, ''
, $self->{-dsrid}
, $self->{-dsrfd}
, $self->{-dsrwd}
, ${$self->{-dsrd0}}[$self->{-dsrfd}||0]
, $new)
) {
$self->dsFldUpd( $self->{-dsrfd}
, ${$self->{-dsrd0}}[$self->{-dsrfd}]);
}
else {
$self->{-dsrch} =1;
$self->{-dsrnw} =1 if $self->dsRowCount()-1 <$self->{-dsrid};
$self->dsFldUpd( $self->{-dsrfd}
, $new);
}
}
}
sub wgFldHelper { # F4 field helper
my ($self, $wg, $fld, $row) =@_;
print "wgFldHelper(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
if ($Current ne $self) {$Current =$self; $self->{-wgmnu}->set(-mdedt=>$self->{-mdedt}) if ref($self->{-wgmnu})}
$wg =$self->{-dsrwd} ||return(0) if !defined($wg);
$fld =$self->{-dsrfd} ||0 if !defined($fld);
$row =$self->{-dsrsd} ||0 if !defined($row);
return(0) if $row ne $self->{-dsrsd};
if (!$self->{-dsrch}
&& !$self->Try($self->{-cbcmd},$self,'rwUpd0','',$self->{-dsrid}))
{ return(0) };
! $self->Try($self->{-cbcmd},$self,'fdUpd0'
, ''
, $self->{-dsrid}
, $self->{-dsrfd}
, $self->{-dsrwd})
|| $self->Try($self->{-cbcmd},$self,'fdHelp'
, ''
, $self->{-dsrid}
, $self->{-dsrfd}
, $self->{-dsrwd})
}
sub wgIndicate {
return 1 if !$_[0]->{-wgind};
my $col =($_[0]->{-dsrfd} ||0);
my ($dbfd, $sqfd);
$_[0]->{-wgind}->configure(-text=>(
'(r=' .(($_[0]->{-dsrid} ||0) +1)
.'/' .$_[0]->dsRowCount()
.', c=' .($col +1)
.($_[0]->{-dsrnw} ? ' New' : '')
.($_[0]->{-dsrch} ? ' Chg' : '')
.')'
.($_[0]->{-wgind}->cget(-relief) !~/sunken/i
? ''
: defined($_[1])
? ' ' .$_[1]
: ' '
. (!defined($sqfd =(defined($_[0]->{-sqgfd}) ? $_[0]->{-sqgfd}->[$col] : undef)) ? ''
: ($sqfd->[0] =~/p/i ?'[PK]':'').($sqfd->[0] =~/k/i ?'[WK]':'')
.($sqfd->[0] =~/([cirsudv]+)/i ? uc("[$1]") : '').(defined($sqfd->[4]) ? '[F4]' : '') .' ')
. (!defined($dbfd =$_[0]->{-dbfds}->[$col]) ? ''
: $dbfd->{NAME} .': ' . ($Tk::TM::Common::SQLType{$dbfd->{TYPE}}||'unknown')
.'(' .(defined($dbfd->{PRECISION}) ? $dbfd->{PRECISION} : '') .',' .(defined($dbfd->{SCALE}) ? $dbfd->{SCALE} :'') .') ')
. (!defined($sqfd) ? '' : $sqfd->[6])
)
));
$_[0]->{-wgind}->update if defined($_[1]);
1
}
sub wgCursorWait {
if (Exists($_[0]->{-wgscr})) {
my $curs =$_[0]->{-wgscr}->toplevel->cget(-cursor);
$_[0]->{-wgscr}->toplevel->configure(-cursor=>$Tk::TM::Common::CursorWait);
$_[0]->{-wgscr}->toplevel->update;
$_[0]->{-wgscr}->toplevel->configure(-cursor=>$curs);
}
}
#######################
# Abstract Functions: Outside used commands
#######################
sub Action { # Execute action
my ($self, $act) =@_;
print "Action(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->Try($self->{-cbcmd}, $self, 'usAct', $act
, $self->{-dsrid} ||0
, $self->{-dsrfd} ||0
, $self->{-dsrwd} ||'')
}
sub Clear { # Clear all data in data system
my ($self, $opt) =@_;
print "Clear(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->Stop(($opt||'') .'#end') || return 0;
$self->dsReset();
$self->dsRowGo('top');
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
return 1;
}
sub Display { # Display data
$_[0]->dsDisplay() && $_[0]->wgIndicate();
}
sub Export { # Export Data
my $self =shift;
print "Export(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
return 0 if !$self->Stop('');
$self->Try($self->{-cbcmd},$self,'doExport',@_)
}
sub Find { # Find Data
my ($self, $find) =@_;
print "Find(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
return(0) if !$self->Stop('');
eval('use Tk::TM::wDialogBox');
my $sch =(defined($find) ? $find : $Search);
my $dbox =$self->{-wgscr}->toplevel->tmDialogBox
(-title=>Tk::TM::Lang::txtMsg('Find')
,-buttons=>[Tk::TM::Lang::txtMsg('Find')
,Tk::TM::Lang::txtMsg('Cancel')]);
my $wg =$dbox->add('Entry',-textvariable=>\$sch)->pack(-fill=>'x');
$wg->icursor('end');
$wg->selectionRange(0,'end');
return(0) if $dbox->Show() !=0;
$Search =$sch;
$self->FindNxt(0);
}
sub FindNxt { # Find Data Again
my ($self,$offs) =@_;
print "FindNxt(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
return(0) if !$self->Stop('');
$self->wgCursorWait;
$offs =1 if !defined($offs);
my $col =$self->{-dsrfd};
my $mrg =$self->dsRowCount() -1;
my $cur =$self->{-dsrid} +$offs;
eval("while (\$cur <=\$mrg && \$self->dsRowDta(\$cur)->[\$col] !~/$Search/i) {\$cur +=1}");
if ($cur >$mrg) {$self->{-wgscr}->toplevel->bell; return(0)};
$self->RowGo($cur);
}
sub Import { # Import Data
my $self =shift;
print "Import(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
return 0 if !$self->Stop('') || !$self->Clear('');
$self->Try($self->{-cbcmd},$self,'doImport',@_)
}
sub Print { # Print Data
my $self =shift;
print "Print(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
return 0 if !$self->Stop('');
$self->Try($self->{-cbcmd},$self,'doPrint',@_)
}
sub Retrieve { # Retrieve data into data system
my ($self,$opt) =@_;
print "Retrieve(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$opt =$opt ||'';
$self->Stop($opt) || return 0;
my $row =$self->{-dsrid};
my $ret =0;
if (defined($self->{-dsslp})) {$row =$self->{-dsslp}; $self->{-dsslp} =undef}
$self->dsReset();
$self->dsRowGo('top');
$ret =$self->Try($self->{-cbcmd},$self,'dbRead','');
$self->dsAdapt();
$self->dsRowGo($opt =~/reread/i ? $row : 'top');
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
$ret;
}
sub RowDel { # Delete current row
my $self =shift;
print "RowDel($self; ",$self->{-dsrid},")\n" if $Tk::TM::Common::Debug;
$self->{-mdedt} || return(0);
my $ret =$self->Stop('#save');
return 0 if !$ret;
return 1 if $ret ==2;
$self->Try($self->{-cbcmd},$self,'rwDel0','',$self->{-dsrid}) || return 0;
$self->Try($self->{-cbcmd},$self,'dbDel','',$self->{-dsrid},undef,undef,$self->dsRowDta()) || return 0;
$self->dsRowDel();
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
return 1;
}
sub RowGo { # Go to specified row
my ($self, $row) =@_;
print "RowGo(",join(', ',map {defined($_) ? $_ : 'null'} @_),"; ",$self->{-dsrid},")\n" if $Tk::TM::Common::Debug;
my $ret =$self->Stop('#save');
return 0 if !$ret;
if (!($row eq 'next' && $ret ==2)) {
$self->dsRowGo($row);
$self->{-dsrd0} =[@{$self->dsRowDta()}];
}
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
return 1;
}
sub RowNew { # Create new row in given place
my $self =shift;
print "RowNew($self)\n" if $Tk::TM::Common::Debug;
$self->{-mdedt} || return(0);
return 0 if !$self->Stop('#save');
$self->Try($self->{-cbcmd},$self,'rwIns0','') || return 0;
$self->dsRowNew(@_);
$self->{-dsrnw} =1;
if ($self->{-sqgfd}) {
my $i =0;
map { $self->dsFldUpd($i,ref($_->[3]) eq 'CODE' ? &{$_->[3]}() : $_->[3])
if defined($_->[3]);
$i++
} @{$self->{-sqgfd}};
}
$self->Try($self->{-cbcmd},$self,'rwIns1',$self->{-dsrid});
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
return 1;
}
sub RowUndo { # Undo current row
my ($self, $opt) =@_;
print "RowUndo(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->{-mdedt} || return(0);
$self->Stop($opt .'#undo') || return 0;
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
}
sub Save { # Save data if changed
my ($self, $opt) =@_;
print "Save(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->{-mdedt} || return(0);
$self->Stop(($opt||'') .'#save') || return 0;
$self->Try($self->{-cbcmd},$self,'rwChg1','',$self->{-dsrid});
$self->wgIndicate();
}
sub Sleep { # Free data system, Retrieve - ups.
my ($self, $opt) =@_;
print "Sleep(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->Stop(($opt||'') .'#force#end') || return 0;
if ($opt =~/wgs/i) {
$self->{-wgtbl}->destroy if Exists($self->{-wgtbl});
$self->{-wgbln}->destroy if Exists($self->{-wgbln});
grep {$_->destroy if Exists($_)} @{$self->{-wgarr}};
$self->{-wgtbl} =undef;
$self->{-wgbln} =undef;
$self->{-wgarr} =[];
$self->{-wgind} =undef;
$self->{-dsrwd} =undef;
}
if ($opt =~/dta/i || !$opt) {
$self->dsReset(1);
}
1;
}
sub Stop { # Stop editing data if any
print "Stop(",join(', ',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
my ($self, $opt) =@_; $opt ='' if !defined($opt);
$self->wgFldFocusOut();
# print "Stop1(",join(', ',map {defined($_) ? $_ : 'null'} @_),"; ", $self->{-dsrid}, ", ", $self->{-dsrnw}, ", ", $self->{-dsrch},")\n" if $Tk::TM::Common::Debug;
$self->{-dsrnw} || $self->Try($self->{-cbcmd},$self,'rwChg0',$opt,$self->{-dsrid}) || return 0;
# Traverse for update
if (!$self->{-dsrch} && !$self->{-dsrnw}) {
$self->Try($self->{-cbcmd},$self,'doEnd',$opt,$self->{-dsrid},undef,undef,$self->dsRowDta()) if $opt=~/end/;
return 1
}
if ( $self->{-dsrnw}
&& !$self->{-dsrch}) {
return 2 if $self->dsRowCount() <2;
$self->{-dsrch} =0;
$self->{-dsrnw} =0;
if ($opt=~/end/i) {
$self->Try($self->{-cbcmd},$self,'doEnd',$opt,$self->{-dsrid},$self->dsRowDta());
return 1
}
$self->dsRowDel();
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->wgIndicate();
return 2
}
if ($opt=~/undo/i) { # In doubt
$self->{-dsrch} =0;
$self->{-dsrnw} =0;
if ($opt=~/end/i) {
$self->Try($self->{-cbcmd},$self,'doEnd',$opt,$self->{-dsrid},$self->dsRowDta());
return 1
}
$self->dsRowUpd($self->{-dsrd0});
$self->wgIndicate();
return 1;
}
if ($opt!~/save/i) { # insert '1 ||' for debug
my $reply =$self->StopMsgBox($opt);
return 0 if $reply =~/c/i && $opt !~/force/i;
if ($reply =~/[nc]/i) {
eval {$_[1] =$opt =$opt ."#undo"};
$self->{-dsrch} =0;
$self->{-dsrnw} =0;
if ($opt=~/end/i) {
$self->Try($self->{-cbcmd},$self,'doEnd',$opt,$self->{-dsrid},$self->dsRowDta());
return 1
}
$self->dsRowUpd($self->{-dsrd0});
$self->wgIndicate();
return 1;
}
eval {$_[1] =$opt =$opt ."#save"};
}
$self->wgCursorWait;
$self->Try($self->{-cbcmd},$self
, $self->{-dsrnw} ? 'dbIns' : 'dbUpd'
, $opt
, $self->{-dsrid}
, undef, undef
, $self->{-dsrd0}
, $self->dsRowDta() # sync scr may be
) || return 0;
!$self->{-dsrnw} || $self->Try($self->{-cbcmd},$self,'rwChg0',$opt,$self->{-dsrid}) || return 0;
# Traverse for Insert
$self->Try($self->{-cbcmd},$self
, 'rwUpd1'
, $opt
, $self->{-dsrid}
, undef, undef
, $self->{-dsrd0}
, $self->dsRowDta() # sync scr may be
) || return 0;
$self->{-dsrch} =0;
$self->{-dsrnw} =0;
$self->{-dsrd0} =[@{$self->dsRowDta()}];
$self->wgIndicate();
$self->Try($self->{-cbcmd},$self,'doEnd',$opt,$self->{-dsrid},$self->dsRowDta()) if $opt=~/end/;
return 1;
}
sub StopMsgBox { # MessageBox 'Save Changes?'; Internally used in 'Stop'
my ($self, $opt) =@_;
my $ret;
$ret =$self->{-wgscr}->
messageBox('-icon' => 'question'
, -type => ($opt=~/force/i ? 'YesNo' : 'YesNoCancel')
, -title => Tk::TM::Lang::txtMsg('Save changes?')
, -message => Tk::TM::Lang::txtMsg('Data was modified') .', ' .Tk::TM::Lang::txtMsg('Save changes?'));
$ret =substr(lc($ret), 0, 1);
$ret =~tr/c/n/ if $opt=~/force/i;
return $ret;
}
sub Try {
my ($self,$sub) =(shift,shift);
my $ret =ref($sub) eq 'CODE' ? eval {&{$sub}(@_)} : $sub;
print "Try(",join(',',map {defined($_) ? $_ : 'null'} @_),")->",defined($ret) ? $ret : 'null',"\n" if $Tk::TM::Common::Debug;
$self->{-wgscr}->messageBox(-icon=>'error',-type=>'Ok',-title=>Tk::TM::Lang::txtMsg('Error')
,-message=> $@) if $@;
$ret
}
#######################
# Abstract Functions: Implementations
#######################
sub doDefault { # Template of User-defined function
my ($self, $cmd, $opt, $row, $fld, $wg, $dta, $new) =(shift, shift, @_);
print "**CB($self, $cmd, ", join(", ", map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
if ($self->{"-cb${cmd}"}) {
my $sub =$self->{"-cb${cmd}"};
return(&$sub($self,@_))
}
if ($cmd eq 'fdChg1') { # goto field
}
elsif ($cmd eq 'fdHelp') { # F4 field helper
if (defined($self->{-sqgfd}) && defined($self->{-sqgfd}->[$fld]->[4])) {
my $hd =$self->{-sqgfd}->[$fld]->[4];
return $self->DBIHlp(&$hd()) if ref($hd) eq 'CODE';
return $self->DBIHlp($hd) if !ref($hd);
return $self->DBIHlp($hd) if ref($hd->[0]);
return $self->DBIHlp($self->DBIGen('-sqlsel',$opt .'#genbuf',$hd)) if ref($hd->[$#{@$hd}]) ne 'ARRAY';
my @sql =$self->DBIGen('-sqlsel',$opt .'#genbuf',[$hd->[0],@{$hd->[1]}]);
my $cmd =shift(@sql);
return $self->DBIHlp($cmd,\@sql,$hd->[2]);
}
}
elsif ($cmd eq 'fdUpd0') { # modify field? immediate before 'fdUpd1'
return(1) if !defined($self->{-sqgfd})
|| $self->{-sqgfd}->[$fld]->[0] !~/[v]/i
&& ( (!$self->{-dsrnw} && $self->{-sqgfd}->[$fld]->[0] =~/[u]/i)
||($self->{-dsrnw} && $self->{-sqgfd}->[$fld]->[0] =~/[ci]/i));
return(0)
}
elsif ($cmd eq 'fdUpd1') { # field modified: accept changes?
}
elsif ($cmd eq 'rwChg0') { # change row? save details
}
elsif ($cmd eq 'rwChg1') { # row changed: retrieve details
}
elsif ($cmd eq 'rwDel0') { # delete row?
return($self->{-mdedt} =~/[1-9d]/i ? 1 : 0);
}
elsif ($cmd eq 'rwIns0') { # insert row? save masters
return($self->{-mdedt} =~/[1-9ci]/i ? 1 : 0);
}
elsif ($cmd eq 'rwIns1') { # row created: fill default values
}
elsif ($cmd eq 'rwUpd0') { # update row?
return($self->{-mdedt} =~/[1-9u]/i ? 1 : 0);
}
elsif ($cmd eq 'rwUpd1') { # row updated or inserted: SQL reselectrow
}
elsif ($cmd eq 'dbRead') { # SQL select
return($self->DBICmd($opt,$self->DBIGen('-sqlsel',$opt)));
}
elsif ($cmd eq 'dbIns') { # SQL insert
return($self->DBICmd($opt,$self->DBIGen('-sqlins',$opt)));
}
elsif ($cmd eq 'dbUpd') { # SQL update
return($self->DBICmd($opt,$self->DBIGen('-sqlupd',$opt)));
}
elsif ($cmd eq 'dbDel') { # SQL delete
return($self->DBICmd($opt,$self->DBIGen('-sqldel',$opt)));
}
elsif ($cmd eq 'doEnd') { # end using data object
}
elsif ($cmd eq 'doExport') { # export data to file
return($self->doExport(@_))
}
elsif ($cmd eq 'doImport') { # import data from file
return($self->doImport(@_))
}
elsif ($cmd eq 'doPrint') { # print data
return($self->doPrint(@_))
}
return 1;
}
sub doExport { # Export Data
my ($self, $file, $fmt) =@_;
if (!$file) {
eval('use Tk::FileSelect');
$file =$self->{-wgscr}->toplevel->getSaveFile(-title=>Tk::TM::Lang::txtMsg('Save data into file'),-defaultextension=>'.txt');
return('') if !$file;
}
local *OUT;
open(OUT, ">$file") || ($self->{-wgscr}->messageBox(-icon=>'error',-type=>'Ok',-title=>Tk::TM::Lang::txtMsg('Error'),-message=>(Tk::TM::Lang::txtMsg('Opening') ." >$file: $!")), return(''));
for (my $rowno =0; $rowno <$self->dsRowCount(); $rowno++) {
my $row ='';
foreach my $flddta (@{$self->dsRowDta($rowno)}) {
$row =$row .$flddta ."\t";
}
print(OUT $row, "\n") || ($self->{-wgscr}->messageBox(-icon=>'error',-type=>'Ok',-title=>Tk::TM::Lang::txtMsg('Error'),-message=>(Tk::TM::Lang::txtMsg('Writing') ." >$file: $!")), return(''));
}
close(OUT) || ($self->{-wgscr}->messageBox(-icon=>'error',-type=>'Ok',-title=>Tk::TM::Lang::txtMsg('Error'),-message=>(Tk::TM::Lang::txtMsg('Closing') ." >$file: $!")), return(''));
return($file);
}
sub doImport { # Import Data
my ($self, $file, $fmt) =@_;
if (!$file) {
eval('use Tk::FileSelect');
$file =$self->{-wgscr}->toplevel->getOpenFile(-title=>Tk::TM::Lang::txtMsg('Load data from file'),-defaultextension=>'.txt');
return('') if !$file;
}
local *IN;
open(IN, "<$file") || ($self->{-wgscr}->messageBox(-icon=>'error',-type=>'Ok',-title=>Tk::TM::Lang::txtMsg('Error'),-message=>(Tk::TM::Lang::txtMsg('Opening') ." <$file: $!")), return(''));
while (!eof(IN)) {
my $row =<IN>;
if (!defined($row)) {
$Error =(Tk::TM::Lang::txtMsg('Reading') ." <$file: $!");
last;
}
chomp($row);
$self->dsRowFeed([split(/\t/, $row)]);
$self->{-dsrid} =$self->dsRowCount() -1;
$self->{-dsrnw} =1;
$self->{-dsrch} =1;
next if $self->Stop('#save#silent');
$self->{-dsrnw} =0;
$self->{-dsrch} =1;
$self->{-dsrd0} =[@{$self->dsRowDta()}];
next if $self->Stop('#save#silent');
$self->{-dsrnw} =1;
$self->{-dsrch} =0;
$self->dsRowDel();
last;
}
$self->RowGo('bot');
close(IN) || ($Error =$Error || (Tk::TM::Lang::txtMsg('Closing') ." >$file: $!"));
$Error && $self->{-wgscr}->messageBox(-icon=>'error',-type=>'Ok',-title=>Tk::TM::Lang::txtMsg('Error'),-message=>$Error);
return ($Error ? '' : $file);
}
sub doPrint { # Print Data
my ($self, $file, $fmt) =@_;
$self->{-wgscr}->
messageBox(-icon => 'info'
,-type => 'Ok'
,-title => Tk::TM::Lang::txtMsg('Pardon')
,-message=> Tk::TM::Lang::txtMsg('Function not released'));
return('');
}
#######################
# Abstract Functions: Useful methods
#######################
sub DBICmd { # DBI Command execution
my $self =shift;
print "DBICmd($self; ",join(';',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
my $dbh =($_[0] =~/^DBI:/i ? shift : $self->{-dbh} ? $self->{-dbh} : $Tk::TM::Common::DBH);
return(0) if !$dbh;
my $opt =($_[0] =~/^#/i || $_[0] eq '' ? shift : '');
return(1) if !@_;
my $ret =1;
my $err ='';
$Error ='';
$self->wgCursorWait;
CMD:
my $cmd =shift || 'commit';
SQL:
my $sql ='';
my $sqx =0;
if ($cmd =~/^selectrow (.*)/i) {$sql ='select '.$1; $cmd ='selectrow_array'; $sqx =1}
elsif ($cmd =~/^select /i) {$sql =$cmd; $cmd ='selectall_arrayref'; $sqx =2}
elsif ($cmd =~/^(insert|update|delete) /i) {$sql =$cmd; $cmd ='do'}
elsif ($cmd !~/^(commit|rollback)/i) {$sql =shift}
if (ref($_[0]) =~/array/i && defined($_[1]) && $dbh->{AutoCommit}) {eval {$dbh->{AutoCommit} =0}}
print uc($cmd), " ", $sql || '?', "; \"",join('", "',map {defined($_) ? $_ : 'null'} ref($_[0]) =~/array/i ? @{$_[0]} : @_),"\"\n" if $Tk::TM::Common::Echo;
$self->wgIndicate(uc($cmd) .' ' .($sql || '?'));
my $rv =undef;
if ($sqx ==2) {
my $dbs =$dbh->prepare($sql);
$dbs->execute(ref($_[0]) =~/array/i ? @{$_[0]} : @_) if $dbs && !$dbh->err;
$rv =$dbs->fetchall_arrayref if $dbs && !$dbh->err;
if ($rv) {$self->DBIDesc($dbs)}
}
elsif ($sqx ==1) {
$rv =[$dbh->$cmd($sql, undef, ref($_[0]) =~/array/i ? @{$_[0]} : @_)];
$rv =undef if $dbh->err;
}
else {
$rv =(ref($cmd)
? &$cmd($dbh)
: !$sql
? ($dbh->{AutoCommit} && $cmd =~/^(commit|rollback)/i ? 1 : $dbh->$cmd())
: $dbh->$cmd($sql, undef, ref($_[0]) =~/array/i ? @{$_[0]} : @_)
)
}
if (!$sqx) {$ret =$ret ? $rv : $ret}
elsif ($cmd =~/^selectrow/i) {$ret =$ret ? $rv && $self->dsRowUpd($rv) : $ret}
elsif ($cmd =~/^selectall/i) {$ret =$ret ? $rv && $self->dsRowFeedAll($rv) : $ret}
$Error = $err = $err || $dbh->errstr || $dbh->err;
if (ref($_[0]) =~/array/i && defined($_[1])) {
shift;
if ($err) {$cmd ='rollback'; goto SQL}
goto CMD;
}
if ($cmd =~/^(commit|rollback) /i && !$dbh->{AutoCommit}) {eval {$dbh->{AutoCommit} =1}};
if (!$err) {}
elsif ($opt =~/#silent/i) {$ret =0}
else {
$self->{-wgscr}->
messageBox(-icon => 'error'
,-type => 'Ok'
,-title => Tk::TM::Lang::txtMsg('Error')
,-message=> $err);
$ret =0
}
$ret;
}
sub DBICnd { # DBI SQL Condition dialog
my $self =shift;
return(0) if !$self->Stop();
print "DBICnd($self; ",join(';',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->wgCursorWait;
my ($ssc, $sso, $vsc, $vso);
my $sqlc =(ref($self->{-sqlsel}) ? $self->{-sqlsel}->[0] : $self->{-sqlsel});
if (defined($self->{-sqgsf})) {
$vsc =$self->{-sqgsc};
$vso =$self->{-sqgso};
$ssc =$vsc;
$sso =$vso;
}
elsif (defined($sqlc) && $sqlc =~/^SELECT/i){
$ssc =$sqlc;
$vsc =$vso ='';
$vsc =$2 if $sqlc =~/( +\n*WHERE +)(.*?)(?= +ORDER +BY +| +GROUP +BY +|\n|\z)/i;
$vso =$2 if $sqlc =~/( +\n*ORDER +BY +)(.*?)(?= +GROUP +BY +|\n|\z)/i;
}
else {
$self->{-wgscr}->
messageBox(-icon => 'info'
,-type => 'Ok'
,-title => Tk::TM::Lang::txtMsg('Pardon')
,-message=> Tk::TM::Lang::txtMsg('Function not released'));
return(0);
}
my $do =new Tk::TM::DataObject(-mdedt=>'u');
if ($self->{-sqgfd}) {
foreach my $v (@{$self->{-sqgfd}}) {
$do->dsRowFeed([$do->dsRowCount(),$v->[1],$v->[2],$v->[6],$v->[3]]);
}
}
eval('use Tk::TM::wDialogBox');
my $dlg =$self->{-wgscr}->tmDialogBox
(-title=>Tk::TM::Lang::txtMsg('Condition')
,-buttons=>[Tk::TM::Lang::txtMsg('Ok')
,Tk::TM::Lang::txtMsg('Cancel')]);
$dlg->add('tmMenu',-mdmnu=>'',-mdnav=>1,-dos=>[$do])->pack(-anchor=>'nw');
my $tbl =$dlg->add('tmTable'
,-rowcount=>($do->dsRowCount()>10 ? 10 : $do->dsRowCount())
,-colspecs=>[['#','Entry',-width=>2,-state=>'disabled', -bg=>$dlg->cget(-bg)]
,['Table','Entry',-state=>'disabled', -bg=>$dlg->cget(-bg)]
,['Field','Entry',-state=>'disabled', -bg=>$dlg->cget(-bg)]
,['Label','Entry',-state=>'disabled', -bg=>$dlg->cget(-bg)]
,['Filter','Entry']]
)->pack(-anchor=>'w');
$dlg->add('Label',-text=>Tk::TM::Lang::txtMsg('Where condition'))->pack(-anchor=>'w');
$dlg->add('Entry',-textvariable=>\$vsc)->pack(-anchor=>'w',-expand=>'yes',-fill=>'x');
$dlg->add('Label',-text=>Tk::TM::Lang::txtMsg('Order by'))->pack(-anchor=>'w');
$dlg->add('Entry',-textvariable=>\$vso)->pack(-anchor=>'w',-expand=>'yes',-fill=>'x');
$do->RowGo('top');
$do->set(-wgtbl=>$tbl)->Display();
$tbl->Focus();
if ($dlg->Show()!=0) {$do->Stop('#undo#end'); $do->destroy(); return(0)};
$do->Stop('#save#end');
if ($self->{-sqgfd}) {
for (my $i =0; $i <$do->dsRowCount(); $i++) {
my $v =$do->dsRowDta($i)->[4];
$self->{-sqgfd}->[$i]->[3] =!defined($v) ? $v : $v eq '' ? undef : $v;
}
}
$do->destroy();
$self->set(-sqgscr=>$self->{-sqgscr}) if $self->{-sqgsf} && $self->{-sqgscr};
if (defined($self->{-sqgsf})) {
$self->{-sqgsc} =$vsc;
$self->{-sqgso} =$vso;
}
else {
foreach my $v (' +\\n*ORDER +BY +', ' +\\n*GROUP +BY +', '\\z') {
$sqlc =~s/(?=$v)/ \nWHERE /i if $sqlc !~/ +\n*WHERE +/i;
$sqlc =~s/(?=$v)/ \nORDER BY /i if $sqlc !~/ +\n*ORDER +BY +/i;
}
$sqlc =~s/( +\n*WHERE +.*?)(?= +ORDER +BY +| +GROUP +BY +|\n|\z)/ \nWHERE $vsc /i;
$sqlc =~s/( +\n*ORDER +BY +.*?)(?= +GROUP +BY +|\n|\z)/ \nORDER BY $vso /i;
$sqlc =~s/(\nWHERE + *|\nORDER BY + *)(?= +ORDER +BY +| +GROUP +BY +|\n|\z)//ig;
(ref($self->{-sqlsel}) ? $self->{-sqlsel}->[0] :$self->{-sqlsel}) =$sqlc;
}
if (!$self->Retrieve('#reread')) {
if (defined($self->{-sqgsf})) {$self->{-sqgsc} =$ssc; $self->{-sqgso} =$sso}
else {(ref($self->{-sqlsel}) ? $self->{-sqlsel}->[0] :$self->{-sqlsel}) =$ssc}
}
1;
}
sub DBIDesc { # DBI Describe Result Set
my ($self,$sql) =@_;
print "DBIDesc(",join(';',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
my $dbs =(ref($sql) ? $sql : undef);
if (!ref($sql)) {
my $dbh =($self->{-dbh} ? $self->{-dbh} : $Tk::TM::Common::DBH);
return(0) if !$dbh;
$dbs =$dbh->prepare($sql);
$dbs->execute if $dbs && !$dbs->err;
}
eval {
$self->{-dbfds} =[];
$self->{-dbfnm} ={};
for (my $i =$[; $i <$dbs->{NUM_OF_FIELDS} +$[; $i++) {
$self->{-dbfnm}->{$dbs->{NAME}->[$i]} =$i;
my $dsc ={};
eval {$dsc->{NAME} =$dbs->{NAME}->[$i]};
eval {$dsc->{TYPE} =$dbs->{TYPE}->[$i]};
eval {$dsc->{SCALE} =$dbs->{SCALE}->[$i]};
eval {$dsc->{PRECISION} =$dbs->{PRECISION}->[$i]};
eval {$dsc->{NULLABLE} =$dbs->{NULLABLE}->[$i]};
push(@{$self->{-dbfds}}, $dsc);
}
};
$dbs->finish if !ref($sql);
$self
}
sub DBIGen { # DBI SQL Generator
my ($self, $cmd, $opt, $sqla) =@_; $opt ='' if !defined($opt);
my @sql =();
my $rsr =0;
RSR:
if (($sqla || $self->{$cmd}) && !$rsr) {
$sqla =$self->{$cmd} if !defined($sqla);
foreach my $sqlt (ref($sqla) && ref($sqla->[0]) ? @{$sqla} : $sqla) {
my ($sqlc, $sqlp) =('',[]);
if (ref($sqlt)) {
$sqlc =$sqlt->[0]; $sqlc =~s/\n//g;
push @sql, $sqlc, $sqlp;
if ($sqlt->[0] =~/^select /i && $opt !~/genbuf/i) {
map {push @$sqlp, ref($_) eq 'CODE' ? &$_() : $_} @{$sqlt}[1 .. $#{@$sqlt}];
}
else {
my $fldl =0;
my $rwdt =$self->dsRowDta();
foreach my $e (@{$sqlt}[1 .. $#{@$sqlt}]) {
if (ref($e)) { push @$sqlp, &$e() }
elsif ($e >=0) {
$rwdt =$self->{-dsrd0} if $fldl >$e && $sqlt->[0] =~/^update/i;
push @$sqlp, $rwdt->[$e]; $fldl =$e;
}
elsif ($e <0 ) {
for (my $i =$fldl+1; $i <=abs($e); $i++) {
push @$sqlp, $rwdt->[$i]; $fldl =$i;
}
}
}
}
}
else {
$sqlc =$sqlt; $sqlc =~s/\n//g;
push @sql, $sqlc, $sqlp;
if ($sqlt =~/^(insert|delete)/i) {
push @$sqlp, @{$self->dsRowDta()};
}
elsif ($sqlt =~/^update/i) {
push @$sqlp, @{$self->dsRowDta()}, @{$self->{-dsrd0}};
}
}
}
if ($cmd =~/ins|upd/i && !$self->{-sqlsel} && $self->{-sqgsf}) {
$rsr =1; goto RSR;
}
}
elsif ($self->{-sqgsf}) {
$cmd =($rsr ? 'SELECTROW' : $cmd =~/sel/i ? 'SELECT' : $cmd =~/ins/i ? 'INSERT' : $cmd =~/upd/i ? 'UPDATE' : $cmd =~/del/i ? 'DELETE' : undef);
$cmd ="$cmd ";
my ($i, $tbl, $vns, $vvs, $whs, $par) =(0, '', '', '', '',[]);
$tbl =$1 if defined($self->{-sqgsf}) && $self->{-sqgsf} =~/^ *([^ ,]+)/;
if ($cmd =~/^sel/i) {
if ($rsr) {
map { if ($_->[0] =~/[k]/i) {
$whs =$whs .$_->[2] .'=? AND ';
push @$par, $self->dsFldDta($i);
}
$i++
} @{$self->{-sqgfd}};
}
map {
$cmd =$cmd .(defined($_->[1] && $_->[1] ne '' && $_->[2] ne '') ? $_->[1] .'.' : '') .($_->[2] ne '' ? $_->[2] : 'NULL') .', ' if $_->[0] =~/[rs]/i;
if (defined($_->[3])) {
my $v =ref($_->[3]) eq 'CODE' ? &{$_->[3]}() : $_->[3];
$whs =$whs .(defined($_->[1] && $_->[1] ne '') ? $_->[1] .'.' : '') .$_->[2] .(defined($v) ? ' = ?' : ' is NULL ') .' AND ';
push @$par, $v if defined($v);
}
} @{$self->{-sqgfd}};
$cmd =~s/[, ]*$/ /i;
$cmd =$cmd .' FROM ' .$self->{-sqgsf};
$whs =~s/ *AND *$//i;
$whs ="($whs)" if $whs ne '';
if (defined($self->{-sqgsj}) && $self->{-sqgsj} ne '') {
$whs ='(' .$self->{-sqgsj} .')' .($whs ne '' ? ' AND ' .$whs : '')
}
if (defined($self->{-sqgsc}) && $self->{-sqgsc} ne '') {
$whs =($whs ne '' ? $whs .' AND ' :'') .'(' .(ref($self->{-sqgsc}) ? $self->{-sqgsc}->[0] : $self->{-sqgsc}) .')';
map { push @$par, ref($_) eq 'CODE' ? &$_() : $_
} @{$self->{-sqgsc}}[1..$#{@{$self->{-sqgsc}}}]
}
$cmd =$cmd .' WHERE ' .$whs if $whs ne '';
$cmd =$cmd .' ORDER BY ' .$self->{-sqgso} if defined($self->{-sqgso}) && $self->{-sqgso} ne '';
push @sql, $cmd, $par;
}
elsif ($cmd =~/^ins/i) {
map { if ($_->[0] =~/[ci]/i) {
$tbl =$_->[1] if $tbl eq '';
$vns =$vns .$_->[2] .',';
$vvs =$vvs .'?,';
push @$par, $self->dsFldDta($i);
}
$i++
} @{$self->{-sqgfd}};
$vns =~s/[, ]*$//i;
$vvs =~s/[, ]*$//i;
$cmd =$cmd .' INTO ' .$tbl .' (' .$vns .') VALUES (' .$vvs .')';
push @sql, $cmd, $par;
$rsr =1; goto RSR;
}
elsif ($cmd =~/^upd/i) {
map { if ($_->[0] =~/[u]/i) {
$tbl =$_->[1] if $tbl eq '';
$vns =$vns .$_->[2] .'=?, ';
push @$par, $self->dsFldDta($i);
}
$i++
} @{$self->{-sqgfd}};
$i =0;
map { if ($_->[0] =~/[pk]/i) {
$whs =$whs .$_->[2] .'=? AND ';
push @$par, $self->{-dsrd0}->[$i];
}
$i++
} @{$self->{-sqgfd}};
$vns =~s/[, ]*$//i;
$whs =~s/ *AND *$//i;
$cmd =$cmd .' ' .$tbl .' SET ' .$vns .' WHERE ' .$whs;
push @sql, $cmd, $par;
$rsr =1; goto RSR;
}
elsif ($cmd =~/^del/i) {
map { if ($_->[0] =~/[pk]/i) {
$tbl =$_->[1] if $tbl eq '';
$whs =$whs .$_->[2] .'=? AND ';
push @$par, $self->{-dsrd0}->[$i];
}
$i++
} @{$self->{-sqgfd}};
$whs =~s/ *AND *$//i;
$cmd =$cmd .' FROM ' .$tbl .' WHERE ' .$whs;
push @sql, $cmd, $par;
}
}
else {
return(());
}
@sql
}
sub DBIHlp { # DBI entry helper screen
my $self =shift;
print "DBIHlp($self; ",join(';',map {defined($_) ? $_ : 'null'} @_),")\n" if $Tk::TM::Common::Debug;
$self->wgCursorWait;
my $cmd =(ref($_[0]) ? '' : shift);
my $do =new Tk::TM::DataObject(-mdedt=>0);
if ($cmd) {$do->DBICmd($cmd,@{$_[0]})}
else {$do->dsRowFeedAll($_[0])}
if (!$do->dsRowCount) {$do->destroy(); return(0)};
my $colcount =scalar($#{$do->dsRowDta(0)});
my $colspecs =[];
foreach (my $i=@[; $i<=$colcount; $i++) {
push(@$colspecs, ['','Entry']);
}
eval('use Tk::TM::wDialogBox');
my $dlg =$self->{-wgscr}->tmDialogBox
(-title=>Tk::TM::Lang::txtMsg('Choose')
,-buttons=>[Tk::TM::Lang::txtMsg('Ok')
,Tk::TM::Lang::txtMsg('Cancel')]);
$dlg->add('tmMenu',-mdmnu=>'',-mdnav=>1,-dos=>[$do])->pack(-anchor=>'nw');
my $tbl =$dlg->add('tmTable'
,-rowcount=>($do->dsRowCount()>10 ? 10 : $do->dsRowCount())
,-colspecs=>$colspecs)->pack(-anchor=>'w');
$do->RowGo('top');
$do->set(-wgtbl=>$tbl)->Display();
$tbl->Focus();
if ($dlg->Show()!=0) {$do->destroy(); return(0)};
my $dta =$do->dsRowDta();
$self->{-dsrch} =1;
if (!ref($_[1])) {
$self->dsFldUpd(undef, $dta->[0])
}
else {
foreach my $inc (@{$_[1]}) {
$self->dsFldUpd($self->{-dsrfd} +$inc, $dta->[0])
}
}
$do->destroy();
1;
}