ARSObject

 view release on metacpan or  search on metacpan

lib/ARSObject.pm  view on Meta::CPAN

#!perl -w
#
# High level interface above ARS module
#
# Andrew V Makarow, 2010-03-02, K)
#
#
# 2010-03-24 detached
# 2010-03-02 started inside a script
# 
package ARSObject;
use vars qw($VERSION @ISA $AUTOLOAD $CGI::Carp::CUSTOM_MSG);
use UNIVERSAL;
use strict;
use POSIX qw(:fcntl_h);

$VERSION = '0.57';

my $fretry =8;

1;

sub new {	# New ARS object
		# (-param=>value,...) -> ARS object
 my $c=shift;
 my $s ={'' => ''
	,-ctrl => undef		# ARS control struct from ars_Login()
	,-srv  => undef		# Server name
	,-usr  => undef		# User name
	,-pswd => undef		# Password string
	,-lang => ''		# Language
	,-schema => undef	# Schemas to use: [form,...]
	,-vfbase =>		# Var files base
			(do{	my $v =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0;
				$v =~/^(.+?)\.[^\\\/]*$/ ? "$1-" : "$v-"
			})
	#,-storable =>undef	# Use Storable module for cache files?
	,-schgen => 1		# 1 - use vfname('meta') for '-meta', generate it from ARS if not exists.
				# 2 - renewable 'meta' smartly
				# 3 - renew meta always
				# [schema,...] - list to renew
	,-schfdo => 0		# Include display only fields into schema (AR_FIELD_OPTION_DISPLAY)
	,-meta => {}		# Forms metadata from ARS:
				#	{formName}->{-fields}->{fieldName}=>{}
				#	{formName}->{-fldids}->{fieldId}=>{}
				#	Additional parameters may be:
				#	,'fieldLbl' =>label
				#	,'fieldLbll'=>label localised
				#	,'fieldLblc'=>label catenation/comment
				#	,'fieldLbv' =>labels of values
				#	,'fieldLbvl'=>labels of values localised
				#	,'indexUnique'
				#	,'strOut'|'strIn'=>sub(self,form,{field},$_=val){}
	#,-meta-min		# Used in 'arsmetamin' operation
	#,-meta-sql		# 'arsmetasql':	{tableName}->{-cols}->{sqlName}=>{fieldName, sqlName,...}
				#		{tableName}->{-fields}->{fieldName}=>sqlName
				#		{tableName}->{-ids}->{fieldId}=>sqlName
				#		{-forms}->{formName}->{tableName}
				#	also: -sqlname, -sqlntbl, -sqlncol, -sqlninc
				#		-sqlschema
	,-metax => 		# Exclude field schema parameters from '-meta'
			['displayInstanceList','permissions']
	,-metaid => {}		# Commonly used fields with common names and value translation
	,-metadn => {}		# {fieldId | fieldName => 
				#	{fieldName=>'name',FieldId=>id
				#	,strIn=>sub(self,form,{field},$_=val){}
				#	,strOut=>sub(self,form,{field},$_=val){}
				#	},...}
	,-maxRetrieve => 0	# ARS::ars_GetListEntry(maxRetrieve)
	,-entryNo => undef	# Logical number of entry inserted
	,-strFields => 1	# Translate fields data using 'strIn'/'strOut'/'-meta'?
				# 1 - 'enumLimits', 2 - 'fieldLbvl' before 'enumLimits'
	,-cmd =>''		# Command running, for err messages, script local $s->{-cmd}
	,-die =>undef		# Error die/warn,  'Carp' or 'CGI::Carp...'
	# ,-diemsg => undef	#
	,-warn=>undef		# , see set() and connect() below
	# ,-warnmsg => undef	#
	,-cpcon=>undef		# Translation to console codepage sub{}(self, args) -> translated
	,-echo=>0		# Echo printout switch
	,-dbi=>undef		# DBI object, by dbiconnect()
	,-dbiconnect =>undef	#
	,-cgi=>undef		# CGI object, by cgi()
	,-smtp=>undef
	,-smtphost=>undef
	#,-fpl=>[]		# CGI Form Presenter fields list
	#,-fphc=>{}		# 	CGI fields cache
	#,-fphd=>{}		#	DB fields cache
	#,-fpbv=>[]		#	buffer values
	#,-fpbn=>''		#	buffer name == record common name
	};
 bless $s,$c;
 set($s, @_);
 $s->{-storable} =eval('use Storable; 1') if !exists($s->{-storable});
 $s
}


sub AUTOLOAD {	# Use self->arsXXX() syntax for ars_XXX(ctrl,...) calls
 my $m =substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
 return(&{$_[0]->{-die}}($_[0]->efmt("Called name without 'ars'", $_[0]->{-cmd}, undef, 'AUTOLOAD',$m)))
	if $m !~/^ars/;
 $m =~s/^ars/ars_/
	if $m !~/^ars_/;
 $m =~s/^ars/ARS::ars/
	if $m !~/^ARS::/;
 no strict;
 &$m($_[0]->{-ctrl}, @_[1..$#_])
}


sub DESTROY {
	my $s =shift;
	$s->{-die} =undef;
	$s->{-warn}=undef;
	$s->{-ctrl} && eval{ars_Logoff($s->{-ctrl})};
	$s->{-ctrl}=undef;
	$s->{-dbi} && eval{$s->{-dbi}->disconnect()};
	$s->{-dbi} =undef;
	$s->{-cgi} =undef;
	$s->{-diemsg}  =undef;
	$s->{-warnmsg} =undef;
}


sub set {	# Set/Get parameters
		# () -> (parameters)
		# (-param) -> value
		# (-param => value,...) -> self
 return(keys(%{$_[0]})) if scalar(@_) ==1;
 return($_[0]->{$_[1]}) if scalar(@_) ==2;
 my ($s,%a) =@_;

lib/ARSObject.pm  view on Meta::CPAN

 $^S
}

		# error message form ??? use ???
		# (err/var, command, operation, function, args)
sub efmt {
	efmt1(@_)
}

sub efmt0 {
 my ($s, $e, $c, $o, $f, @a) =@_;
 cpcon($s
	,join(': '
		,($c ? $c : ())
		,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
		,($o ? $o : ())
		)
	.($e && ($e eq '$!') && $^E ? (' -> ' .$! .' / ' .$^E) : ( ' -> ' .($e || 'unknown error')))
	)
}

sub efmt1 {
 my ($s, $e, $c, $o, $f, @a) =@_;
 cpcon($s
	,join(' # '
		,($e && ($e eq '$!') && $^E ? ($! .' / ' .$^E) : ($e || 'unknown error'))
		,($o ? $o : ())
		,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
		,($c ? $c : ())
		)
	)
}


sub strquot {	# Quote and Escape string enclosing in ''
 my $v =$_[1];		# (string) -> escaped
 return('undef') if !defined($v);
 $v =~s/([\\'])/\\$1/g;
 $v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
 $v =~/^\d+$/ ? $v : ('\'' .$v .'\'');
}


sub strquot2 {	# Quote and Escape string enclosing in ""
 my $v =$_[1];		# (string) -> escaped
 return('undef') if !defined($v);
 $v =~s/([\\"])/\\$1/g;
 $v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
 $v =~/^\d+$/ ? $v : ('"' .$v .'"');
}


sub arsquot {	# Quote string for ARS
 return('NULL') if !defined($_[1]);
 my $v =$_[1];
 $v =~s/"/""/g;
 $v =~/^\d+$/ ? $v : ('"' .$v .'"');
}


sub dsquot {	# Quote data structure
   $#_ <2		# (self, ?'=>', data struct)
 ? dsquot($_[0],'=> ',$_[1])
 : !ref($_[2])	# (, hash delim, value) -> stringified
 ? strquot($_[0],$_[2])
 : ref($_[2]) eq 'ARRAY'
 ? '[' .join(', ', map {dsquot(@_[0..1],$_)
			} @{$_[2]}) .']'
 : ref($_[2]) eq 'HASH'
 ? '{' .join(', ', map {$_ .$_[1] .dsquot(@_[0..1],$_[2]->{$_})
			} sort keys %{$_[2]}) .'}'
 : strquot($_[0],$_[2])
}


sub dsquot1 {	# Quote data structure, defined elements only
   $#_ <2		# (self, ?'=>', data struct)
 ? dsquot1($_[0],'=> ',$_[1])
 : !ref($_[2])	# (, hash delim, value) -> stringified
 ? strquot($_[0],$_[2])
 : ref($_[2]) eq 'ARRAY'
 ? '[' .join(', ', map {defined($_) ? dsquot1(@_[0..1],$_) : ()
			} @{$_[2]}) .']'
 : ref($_[2]) eq 'HASH'
 ? '{' .join(', ', map {defined($_[2]->{$_}) ? $_ .$_[1] .dsquot1(@_[0..1],$_[2]->{$_}) : ()
			} sort keys %{$_[2]}) .'}'
 : strquot($_[0],$_[2])
}


sub dsdump {     # Data structure dump to string
 my ($s, $d) =@_;	# (data structure) -> dump string
 eval('use Data::Dumper');
 my $o =Data::Dumper->new([$d]); 
 $o->Indent(1);
 $o->Deepcopy(1);
 $o->Dump();
}


sub dsparse {  # Data structure dump string to perl structure
 my ($s, $d) =@_;	# (string) -> data structure
 eval('use Safe; 1')
 && Safe->new()->reval($d)
}


sub dscmp {	# Compare data structures
 my($s, $ds1, $ds2) =@_;
 return(1) if (defined($ds1) && !defined($ds2)) ||(defined($ds2) && !defined($ds1));
 return(0) if !defined($ds1) && !defined($ds2);
 return(1) if (ref($ds1) ||'') ne (ref($ds2) ||'');
 return($ds1 cmp $ds2) if !ref($ds1);
 return(dsquot($s,$ds1) cmp dsquot($s,$ds2)) if ref($ds1) eq 'ARRAY';
 return(dsquot($s,$ds1) cmp dsquot($s,$ds2)) if ref($ds1) eq 'HASH';
 $ds1 cmp $ds2
}


sub dsunique {	# Unique list
 my %h =(map {defined($_) ? ($_ => 1) : ()} @_[1..$#_]);
 use locale;
 sort keys %h
}



sub dsmerge {	# Merge arrays or hashes
 my $r;
 if (ref($_[1]) eq 'ARRAY') {
	$r =[];
	for (my $i=1; $i <=$#_; $i++) {
		for (my $j=0; $j <=$#{$_[$i]}; $j++) {
			$r->[$j] =$_[$i]->[$j]
		}
	}
 }
 elsif (ref($_[1]) eq 'HASH') {
	$r ={};
	for (my $i=1; $i <=$#_; $i++) {
		foreach my $k (keys %{$_[$i]}) {
			$r->{$k} =$_[$i]->{$k}
		}
	}
 }
 $r
}


sub strtime {	# Stringify Time
 my $s =shift;
 if (scalar(@_) && !defined($_[0])) {
	&{$s->{-warn}}('Not defined time in strtime()') if $^W;
	return(undef)
 }
 my $msk =(scalar(@_) ==0) || ($_[0] =~/^\d+$/i) ? 'yyyy-mm-dd hh:mm:ss' : shift;
 my @tme =(scalar(@_) ==0) ? localtime(time) : scalar(@_) ==1 ? localtime($_[0]) : @_;
 $msk =~s/yyyy/%Y/;
 $msk =~s/yy/%y/;
 $msk =~s/mm/%m/;
 $msk =~s/mm/%M/i;
 $msk =~s/dd/%d/;
 $msk =~s/hh/%H/;
 $msk =~s/hh/%h/i;
 $msk =~s/ss/%S/;
#eval('use POSIX');
 my $r =POSIX::strftime($msk, @tme);
# &{$s->{-warn}}("Not defined strtime('$msk'," .join(',', map {defined($_) ? $_ : 'undef'} @tme) .")")

lib/ARSObject.pm  view on Meta::CPAN

sub fstore {		# Store file
 my $s =shift;		# ('-b',filename, strings) -> success
 my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
 my $f =$_[0]; $f ='>' .$f if $f !~/^[<>]/;
 print "fstore('$f')\n" if $s->{-echo};
 # local $SIG{'TERM'} ='IGNORE';
 # local $SIG{'INT'}  ='IGNORE';
 # local $SIG{'BREAK'}='IGNORE';
 my $r;
 local *FILE;
 for (my $i =0; $i <$fretry; $i++) {
	$r =open(FILE, $f);
	last if $r;
 }
 return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open file','fstore',$f)))
	if !$r;
 if ($o =~/b/) {
	binmode(FILE);
	$r =defined(syswrite(FILE,$_[1]))
 }
 else {
	$r =print FILE join("\n",@_[1..$#_])
 }
 close(FILE);
 $r || &{$s->{-die}}($s->efmt('$!',undef,'Cannot write file','fstore',$f))
}


sub fload {		# Load file
 my $s =shift;		# ('-b',filename) -> content
 my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
 my($f,$f0) =($_[0],$_[0]); 
	if ($f =~/^[<>]+/)	{$f0 =$'}
	else			{$f  ='<' .$f}
 print "fload('$f')\n" if $s->{-echo};
 local *FILE;
 my $r;
 for (my $i =0; $i <$fretry; $i++) {
	$r =open(FILE, $f);
	last if $r;
 }
 return(&{$s->{-die}}($s->efmt('$!',undef,'Cannot open file','fload',$f)))
	if !$r;
 my $b =undef;
 binmode(FILE) if $o =~/b/;
 $r =read(FILE,$b,-s $f0);
 close(FILE);
 defined($r) ? $b : &{$s->{-die}}($s->efmt('$!',undef,'Cannot read file','fload',$f))
}


sub vfname {		# Name of variables file
			# (varname|-slot) -> pathname
 return($_[0]->{-vfbase}) if !$_[1];
 my $v =$_[1];	$v =~s/[\s.,:;|\/\\?*+()<>\]\["']/_/g;
 $_[0]->{-vfbase} .($v =~/^-(.+)/ ? ($1 .($_[2] ||'.var')) : ($v .($_[2] ||'.var')))
}


sub vfstore {		# Store variables file
			# (varname, {data}) -> success
			# (-slot) -> success
 my($s,$n,$d)=@_;
 $d =$s->{$n} if !$d && ($n =~/^-/);
 my $f =$s->vfname($n, '.new');
 my $r;
 if (($n =~/^-/) && exists($s->{"${n}-storable"}) ? $s->{"${n}-storable"} : $s->{-storable}) {
	for (my $i =0; ($i <$fretry) && eval("use Storable; 1"); $i++) {
		$r =Storable::store($d, $f);
		last if $r;
	}
	return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::store',$f)))
		if !$r;
 }
 else {
	$r =$s->fstore('-', $f, $s->dsdump($d));
 }
 if ($r) {
	my $rr =0;
	for (my $i =0; $i <$fretry; $i++) {
		$rr =rename($f, $s->vfname($n));
		last if $rr
	}
	return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'rename',$f,'*.var')))
		if !$rr
 }
 $r
}


sub vfload {		# Load variables file
			# (varname|-slot, ?{use default} | load default, ?renew | renew seconds) -> {data}
 my($s,$f,$d,$nn) =@_;	# -slot-calc, -slot-store
 my $k =($f =~/^-/ ? $f : undef);
 $f =$s->vfname($f);
 if ($nn && $nn >1) {
	my @st =stat($f);
	$nn =0 if $st[9] && (time() -$st[9] <$nn);
 }
 if ($d && ($nn || !-f $f)) {
	if (ref($d)) {
		$s->vfstore($k, $d =ref($d) eq 'CODE' ? &$d($s,$k) : $d);
		$s->{$k} =$d if $k;
	}
	elsif (!$k) {
	}
	elsif (ref($s->{"$k-calc"}) eq 'CODE') {
		my $cc =$s->{"$k-calc"};
		local $s->{"$k-calc"} =undef;
		$s->{$k} =$d =&$cc($s,$k);
	}
	elsif (ref($s->{"$k-store"}) eq 'CODE') {
		$s->vfstore($k, $s->{$k} =$d =&{$s->{"$k-store"}}($s,$k))
	}
	elsif (ref($s->{$k}) eq 'CODE') {
		$s->vfstore($k, $s->{$k} =$d =&{$s->{$k}}($s,$k))
	}
	return($d)
 }
 elsif (ref($s->{"$k-calc"}) eq 'CODE') {
	my $cc =$s->{"$k-calc"};
	local $s->{"$k-calc"} =undef;
	$s->{$k} =$d =&$cc($s,$k);
	return($d);
 }
 my $r;
 if (0) {
	$r =($k && exists($s->{"${k}-storable"}) ? $s->{"${k}-storable"} : $s->{-storable})
	? eval("use Storable; 1")
		&& Storable::retrieve($f)
		|| return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::retrieve',$f)))
	: ((eval{do($f)}) || return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},undef,'do',$f))));
 }
 else {
	local *FILE;
	for (my $i =0; $i <$fretry; $i++) {
		$r =open(FILE, "<$f");
		last if $r;
	}
	return(&{$s->{-die}}($s->efmt('$!',undef,'Cannot open file','vfload',$f)))
		if !$r;
	binmode(FILE);
	my $v;
	sysread(FILE,$v,64,0)
		||return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'sysread',$f)));
	$r =($v 
		? $v !~/^\$VAR1\s*=/
		: ($k && exists($s->{"${k}-storable"}) ? $s->{"${k}-storable"} : $s->{-storable}))
	? ((seek(FILE,0,0) ||1)
		&& eval("use Storable; 1")
		&& Storable::fd_retrieve(\*FILE)
		|| return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::retrieve',$f))))
	: ((eval{close(FILE); 1}) &&
		do($f) || return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},undef,'do',$f)))
		);
	eval{close(FILE)};
 }
 $s->{$k} =$r if $k;
 $r
}



sub vfrenew {		# Renew variables file
 my($s,$f,$nn) =@_;	# (-slot, ?period seconds) -> vfload
 return(1) if $f !~/^-/;
 vfload($s,$f,1,$nn ||1);
}



sub vfclear {	# Clear vfdata() and vfhash()
 my($s,$f) =@_;	# (-slot, ?period seconds) -> vfload
 return(1) if $f !~/^-/;
 delete($s->{$f});
 foreach my $k (keys %$s) {
	next if $k !~/^\Q$f\E[\/].+/;
	delete $s->{$k};
 }
 1;
}


sub vfdata {	# Access to array data from variables file
		# automatically load using vfload().
		# (-slot) -> [array]
		# (-slot, filter sub{}(self, -slot, index, $_=value)) -> [array]
 vfload($_[0], $_[1], 1) if !$_[0]->{$_[1]} || (ref($_[0]->{$_[1]}) eq 'CODE');
 if ($_[2]) {
	if (ref($_[2]) eq 'CODE') {
		local $_;
		local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
			."vfdata('$_[1]', sub{})";
		my ($rr, $v);
		if (ref($_[0]->{$_[1]}) eq 'ARRAY') {
			$rr =[];
			for(my $i=0; $i<=$#{$_[0]->{$_[1]}}; $i++) {
				if (!defined(eval{$v =&{$_[2]}($_[0], $_[1], $i, $_ =$_[0]->{$_[1]}->[$i])}) && $@) {
					last if $@ =~/^last[\r\n]*$/;
					next if $@ =~/^next[\r\n]*$/;
					return(&{$_[0]->{-die}}($_[0]->efmt($@,$_[0]->{-cmd})));
				}
				elsif ($v) {
					push @$rr, $_[0]->{$_[1]}->[$i]
				}
			}
		}
		elsif (ref($_[0]->{$_[1]}) eq 'HASH') {
			$rr ={};
			foreach my $i (keys %{$_[0]->{$_[1]}}) {
				if (!defined(eval{$v =&{$_[2]}($_[0], $_[1], $i, $_ =$_[0]->{$_[1]}->{$i})}) && $@) {
					last if $@ =~/^last[\r\n]*$/;
					next if $@ =~/^next[\r\n]*$/;
					return(&{$_[0]->{-die}}($_[0]->efmt($@,$_[0]->{-cmd})));
				}
				elsif ($v) {
					$rr->{$i} =$_[0]->{$_[1]}->{$i}
				}
			}
		}
		return($rr)
	}
	else {
		return($_[0]->{$_[1]}->[$_[2]])
	}
 }
 $_[0]->{$_[1]}
}


sub vfhash {	# Access to hash of array data from variables file
		# automatically formed in memory using vfdata().
		# (-slot, key name) -> {hash from vfdata()}
		# (-slot, key name => key value) -> {key=>value,...}
		# (-slot, key name => key value => elem name ) -> elem value
		# (-slot, key name => filter sub{}(self, -slot, key, $_ = value)) -> {key=>value,...}
 my($s, $f, $k, $v, $e) =@_;
 return(&{$s->{-die}}($s->efmt('Key name needed',undef,undef,'vfhash',$f))) if !$k;
 $s->vfload($f, 1) if !$s->{$f} ||(ref($s->{$f}) eq 'CODE');
 my $kk ="$f/$k";
 if (!$s->{$kk}) {
	$s->{$kk} ={};
	if (ref($s->{$f}) eq 'ARRAY') {
		for(my $i=0; $i<=$#{$s->{$f}}; $i++) {
			$s->{$kk}->{$s->{$f}->[$i]->{$k}} =$s->{$f}->[$i]
				if defined($s->{$f}->[$i]->{$k})
		}
	}
	else {
		foreach my $kh (keys %{$s->{$f}}) {
			$s->{$kk}->{$s->{$f}->{$kh}->{$k}} =$s->{$f}->{$kh}
				if defined($s->{$f}->{$kh}->{$k})
		}
	}
 }
 if (ref($v) eq 'CODE') {
	my ($rh, $t) =({});
	local $_;
	local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
		."vfhash('$f', '$k', sub{})";
	foreach my $ke (keys %{$s->{$kk}}) {
		if (!defined(eval{$t =&$v($s, $f, $k, $_ =$s->{$kk}->{$ke})}) && $@) {
			last if $@ =~/^last[\r\n]*$/;
			next if $@ =~/^next[\r\n]*$/;
			return(&{$s->{-die}}($s->efmt($@,$s->{-cmd})));
		}
		elsif ($t) {
			$rh->{$ke} =$s->{$kk}->{$ke};
		}
	}
	return($rh)
 }
 !defined($v) 
 ? $s->{$kk} 
 : !defined($s->{$kk})
 ? $s->{$kk}
 : !ref($s->{$kk}->{$v})
 ? $s->{$kk}->{$v}
 : defined($e)
 ? $s->{$kk}->{$v}->{$e}
 : $s->{$kk}->{$v}
}



sub vfdistinct {# Distinct values from vfdata() field.
		# (-slot, key name) -> [keys %{vfhash(...)}]
		# (-slot, key name => filter sub{}(self, -slot, key, $_ = value)) -> [keys %{vfhash(...)}]
 my($s, $f, $k, $v) =@_;
 my(%rh, $t);
 local $_;
 local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
	."vfdistinct('$f', '$k', sub{})";
 $s->vfload($f, 1) if !$s->{$f} ||(ref($s->{$f}) eq 'CODE');
 if (ref($s->{$f}) eq 'ARRAY') {
	for(my $i=0; $i<=$#{$s->{$f}}; $i++) {
		if (!defined($s->{$f}->[$i]->{$k})) {
		}
		elsif ($v && !defined(eval{$t =&$v($s, $f, $k, $_ =$s->{$f}->[$i])}) && $@) {
			last if $@ =~/^last[\r\n]*$/;
			next if $@ =~/^next[\r\n]*$/;
			return(&{$s->{-die}}($s->efmt($@,$s->{-cmd})));
		}
		elsif (!$v ||$t) {
			$rh{$s->{$f}->[$i]->{$k}} =1
		}
	}
 }
 else {
	foreach my $kh (keys %{$s->{$f}}) {
		if (!defined($s->{$f}->{$kh}->{$k})) {
		}
		elsif ($v && !defined(eval{$t =&$v($s, $f, $k, $_ =$s->{$k}->{$kh})}) && $@) {
			last if $@ =~/^last[\r\n]*$/;
			next if $@ =~/^next[\r\n]*$/;
			return(&{$s->{-die}}($s->efmt($@,$s->{-cmd})));
		}
		elsif (!$v ||$t) {
			$rh{$s->{$f}->{$kh}->{$k}} =1
		}
	}
 }
 use locale;
 return([sort {$a cmp $b} keys %rh])
}



sub connect {		# Connect to ARS server
 eval('use ARS');	# (-param=>value,...) -> self
 my $s =shift;		# -srv, -usr, -pswd, -lang
 $s->set(@_);
 $s->set(-die=>'Carp') if !$s->{-die};
 local $s->{-cmd} ="connect()";
 return($s) if $s->{-ctrl};
 print $s->cpcon("connect()\n") if $s->{-echo};
 return($s) if $s->{-ctrl} && ARS::ars_VerifyUser($s->{-ctrl});
 $s->{-ctrl} =ARS::ars_Login(
		$s->{-srv}, $s->{-usr}, $s->{-pswd}, $s->{-lang}
		, '' # , join('-', ($ENV{COMPUTERNAME} ||$ENV{HOSTNAME} ||eval('use Sys::Hostname;hostname') ||'localhost'), getlogin() || $> || '', $$, $^T, time())
		, 0, 0)
	|| return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_Login', map {$_=>$s->{$_}} qw(-srv -usr -lang))));
 $s->{-ctrl} && ARS::ars_SetSessionConfiguration($s->{-ctrl}, &ARS::AR_SESS_OVERRIDE_PREV_IP, 1);
 $s->arsmeta();
 $s
}


sub disconnect {	# Disconnect data servers
 my $s =shift;
 $s->{-ctrl} && eval{ars_Logoff($s->{-ctrl})};
 $s->{-ctrl}=undef;
 $s->{-dbi} && eval{$s->{-dbi}->disconnect()};
 $s->{-dbi} =undef;
}


sub arsmeta {		# Load/refresh ARS metadata
 my $s =shift;		# -srv, -usr, -pswd, -lang
 $s->set(@_);
 local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
	.($s->{-schgen} ? "dumper('" .$s->vfname('meta') ."')" : 'arsmeta()');
 if (ref($s->{-schgen})
 || ($s->{-schgen} && ($s->{-schgen} >1))
 || (!-e $s->vfname('-meta'))
	) {
	#
	# Data types:
	# 'integer','real','char','enum','time','decimal'
	# 'diary','attach','currency'
	# 'trim','control','table','column','page','page_holder'
	#
	my ($vfs, $vfu);
	local $s->{-schgen} =$s->{-schgen};
	if (ref($s->{-schgen}) && (-e $s->vfname('-meta'))) {
		$s->vfload('-meta');
	}
	elsif (($s->{-schgen} >1) && (-e $s->vfname('-meta'))) {
		$s->vfload('-meta');
		$vfs =$s->{-schgen} >2
			? 0
			: ([stat $s->vfname('-meta')]->[9] ||0);
	}
	else {
		$s->{-meta} ={};
	}
	foreach my $f (ref($s->{-schgen}) ? @{$s->{-schgen}} : @{$s->{-schema}}){
		my $fa =ARS::ars_GetSchema($s->{-ctrl}, $f);
		!$fa && return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetSchema',$f)));
		if ($vfs && $s->{-meta}->{$f}) {
			#print $s->strtime($fa->{timestamp}),'/',$s->strtime($vfs), "\n", $s->cpcon($s->dsdump($fa)), "\n"; exit(0);
			next	if $s->{-meta}->{$f} && $s->{-meta}->{$f}->{timestamp}
				? (($s->{-meta}->{$f}->{timestamp}||0) >=($fa->{timestamp}||0))
					&& ($vfs >=($fa->{timestamp}||0))
				: $vfs >=($fa->{timestamp}||0 +60*60);
		}
		$vfu =1;
		$s->{-meta}->{$f} ={}; # {} || $fa
		$s->{-meta}->{$f}->{-fields} ={};
		$s->{-meta}->{$f}->{timestamp} =$fa->{timestamp};
		# $s->{-meta}->{$f}->{indexList} =$fa->{indexList};
		# $s->{-meta}->{$f}->{getListFields} =$fa->{getListFields};
		# $s->{-meta}->{$f}->{sortList} =$fa->{sortList};
		my ($cyr, $vli, $vll) =1 && $s->{-lang} && ($s->{-lang} =~/^(?:ru)/i);
		if (!$cyr && $s->{-lang}) {
			my $vlc;
			my $ull =$s->{-lang} =~/^([A-Za-z]+)/  ? $1 : $s->{-lang};
			my $ulc =$s->{-lang} =~/^([A-Za-z_]+)/ ? $1 : $s->{-lang};
			my $i =0;
			foreach my $vi (ars_GetListVUI($s->{-ctrl}, $f, 0)) {
				my $vw =ars_GetVUI($s->{-ctrl}, $f, $vi);
				# language[_territory[.codeset]][@modifier]
				# en_US.ISO8859-15@euro
				$vli =$i if !defined($vli) && !$vw->{locale};
				$vlc =$i if !defined($vlc) &&  $vw->{locale} && ($vw->{locale} =~/^\Q$ulc\E/);
				$vll =$i if !defined($vll) &&  $vw->{locale} && ($vw->{locale} =~/^\Q$ull\E/);
				last if defined($vli) && defined($vlc) && defined($vll);
				$i++
			}
			$vll =$vlc if defined($vlc);
		}
		my $ix ={map {$_->{unique}
				&& (scalar(@{$_->{fieldIds}}) ==1)
				? ($_->{fieldIds}->[0] => 1)
				: ()} @{$fa->{indexList}}};
		my %ff =ARS::ars_GetFieldTable($s->{-ctrl}, $f);
		!%ff && return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetFieldTable',$f)));
		foreach my $ff (sort keys %ff) {
			my $fm =ARS::ars_GetField($s->{-ctrl},$f,$ff{$ff})
				|| return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetField',$f,$ff)));
			# 'fieldId', 'fieldName', 'dataType'
			next	if !$fm->{dataType}
				|| ($fm->{dataType} =~/^(trim|control|table|column|page)/);
			next	if !$s->{-schfdo} && $fm->{option} && ($fm->{option} == 4); # AR_FIELD_OPTION_DISPLAY
			$s->{-meta}->{$f}->{-fields}->{$ff} =$fm;
			$s->{-meta}->{$f}->{-fields}->{$ff}->{indexUnique} =$fm->{fieldId}
				if $ix->{$fm->{fieldId}}
				|| ($fm->{fieldId} eq '1'); # || '179'?
			if ($fm->{displayInstanceList}->{dInstanceList}
				) {
				# foreach my $i (defined($vli) || defined($vll) ? (map {defined($_) ? $_ : ()} $vli, $vll) : (0..$#{$fm->{displayInstanceList}->{dInstanceList}})) {
				for (my $i =0; $i <=$#{$fm->{displayInstanceList}->{dInstanceList}}; $i++) {
					next if !$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props};
					for(my $j =0; $j <=$#{$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}}; $j++) {
						my $prp =$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}->[$j]->{prop};
						if ($prp ==20) {
							# $i   == vui id
							# prop == 20 == AR_DPROP_LABEL
							my $v =$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}->[$j]->{value};
							$fm->{fieldLbl} =$v
								if 1
								&& !$fm->{fieldLbl}
								&& ((defined($vli)
								    && ($i == $vli))
								   || ($v =~/^[\s\d*\\=-]*[A-Za-z]/));
							$fm->{fieldLbll} =$v
								if 1
								&& !$fm->{fieldLbll}
								&& ((defined($vll)
								     && ($i == $vll))
								   || ($cyr && ($v !~/^[\s\d*\\=-]*[A-Za-z]/)));
							$fm->{fieldLblc} =($fm->{fieldLblc} ? $fm->{fieldLblc} .'; ' : '')
								."[$i] $v"
								if !$cyr
								&& !defined($vll)
								&& ($fm->{fieldLblc}||'') !~/\Q$v\E/;
						}
						elsif ($prp ==230) {
							# $i   == vui id
							# prop == 230 == AR_DPROP_ENUM_LABELS
							# 6\0\Proposed\1\Enabled\2\Offline\3\Obsolete\4\Archive\5\Delete
							# next if $fm->{fieldLbv} && (!$cyr ||$fm->{fieldLbvl});
							my $v =$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}->[$j]->{value};
							$v=$v =~/^\d+(\\\d+\\.+)/ ? $1 : $v;
							$fm->{fieldLbv} =$v
								if 0
								&& !$fm->{fieldLbv}
								&& ((defined($vli)
								     && ($i == $vli))
								   || ($v =~/^[\s\d*\\=-]*[A-Za-z]/));
							$fm->{fieldLbvl} =$v
								if 1
								&& !$fm->{fieldLbvl}
								&& ((defined($vll)
								     && ($i == $vll))
								   || ($cyr && ($v !~/^[\s\d*\\=-]*[A-Za-z]/)));
						}
					}
				}
			}
			if ($s->{-metax}) {
				foreach my $e (@{$s->{-metax}}) {
					delete $fm->{$e};
				}
			}
		}
	}
	if (!$s->{-schgen}) {
	}
	else {
		$vfu && $s->vfstore('-meta')
	}
	# print $s->cpcon($s->dsdump($s->{-meta})), "\n"; exit(0);
 }
 elsif (-e $s->vfname('meta')) {
	$s->vfload('-meta');
	# print $s->cpcon($s->dsdump($s->{-meta})), "\n"; exit(0);
 }
 else {
	$s->{-meta} ={};
	return(&{$s->{-die}}($s->efmt('No metadata',$s->{-cmd})))
 }
 $s->arsmetaix() if $s->{-meta};
}


sub arsmetaix {	# Index ARS metadata
 my $s =shift;
 if ($s->{-meta}) {
	foreach my $f (keys %{$s->{-meta}}){
		next if $f =~/^-/;
		$s->{-meta}->{$f}->{-fldids} ={}
			if !$s->{-meta}->{$f}->{-fldids};
		foreach my $ff (keys %{$s->{-meta}->{$f}->{-fields}}) {
			$s->{-meta}->{$f}->{-fldids}->{$s->{-meta}->{$f}->{-fields}->{$ff}->{fieldId}}
				=$s->{-meta}->{$f}->{-fields}->{$ff}
		}
	}
	if (ref($s->{-metadn})) {
		foreach my $dn (keys %{$s->{-metadn}}) {
			$s->{-metadn}->{$dn} ={fieldName=>$dn, fieldId=>$s->{-metadn}->{$dn}}
				if !ref($s->{-metadn}->{$dn});
			$s->{-metadn}->{$dn}->{fieldName} =$dn
				if !$s->{-metadn}->{$dn}->{fieldName};
			$s->{-metaid}->{$s->{-metadn}->{$dn}->{fieldId}} =$s->{-metadn}->{$dn}
				if $s->{-metadn}->{$dn}->{fieldId}
				&& !$s->{-metaid}->{$s->{-metadn}->{$dn}->{fieldId}};
		}
	}
	if (ref($s->{-metaid})) {
		foreach my $id (keys %{$s->{-metaid}}) {
			$s->{-metaid}->{$id} ={fieldId=>$id, fieldName=>$s->{-metaid}->{$id}}
				if !ref($s->{-metaid}->{$id});
			$s->{-metaid}->{$id}->{fieldId} =$id;
			$s->{-metadn}->{$s->{-metaid}->{$id}->{fieldName}} =$s->{-metaid}->{$id}
				if $s->{-metaid}->{$id}->{fieldName}
				&& !$s->{-metadn}->{$s->{-metaid}->{$id}->{fieldName}};
		}
	}
	# print $s->cpcon($s->dsdump($s->{-metaid})), "\n"; exit(0);
 }
}


sub arsmetamin {	# Minimal ARS metadata ('-meta-min' varfile)
 my $s =shift;		# 	refresh after 'arsmeta'/'connect'
 $s->set(@_);		# 	load instead of 'arsmeta'/'connect'
 local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
	.($s->{-schgen} ? "dumper('" .$s->vfname('meta-min') ."')" : 'arsmetamin()');
 if (ref($s->{-schgen})
 || !$s->{-schgen}
 || ($s->{-schgen} && ($s->{-schgen} >1))
 || (!-e $s->vfname('-meta-min'))
	) {
	$s->arsmeta() if !$s->{-meta} ||!scalar(%{$s->{-meta}});
	my $fvs =[stat $s->vfname('-meta-min')]->[9] ||0;
	$fvs =0 if ($s->{-schgen} && (ref($s->{-schgen}) || ($s->{-schgen} >2)));
	$fvs =0 if $fvs && ($fvs <([stat $s->vfname('-meta')]->[9]||0));
	$fvs =0 if $fvs && ($fvs <([stat ($^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0)]->[9]||0));
	if (!$fvs) {
		$s->{'-meta-min'} ={};
		foreach my $f (keys %{$s->{-meta}}) {
			foreach my $ff (keys %{$s->{-meta}->{$f}->{-fields}}) {
				my $e =$s->{-meta}->{$f}->{-fields}->{$ff};
				next	if (!$e->{dataType}
						|| ($e->{dataType} ne 'time'))
					&& (!$e->{'limit'}
					|| !$e->{'limit'}->{'enumLimits'}
					|| !($e->{'limit'}->{'enumLimits'}->{'regularList'} ||$e->{'limit'}->{'enumLimits'}->{'customList'}));
				$s->{'-meta-min'}->{$f} ={} if !$s->{'-meta-min'}->{$f};
				$s->{'-meta-min'}->{$f}->{-fields} ={} if !$s->{'-meta-min'}->{$f}->{-fields};
				$e ={%$e};
				delete @$e{'owner','lastChanged', 'timestamp'};
				$s->{'-meta-min'}->{$f}->{-fields}->{$ff} ={%$e};
			}
		}
		$s->vfstore('-meta-min') if $s->{-schgen} && ($s->{-schgen} eq '1' ? !-e $s->vfname('-meta-min') : 1);
	};
 };
# print do($s->vfname('-meta-min'))||0,' ', $@||'', $s->vfname('-meta-min'),' ', "\n";
 $s->vfload('-meta-min') if !$s->{'-meta-min'} && $s->{-schgen};
 if (!$s->{-meta} ||!scalar(%{$s->{-meta}})) {
	$s->{-meta} =$s->{'-meta-min'};
	$s->arsmetaix();
 }
 else {
	foreach my $f (keys %{$s->{'-meta-min'}}) {
		next if $s->{-meta}->{$f};
		my $fs =$s->{'-meta-min'}->{$f};
		$s->{-meta}->{$f} ={}
			if !$s->{-meta}->{$f};
		foreach my $ff (keys %{$fs->{-fields}}) {
			$s->{-meta}->{$f}->{-fields}->{$ff} ={}
				if !$s->{-meta}->{$f}->{-fields}->{$ff};
			eval {@{$s->{-meta}->{$f}->{-fields}->{$ff}}{keys %{$fs->{-fields}->{$ff}}}
				=values %{$fs->{-fields}->{$ff}}};
		}
	}
	$s->arsmetaix()
 }
 delete $s->{'-meta-min'};
 $s;
}


sub arsmetasql {	# SQL ARS metadata ('-meta-sql' varfile)
 my $s =shift;		# 	refresh after 'arsmeta'/'connect'
 $s->set(@_);		# !!! 'enum' texts
 local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
	.($s->{-schgen} ? "dumper('" .$s->vfname('meta-sql') ."')" : 'arsmetasql()');
 if (ref($s->{-schgen})
 || !$s->{-schgen}
 || ($s->{-schgen} && ($s->{-schgen} >1))
 || (!-e $s->vfname('-meta-sql'))
	) {
	$s->arsmeta() if !$s->{-meta} ||!scalar(%{$s->{-meta}});
	my $fvs =[stat $s->vfname('-meta-sql')]->[9] ||0;
	$fvs =0 if ($s->{-schgen} && (ref($s->{-schgen}) || ($s->{-schgen} >2)));
	$fvs =0 if $fvs && ($fvs <([stat $s->vfname('-meta')]->[9]||0));
	$fvs =0 if $fvs && ($fvs <([stat ($^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0)]->[9]||0));
	if (!$fvs) {
		$s->vfload('-meta-sql') if $s->{-schgen} && -e $s->vfname('-meta-sql');
		$s->{'-meta-sql'} ={}	if !$s->{'-meta-sql'};
		foreach my $f ($s->{-schema} ? @{$s->{-schema}} : sort keys %{$s->{-meta}}) {
			$s->sqlname($f);
			foreach my $ff (sort keys %{$s->{-meta}->{$f}->{-fields}}) {
				$s->sqlname($f,$ff,1);
				if ($s->{-meta}->{$f}->{-fields}->{$ff}->{dataType} eq 'enum') {
					# $s->sqlname($f,'_str_' .$ff,1);
					# $s->{'-meta-sql'}->{$s->sqlname($f)}->{-cols}->{$s->sqlname($f,'_str_' .$ff)}->{TYPE_NAME} ='varchar';
				}
			}
			foreach my $ff ('_arsobject_insert', '_arsobject_update', '_arsobject_delete') {
				$s->sqlname($f,$ff,1);
				$s->{'-meta-sql'}->{$s->sqlname($f)}->{-cols}->{$s->sqlname($f,$ff)}->{TYPE_NAME} ='int';
			}
		}
		$s->vfstore('-meta-sql') if $s->{-schgen} && ($s->{-schgen} eq '1' ? !-e $s->vfname('-meta-sql') : 1);
	};
 };
# print do($s->vfname('-meta-sql'))||0,' ', $@||'', $s->vfname('-meta-sql'),' ', "\n";
 $s->vfload('-meta-sql') if !$s->{'-meta-sql'} && $s->{-schgen};
 $s;
}



sub sqlnesc {	# SQL name escaping, default for '-sqlname', '-sqlntbl', '-sqlncol'
 my $v =lc($_[1]); # (self, name) -> escaped
 $v =~s/[^a-zA-Z0-9_]/_/g;
 $v =substr($v,0,64) if length($v) >64;
 $v
}


sub sqlninc {	# SQL name incrementing, default for '-sqlninc'
 my $v =$_[1];	# (self, name) -> incremented
 my ($n, $nn);
 if (0) {
	($n, $nn) =$v =~/^(.+?)_([1-9]+)$/ ? ($1, '_' .($2 +1)) : ($v, '_1');
 }
 else {
	($n, $nn) =$v =~/^(.+?)_([A-Z]+)$/ ? ($1, $2) : ($v, '');
	$nn ='_' .(!$nn ? 'A' : substr($nn,-1,1) eq 'Z' ? $nn .'A' : (substr($nn,0,-1) .chr(ord(substr($nn,-1,1)) +1)));
 }
 $v =$n .$nn;
 length($v) >64 ? substr($n, 0, 64 -length($nn)) .$nn : $v
}


sub sqlname {	# SQL name from ARS name
		# (formName, ?fieldName, ?force update meta) -> SQL name
		# -sqlname, -sqlntbl, -sqlncol, -sqlninc
 my($s,$f,$ff,$fu) =@_;	
 return(undef)
	if !$f;
 return($s->{'-meta-sql'}->{-forms}->{$f})
	if !$ff && !$fu
	&& $s->{'-meta-sql'}
	&& $s->{'-meta-sql'}->{-forms} 
	&& $s->{'-meta-sql'}->{-forms}->{$f};
 return($s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-fields}->{$ff})
	if $ff && !$fu
	&& $s->{'-meta-sql'}
	&& $s->{'-meta-sql'}->{-forms}
	&& $s->{'-meta-sql'}->{-forms}->{$f} 
	&& $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-fields}
	&& $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-fields}->{$ff};
 my $ffh =$ff && $s->{-meta} && $s->{-meta}->{$f} && $s->{-meta}->{$f}->{-fields} && $s->{-meta}->{$f}->{-fields}->{$ff};
 return($s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-fields}->{$s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-ids}->{$ffh->{fieldId}}})
	if $ff && !$fu && $ffh && $ffh->{fieldId}
	&& $s->{'-meta-sql'}
	&& $s->{'-meta-sql'}->{-forms}
	&& $s->{'-meta-sql'}->{-forms}->{$f} 
	&& $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-ids}
	&& $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$f}}->{-ids}->{$ffh->{fieldId}};	
 my $tn =!$f
	? $f
	: $s->{-sqlntbl}
	? &{$s->{-sqlntbl}($s, $f)}
	: $s->{-sqlname}
	? &{$s->{-sqlname}($s, $f)}
	: sqlnesc($s, $f);
 return($tn) if !$f ||!$tn;
 $s->{'-meta-sql'} ={} if !$s->{'-meta-sql'};
 $s->{'-meta-sql'}->{-forms} ={} if !$s->{'-meta-sql'}->{-forms};
 while ($s->{'-meta-sql'}->{$tn} && ($s->{'-meta-sql'}->{$tn}->{formName} ne $f)) {
	$tn =$s->{-sqlninc} ? &{$s->{-sqlninc}}($s, $tn) : sqlninc($s, $tn);
 }
 if (!$s->{'-meta-sql'}->{$tn}) {
	$s->{'-meta-sql'}->{$tn} ={formName=>$f, -cols=>{}, -fields=>{}, -ids=>{}, timestamp=>time()};
	$s->{'-meta-sql'}->{-forms}->{$f} =$tn;
 }
 elsif ($fu) {
	$s->{'-meta-sql'}->{$tn}->{formName} =$f;
	$s->{'-meta-sql'}->{-forms}->{$f} =$tn;
 }
 return($tn) if !$ff;
 my $tc =!$ff
	? $ff
	: $ffh && $ffh->{fieldId} 
		&& $s->{'-meta-sql'}->{$tn}
		&& $s->{'-meta-sql'}->{$tn}->{-ids} && $s->{'-meta-sql'}->{$tn}->{-ids}->{$ffh->{fieldId}}
	? $s->{'-meta-sql'}->{$tn}->{-ids}->{$ffh->{fieldId}}
	: $s->{-sqlncol}
	? &{$s->{-sqlncol}($s, $ff)}
	: $s->{-sqlname}
	? &{$s->{-sqlname}($s, $ff)}
	: sqlnesc($s, $ff);
 return($tc) if !$tc;
 while ($s->{'-meta-sql'}->{$tn}->{-cols}->{$tc} && ($s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}->{fieldName} ne $ff)) {
	$tc =$s->{-sqlninc} ? &{$s->{-sqlninc}}($s, $tc) : sqlninc($s, $tc);
 }
 if ($fu ||!$s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}) {
	my $flh =$s->{-meta}->{$f}->{-fields}->{$ff}->{limit};
	my $tch ={COLUMN_NAME => $tc
		, 'fieldName'=>$ff
		, 'dataType' => $ffh->{dataType}
		, 'timestamp'=>$s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}
				&& $s->{'-meta-sql'}->{$tn}->{-cols}->{$tc}->{'timestamp'}
				|| time()
		, $ffh && $ffh->{fieldId}
		? ('fieldId' => $ffh->{fieldId})
		: ()
		, !$ffh ||!$ffh->{dataType}
		? ()
		: $ffh->{dataType} eq 'integer'
		? (TYPE_NAME => 'int')
		: $ffh->{dataType} eq 'real'
		? (TYPE_NAME => 'float')
		: $ffh->{dataType} eq 'decimal'
		? (TYPE_NAME => $ffh->{dataType}
			, $flh
			? ($flh->{precision} ? (DECIMAL_DIGITS => $flh->{precision}) : ()
			  ,$flh->{rangeHigh} ? (COLUMN_SIZE => length($flh->{rangeHigh})) : ()
				)
			: ()
			)
		: $ffh->{dataType} eq 'char'
			&& (!$flh || !$flh->{maxLength} || ($flh->{maxLength} >255))
		? (TYPE_NAME => 'text')
		: 0 && ($ffh->{dataType} eq 'char') &&  $ffh->{indexUnique}
		? (TYPE_NAME => 'char'
			, $flh && $flh->{maxLength} 
			? (COLUMN_SIZE => $flh->{maxLength})
			: ()
			)
		: $ffh->{dataType} eq 'char'
		? (TYPE_NAME=>'varchar' # $ffh->{dataType}
			, $flh && $flh->{maxLength} 
			? (COLUMN_SIZE => $flh->{maxLength})
			: ()
			)
		: $ffh->{dataType} eq 'diary'
		? (TYPE_NAME => 'text')
		: $ffh->{dataType} eq 'time'
		? (TYPE_NAME => 'datetime'	# !'int'
			#,COLUMN_SIZE=>19,DECIMAL_DIGITS=>0
			)
		: $ffh->{dataType} eq 'enum'
		? (TYPE_NAME => 'int')
		: ()
		, $ffh && $ffh->{fieldId}
			&& (($ffh->{fieldId} =~/^(?:1)$/) || $ffh->{indexUnique})
		? (IS_PK => $ffh->{fieldId})
		: ()
		, $ffh && $ffh->{fieldMap} 
			&& $ffh->{fieldMap}->{fieldType}
			&& ($ffh->{fieldMap}->{fieldType} ==2)
			&& $ffh->{fieldMap}->{join} 
			&& (($ffh->{fieldMap}->{join}->{schemaIndex}||0) !=0)
		? (IS_JOINED => ($ffh->{fieldMap}->{join}->{realId} || 1))
		: ()
		, !$ffh ||!$ffh->{option}
		? ()
		: $ffh->{option} ==1
		? ()
		: $ffh->{option} ==2
		? (NULLABLE => 1)
		: $ffh->{option} ==4
		? (DISPLAY_ONLY => 1)
		: ()
		, $ffh && $ffh->{fieldId} && ($ffh->{fieldId} ==6)
		? (IS_TIMESTAMP => 1)
		: ()
		};
	$s->{'-meta-sql'}->{$tn}->{-cols}->{$tc} =$tch;
	$s->{'-meta-sql'}->{$tn}->{-fields}->{$ff} =$tc;
	$s->{'-meta-sql'}->{$tn}->{-ids}->{$ffh->{fieldId}} =$tc
		if $ffh->{fieldId};
 }
 $tc
}


sub ars_errstr {# Last ARS error
	$ARS::ars_errstr
}



sub schema {	# Schema by form name
		# (schema) -> {schema descr}
		# () -> {schemaName=>{descr}}
 $_[1]
 ? $_[0]->{-meta}->{ref($_[1]) ? $_[1]->{schemaName} : $_[1]}
 : $_[0]->{-meta};
}


sub schfld {	# Schema of field
		# (schema, field) -> {field descr}
		# ({schemaName=>name, fieldName=>name}) -> {field descr}
		# (schema) -> {field=>descr}
 ref($_[1])
 ? $_[0]->{-meta}->{$_[1]->{schemaName}}->{-fields}->{$_[1]->{fieldName}}
 : $_[2]
 ? $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}
 : $_[0]->{-meta}->{$_[1]}->{-fields}
}


sub schid {	# Schema info by field id
		# (schema, fieldId) -> {fieldName=>'name', FieldId=>id}
		# () -> rearranged self
 $_[0]->{-metaid}->{$_[2]}
 || $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}
 || &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schid',$_[1],$_[2]))
}


sub schdn {	# Schema info by field distiguished name
		# (schema, fieldName) -> {fieldName=>'name', FieldId=>id}
 (($_[2] =~/^\d+$/)
	&& ($_[0]->{-metaid}->{$_[2]} 
		|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}))
 || $_[0]->{-metadn}->{$_[2]}
 || $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}
 || &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schdn',$_[1],$_[2]))
}


sub schdi {	# Schema info by field Id
		# (schema, fieldId) -> {fieldName=>'name', FieldId=>id} || undef
 $_[0]->{-metaid}->{$_[2]}
 || $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}
}


sub schlbls {	# Enum field {values => labels}
		# (schema, fieldId) -> {value=>label,...}
 my($s,$f,$ff) =@_;
 $ff =ref($ff) ? $ff
	: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
	: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
	: $s->{-meta}->{$f}->{-fields}->{$ff}; 
 if ($ff && !$ff->{-hashOut} && ($ff->{dataType} eq 'enum')) {
	my $et =ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'
		? $ff->{'limit'}->{'enumLimits'}
		: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}
		? $ff->{'limit'}->{'enumLimits'}->{'regularList'}
		: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}
		? $ff->{'limit'}->{'enumLimits'}->{'customList'}
		: undef;
	if (!$et) {}
	elsif (!ref($et->[0])) {
		$ff->{-hashOut} ={map {($_ => $et->[$_])} (0..$#$et)}
	}
	elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
		$ff->{-hashOut} ={map {($et->[$_]->{itemNumber} => $et->[$_]->{itemName})} (0..$#$et)}
	}
 }
 $ff && $ff->{-hashOut}
}



sub schlblsl {	# Enum field {values => labels localised}
		# (schema, fieldId) -> {value=>localised label,...}
 my($s,$f,$ff) =@_;
 $ff =ref($ff) ? $ff
	: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
	: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
	: $s->{-meta}->{$f}->{-fields}->{$ff};
 $ff->{fieldLbvl} ? {split /\\+/, substr($ff->{fieldLbvl},1)} : schlbls($s,$f,$ff)
}



sub schvals {	# Enum field [values]
		# (schema, fieldId) -> [value,...]
 my($s,$f,$ff) =@_;
 $ff =ref($ff) ? $ff
	: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
	: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
	: $s->{-meta}->{$f}->{-fields}->{$ff}; 
 if ($ff && !$ff->{-listVals} && ($ff->{dataType} eq 'enum')) {
	my $et =ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'
		? $ff->{'limit'}->{'enumLimits'}
		: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}
		? $ff->{'limit'}->{'enumLimits'}->{'regularList'}
		: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}
		? $ff->{'limit'}->{'enumLimits'}->{'customList'}
		: undef;
	if (!$et) {}
	elsif (!ref($et->[0])) {
		$ff->{-listVals} =[0..$#$et]
	}
	elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
		$ff->{-listVals} =[map {$et->[$_]->{itemNumber}} (0..$#$et)]
	}
 }
 $ff && $ff->{-listVals}
}



sub strOut {	# Convert field value for output, using '-meta'
		# (schema, fieldId, fieldValue) -> fieldValue
 my($s,$f,$ff,$v) =@_;
 $ff =ref($ff) ? $ff : $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff} : $s->{-meta}->{$f}->{-fields}->{$ff}; 
 if (!defined($v) ||!$ff ||!$s->{-strFields}) {
 }
 elsif ($ff->{fieldLbvl} && ($s->{-strFields} ==2) && ($ff->{fieldLbvl} =~/\\\Q$v\E\\([^\\]+)/)) {
	$v =$1
 }
 elsif ($ff->{-hashOut}) {
	if (exists($ff->{-hashOut}->{$v})) {
		$v =$ff->{-hashOut}->{$v}
	}
	else {
		# return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strOut',$f,$ff->{fieldName},$v)))
	}
 }
 elsif ($ff->{dataType} eq 'enum') {
	schlbls(@_);
	$v =strOut(@_) if $ff->{-hashOut};
 }
 elsif ($ff->{dataType} eq 'time') {
	$v =strtime($s,$v)
 }
 $v
}


sub strIn {	# Convert input field value to internal, using '-meta'
		# (schema, fieldId, fieldValue) -> fieldValue
 my($s,$f,$ff,$v) =@_;
 $ff =ref($ff) ? $ff : $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff} : $s->{-meta}->{$f}->{-fields}->{$ff};
 if (!defined($v) ||!$ff ||!$s->{-strFields}) {
 }
 elsif ($v =~/^\d+$/) {
 }
 elsif ($ff->{fieldLbvl} && ($ff->{fieldLbvl} =~/\\(\d+)\\\Q$v\E(?:\\|$)/)) {
	# && ($s->{-strFields} ==2)
	$v =$1
 }
 elsif ($ff->{-hashIn}) {
	if (exists($ff->{-hashIn}->{$v})) {
		$v =$ff->{-hashIn}->{$v};
	}
	else {
		return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strIn',$f,$ff->{fieldName},$v)))
	}
 }
 elsif ($ff->{dataType} eq 'enum') {
	my $et =  ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'
		? $ff->{'limit'}->{'enumLimits'}
		: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}
		? $ff->{'limit'}->{'enumLimits'}->{'regularList'}
		: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}
		? $ff->{'limit'}->{'enumLimits'}->{'customList'}
		: undef;
	if (!$et) {}
	elsif (!ref($et->[0])) {
		$ff->{-hashIn} ={map {($et->[$_] => $_)} (0..$#$et)};
		$v =strIn(@_);
	}
	elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
		$ff->{-hashIn} ={map {($et->[$_]->{itemName} => $et->[$_]->{itemNumber})} (0..$#$et)};
		$v =strIn(@_);
	}
	else {
		$et =undef
	}
	return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strIn',$f,$ff->{fieldName},$v)))
		if $et && ($v !~/^\d+$/);
 }
 elsif ($ff->{dataType} eq 'time') {
	$v =timestr($s,$v);
 }
 $v
}


sub lsflds {	# List fields from '-meta'
		# (additional field options)
 my ($s, @a) =@_;
 @a =('fieldLblc') if !@a;
 unshift @a, 'fieldName', 'fieldId', 'dataType', 'option', 'createMode';
 map {	my $f =$_;
	$f =~/^-/
	? ()
	: map {	my $ff =$s->{-meta}->{$f}->{-fields}->{$_};
		join("\t", $f
			#, $ff->{option} && ($ff->{option} == 4) ? 'ro' : ()
			, (map {  $_ eq 'fieldLblc'
				? join('; '
					, map {$ff->{$_} ? $ff->{$_} : ()
						} $ff->{$_} ? ('fieldLblc') : ('fieldLbl', 'fieldLbll'), 'fieldLbv', 'fieldLbvl', 'helpText')
				: !defined($ff->{$_})
				? ''
				: $_ eq 'option'
				? (!$ff->{$_} ? '' : $ff->{$_} == 4 ? 'r' : $ff->{$_} == 2 ? 'o' : $ff->{$_} == 1 ? 'm' : '')
				: $ff->{$_}
				} @a[0..$#a]))
		} sort keys %{$s->{-meta}->{$f}->{-fields}}
	} sort keys %{$s->{-meta}}
}


sub query {	# ars_GetListEntry / ars_LoadQualifier
 #		(-clause=>val) -> list
 #		(...-for=>sub{}) -> self
 #		Field Ids translated using -metadn/-metaid
 # -from ||-form ||-schema => schema name
 # -where || -query ||-qual => search condition
 #		Syntax:
 #		'fieldId' || 'fieldName' - fields
 #		"string value" - strings
 #		digits - numeric value, number of seconds as date value
 #		strIn(form, fieldName, value) - to encode value for '-where'
 #
 # -fields => [{fieldId=>1, columnWidth=>9, separator=>"\t"},...
 #		,[{fieldName=>name, width=>9},...
 #		,[{field=>name|id, width=>9},...] # 128 bytes limit strings
 # ||-fields => [fieldId | fieldName,...]	# using ars_GetListEntryWithFields()
 # ||-fields => '*' | 1 | '*-$', -xfields=>sub{} || [fieldName| fieldId,...]
 # ||-fetch => '*' | 1 | [fieldId|fieldName,...] # using ars_GetEntry() for each record
 # -order ||-sort => [fieldId, (1||2),...] # 1 - asc, 2 - desc
 #			[..., fieldName, field=>'desc', field=>'asc',...]
 # -limit ||-max => maxRetrieve
 # -first ||-start => firstRetrieve
 # -for ||-foreach => sub(self, form, id|string, ?{record}){die "last\n", die "next\n"} -> self
 # ?-echo=>1
 #
 # ars_GetListEntry(ctrl, schema, qualifier, maxRetrieve=0, firstRetrieve=0,...)
 #		..., getListFields, sortList,... 
 # ars_LoadQualifier(ctrl, schema, qualifier string)
 #
 # Using the advanced search bar:
 # 'Currency Field.VALUE'	'Currency Field' = $NULL$
 # ??? BookValue=> {conversionDate=> 1090544110, currencyCode=> 'USD', funcList=> [{currencyCode=> 'USD', value=> '0.00'}, {currencyCode=> 'EUR', value=> ''}, {currencyCode=> 'GBP', value=> ''}, {currencyCode=> 'JPY', value=> ''}, {currencyCode=> 'CA...
 # 'Status History.Fixed.TIME' < "07/01/99"
 # 'Create date' > "10:00:00"
 #
 my $s =shift;
 my %a =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-from};
 my $c =$a{-for} ||$a{-foreach};

 if ($a{-fields} && !ref($a{-fields})) {
	my $q ='trim|control|table|column|page';
	$q .= '|currency|attach' if $a{-fields} =~/^-\$/;
	$q .= '|attach'		 if $a{-fields} =~/^-f/;
	$a{-fields} = 
		[map {  my $ff =$s->{-meta}->{$f}->{-fields}->{$_};
			!$ff->{dataType} || !$ff->{fieldId}
			|| ($ff->{dataType} =~/^($q)/)
			|| ($ff->{fieldId} eq '15')	# 'Status-History' 
							# ars_GetListEntryWithFields() -> [ERROR] (ORA-00904: "C15": invalid identifier) (ARERR #552)
			|| (!$a{-xfields} ? 0 : ref($a{-xfields}) eq 'CODE' ? &{$a{-xfields}}($s, $ff) :  grep {($_ eq $ff->{fieldId}) || ($_ eq $ff->{fieldName})} @{$a{-xfields}})
			? ()
			: ($ff->{fieldId})
			} sort keys %{$s->{-meta}->{$f}->{-fields}}]
 }

 $a{-fetch} =1	if $a{-fields} && !ref($a{-fields});
 delete $a{-fields}	if $a{-fetch};

 local $s->{-cmd} ="query(" .join(', ',map {!defined($a{$_}) ? () : ref($a{$_}) ? "$_=>" .dsquot($s,$a{$_}) : ("$_=>" .strquot($s,$a{$_}))
		} qw(-schema -form -from -fields -fetch -qual -query -where -sort -order -limit -max -maxRetrieve -first -start))
		.")";

 my $fl = ref($a{-fetch})
	? [map {/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}} @{$a{-fetch}}]
	: $a{-fields} && ref($a{-fields}->[0])
	? [map {ref($_)
			? {fieldId=>$_->{fieldId} ||schdn($s,$f, $_->{fieldName} ||$_->{field})->{fieldId}
				, separator=>$_->{separator} ||"\t"
				, columnWidth=>$_->{columnWidth} ||$_->{width} ||10
				}
			: {fieldId=>/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}
				, separator=>"\t"
				, columnWidth=>10
				}
			} @{$a{-fields}}]
	: $a{-fields}
	? [map {/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}} @{$a{-fields}}]
	: [];
 my @fs;
	{my ($v, $x, @r) =($a{-sort} ||$a{-order});
	@fs =	$v
		? (map {if (!$x) {$x =$_; @r=()}
			elsif(/^(desc|2)$/) {@r =($x=~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 2); $x =undef}
			else {@r=($x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId},1); $x=undef if /^(asc|1)$/}
			@r} @$v)
		: ();
	push @fs, $x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 1
		if $x}
 my $q =$s->_qsubst('',$a{-qual} ||$a{-query} ||$a{-where}, $f);
 $s->{-cmd} .=": subst(-from=>'$f'"
		.(@$fl ? ',-fields=>' .join(', ', map {ref($_) ? "'" .$_->{fieldId} ."'(" .$_->{columnWidth} .")" : "'$_'"
			} @$fl) : '')
		.($q ? ",-where=>$q" : '')
		.(@fs ? ',-order=>' .join(', ', map {"'$_'"} @fs) : '')
		.")" 
		if 0;
 $q =ARS::ars_LoadQualifier($s->{-ctrl}, $f, $q);
 return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd})))
	if !$q;
 $s->{-cmd} .=": qual". $s->dsquot(ARS::ars_perl_qualifier($s->{-ctrl}, $q))
	if 0;

 print $s->cpcon(join(";\n", split /\):\s/, $s->{-cmd})), "\n"
	if exists($a{-echo}) ? $a{-echo} : $s->{-echo};

 if ($c && $a{-fields} && !ref($a{-fields}->[0])) {
	my $id;

lib/ARSObject.pm  view on Meta::CPAN

sub entryUpd {	# ars_SetEntry(ctrl,schema,entry_id,getTime,...)
		# (-form=>form, -id=>entryId, field=>value) -> id
		# ?-echo=>1
 #
 # ??? ARMergeEntry()/ars_MergeEntry(ctrl, schema, mergeType, ...)
 # ??? ars_EncodeDiary(diaryEntryHash1, ... diaryEntryHashN)
 #
 my ($s, %a) =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-into};
 my $id=$a{-id};
 print $s->cpcon("entryUpd(-form=>'$f',-id=>'$id')\n")
	if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
 delete @a{qw(-schema -form -from -into -id -echo)};
 local $_;
 local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') 
	."entryUpd(-form=>'$f',-id=>'$id',"
	.join(',', map {!defined($a{$_}) 
			? "$_=>undef"
			: ref($a{$_})
			? ("$_=>" .dsquot($s, $a{$_}))
			: ("$_=>" .strquot($s, $a{$_}))
			} sort keys %a)
	.')';
 %a = map {	my ($k, $v) =($_, $a{$_});
		if ($k !~/^\d+$/) {
			my $ff =schdn($s,$f,$k);
			$k =$ff->{fieldId};
			$v =$ff->{strIn}
			   ? &{$ff->{strIn}}($s,$f,$ff,$_=$v)
			   : strIn($s,$f,$k,$v)
				if $s->{-strFields}
		}
		($k => $v)
		} keys %a;
 my $r =ARS::ars_SetEntry($s->{-ctrl}, $f, $id, 0, %a);
 return(&{$s->{-die}}($s->efmt($ARS::ars_errstr, $s->{-cmd})))
	if !$r && $ARS::ars_errstr;
 $id
}


sub entryDel {	# ars_DeleteEntry
		# (-form=>form, -id=>entryId) -> id
		# ?-echo=>1
 my ($s, %a) =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-from} ||$a{-into};
 my $id=$a{-id};
 print $s->cpcon("entryDel(-form=>'$f',-id=>'$id')\n")
	if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
 delete @a{qw(-schema -form -from -into -id -echo)};
 my $r =ARS::ars_DeleteEntry($s->{-ctrl}, $f, $id);
 return(&{$s->{-die}}($s->efmt($ARS::ars_errstr
		,"entryDel(-form=>'$f',-id=>'$id')")))
	 if !$r && $ARS::ars_errstr;
 $id
}


sub entryBLOB {	# BLOB field retrieve/update
		# (-form=>form, -id=>entryId, -field=>fieldId|fieldName
		# ,?-set=>data
		# ,?-file=>filePath, ?-set=>boolean
 my ($s, %a) =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-from} ||$a{-into};
 my $eu =!$a{-file} ? exists($a{-set}) : exists($a{-set}) ? $a{-set} : $a{-into};
 if ($eu) {
	return($s->entryUpd(-form=>$f, -id=>$a{-id}
		, exists($a{-echo}) ? (-echo=>$a{-echo}) : ()
		, $a{-field}
		, {$a{-file}
			? ('file'=>$a{-file}, 'size'=> -s $a{-file})
			: ('buffer'=>$a{-set}, 'size'=> length($a{-set}))
			}))
 }
 else {
	my $r =ARS::ars_GetEntryBLOB($s->{-ctrl}, $f, $a{-id}
		,$a{-field} =~/^\d+$/ ? $a{-field} : schdn($s,$f,$a{-field})->{fieldId}
		,$a{-file} ? (ARS::AR_LOC_FILENAME(), $a{-file}) : (ARS::AR_LOC_BUFFER()));
	return(&{$s->{-die}}($s->efmt($ARS::ars_errstr
		,"entryBLOB(-form=>'$f',-id=>'" .$a{-id} ."',-field=>" .$a{-field} ."')")))
		if !defined($r) && $ARS::ars_errstr;
	return(!$a{-file} ? $r : $r ? $a{-id} : $r)
 }
}


sub dbi {	# DBI connection object
 return($_[0]->{-dbi}) if $_[0]->{-dbi};
 dbiconnect(@_)
}


sub dbiconnect {# DBI connect to any database
		# (-dbiconnect=>[]) -> dbi object
 set(@_);
 set($_[0],-die=>'Carp') if !$_[0]->{-die};
 print $_[0]->cpcon("dbiconnect()\n")
	if $_[0]->{-echo};
 eval('use DBI; 1') ||return(&{$_[0]->{-die}}($_[0]->efmt('No DBI')));
 $_[0]->{-dbi} =DBI->connect(ref($_[0]->{-dbiconnect}) ? @{$_[0]->{-dbiconnect}} : $_[0]->{-dbiconnect})
	|| &{$_[0]->{-die}}($_[0]->efmt(DBI->errstr,undef,undef,'dbiconnect') ."\n");
}


sub dbiquery {	# DBI query
		# (dbi query args) -> dbi cursor object
		# (-echo=>1,...)
 my($s, @q) =@_;
 my(%a); while ($#q && ($q[0] =~/^-/)) {$a{$q[0]} =$q[1]; shift @q; shift @q};
 print $s->cpcon("dbiquery($q[0])\n")
	if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
 my $op =$s->{-dbi}->prepare(@q)
	|| return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbiprepair',@q)));
 $op->execute()
	|| return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbiexecute',@q)));
 $op;
}


sub dbido {	# DBI do
		# (dbi do args) -> dbi cursor object
		# (-echo=>1,...)
 my($s, @q) =@_;
 my(%a); while ($#q && ($q[0] =~/^-/)) {$a{$q[0]} =$q[1]; shift @q; shift @q};
 print $s->cpcon("dbiquery($q[0])\n")
	if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
 $s->{-dbi}->do(@q)
	|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'dbido',@q));
}


sub dbierrstr {	# Last DBI error
 $_[0]->{-dbi}->errstr
}


sub dbitables {	# DBI tables array
 my ($s, $sch, $tbl) =@_;
 my @t =$s->dbi()->tables('',$sch||$s->{-sqlschema}||'', $tbl||'%');
 if (!scalar(@t) 
 && (((ref($s->{-dbiconnect}) ? $s->{-dbiconnect}->[0] : $s->{-dbiconnect})||'') =~/^dbi:ADO:/i)) {
	$sch =$sch||$s->{-sqlschema};
	@t =$sch
		? (map {$_ =~/\."*\Q$sch\E"*\./i ? ($_) : ()} $s->dbi()->tables())
		: $s->dbi()->tables();
 }
 @t
}


sub dbicols {	# DBI table columns
 my ($s, $sch, $tbl) =@_;
 # my $st =$s->dbiquery('SHOW COLUMNS FROM ' .($sch ? $sch .'.' : '') .$tbl);
 my $st =$s->dbi()->column_info('',$sch||$s->{-sqlschema}||'', $tbl||'','%');
 @{$st->fetchall_arrayref({})}
}


sub dbitypespc { # DBI column type spec
 my ($s, $d) =@_;
 ($d->{'TYPE_NAME'} ||'unknown')
 .($d->{'COLUMN_SIZE'}
	? ' (' .join(',', map {defined($d->{$_}) ? $d->{$_} : ()
		} 'COLUMN_SIZE', 'DECIMAL_DIGITS') .')'
	: '')

}

sub dbidsmetasync {	# DBI datastore - sync meta with 'arsmetasql'
 my ($s, %arg) =@_;	# (-echo)
 return(undef) if !$s->{'-meta-sql'};
 my $dbt ={map {!$_
		? ()
		: $_ =~/\."*([^."]+)"*$/
		? (lc($1) => 1)
		: (lc($_) => 1)
	} $s->dbitables()};
 foreach my $tbl (sort keys %{$s->{'-meta-sql'}}) {
	my @sql;
	if ($tbl =~/^-/) {
		next
	}
	elsif (!$dbt->{$tbl}) {
		push @sql, 'CREATE TABLE ' .join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)
			." (\n"
			.join("\n, "
				, map {	$s->{'-meta-sql'}->{$tbl}->{-cols}->{$_}->{'TYPE_NAME'}
					? '"' .$_ .'" ' .$s->dbitypespc($s->{'-meta-sql'}->{$tbl}->{-cols}->{$_})
					.(($s->{'-meta-sql'}->{$tbl}->{-cols}->{$_}->{fieldId}||'') eq '1'
						? " PRIMARY KEY"
						: $s->{'-meta-sql'}->{$tbl}->{-cols}->{$_}->{IS_PK}
						? " UNIQUE"
						: '')
					: ()
					} sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}})
			.')'
	}
	else {
		my $dbc ={map {	
			!$_ ||!$_->{COLUMN_NAME}
			? ()
			: (lc($_->{COLUMN_NAME}) => $_)
			} $s->dbicols('',$tbl)};
		if (scalar(%$dbc)) {
		my (@altc, @addc);
		foreach my $col (sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}}) {
			my $cl =lc($col);
			my $cm =$s->{'-meta-sql'}->{$tbl}->{-cols}->{$col};
			next if !$cm->{'TYPE_NAME'};
			if (!$dbc->{$cl}) {
				push @addc, '"' .$col .'" ' .$s->dbitypespc($cm)
			}
			elsif (($dbc->{$cl}->{'TYPE_NAME'} ne $cm->{'TYPE_NAME'})
				|| ($cm->{'TYPE_NAME'} ne 'datetime'
					? (($dbc->{$cl}->{'COLUMN_SIZE'}||0) < ($cm->{'COLUMN_SIZE'}||0))
					|| (($dbc->{$cl}->{'DECIMAL_DIGITS'}||0) ne ($cm->{'DECIMAL_DIGITS'}||0))
					: 0 )
				) {
				push @altc, '"' .$col .'" ' .$s->dbitypespc($cm)
			}
			else {
				$cm->{COLUMN_SIZE_DB} =$dbc->{$cl}->{'COLUMN_SIZE'}
					if ($cm->{COLUMN_SIZE_DB}||0) ne ($dbc->{$cl}->{'COLUMN_SIZE'}||0);
				$cm->{DECIMAL_DIGITS_DB} =$dbc->{$cl}->{'DECIMAL_DIGITS'}
					if ($cm->{DECIMAL_DIGITS_DB}||0) ne ($dbc->{$cl}->{'DECIMAL_DIGITS'}||0);
			}
		}
		foreach my $r (@addc) {
			push @sql
				,'ALTER TABLE '
				.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)
				.' ADD ' .$r;
		}
		foreach my $r (@altc) {
			push @sql
				,'ALTER TABLE '
				.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)
				.' ALTER COLUMN ' .$r;
		}
		}
	}
	foreach my $r (@sql) {
		print "$r;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
		$s->dbi()->do($r)
		|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$r,undef,'dbidsmetasync'));
	}
 }
 $s;
}


sub dbidsrpl {	# DBI datastore - load data from ARS
 my ($s, %arg) =@_;
 $arg{-form}  =$arg{-from}  ||$arg{-schema}	if !$arg{-form};
 $arg{-query} =$arg{-where} ||$arg{-qual}	if !$arg{-query};
 $arg{-filter}=undef				if !$arg{-filter};
 $arg{-lim_rf}=300				if !$arg{-lim_rf};
 $arg{-lim_or}=40				if !$arg{-lim_or};
 $arg{-fields}='*'				if !$arg{-fields};
 # $arg{-echo}=0;
 # $arg{-ckpush}=1;	# check db pushes into ARS (_arsobject_insert, _arsobject_update, _arsobject_delete)
 # $arg{-ckdel}=0;	# check ARS deletes into db
 # $arg{-ckupd}=1;	# check ARS updates into db
 # $arg{-sleep}=0;
 # $arg{-pk}=undef;
 # $arg{-timestamp}=undef;	# field name || 0
 # $arg{-unused}=undef;
 # $arg{-master}
 # $arg{-master_pk}
 # $arg{-master_fk}
 # $arg{-master_ts}
 my $tbl =$s->sqlname($arg{-form});
 my $tbc =join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl);
 my ($fpk, $fid, $fts, @flds);
 my ($ci, $cu, $cd) =(0, 0, 0);
 {      my $flds =$s->{'-meta-sql'}->{$tbl}->{-cols};
	$fpk = $flds->{$arg{-pk}} if $arg{-pk};
	$fts = $flds->{$arg{-timestamp}} if $arg{-timestamp};
	foreach my $fn (sort keys %$flds) {
		next 	if !$flds->{$fn}->{fieldName} || !$flds->{$fn}->{COLUMN_NAME}
			|| !$flds->{$fn}->{TYPE_NAME};
		$fpk =$flds->{$fn}	if !$fpk && $flds->{$fn}->{IS_PK} 
					&& ($flds->{$fn}->{IS_PK} eq '1');
		$fid =$flds->{$fn}	if !$fid && $flds->{$fn}->{IS_PK} 
					&& ($flds->{$fn}->{IS_PK} eq '1');
		$fts =$flds->{$fn}	if !$fts && $flds->{$fn}->{IS_TIMESTAMP};
		push @flds, $flds->{$fn};
	}
	!$fpk && &{$s->{-die}}($s->efmt('PK not found','',undef,'dbidsrpl',$arg{-form}));
	$fts =undef if defined($arg{-timestamp}) && !$arg{-timestamp};
	# !$fts && &{$s->{-die}}($s->efmt('Timestamp not found','',undef,'dbidsrpl',$arg{-form}));
 }
 $s->dbi() if !$s->{-dbi};
 local $s->{-dbi}->{LongReadLen} =$s->{-dbi}->{LongReadLen} <= 1024 ? 4*64*1024 : $s->{-dbi}->{LongReadLen};
 my $vts =$fts && $s->dbiquery('SELECT max(' .$fts->{COLUMN_NAME} .') FROM ' .$tbc)->fetchrow_arrayref();
    $vts =$vts && $vts->[0];
 my $cts =0;
 if ($vts) {
	my $sql ='SELECT count(*) FROM ' .$tbc .' WHERE ' .$s->{-dbi}->quote_identifier($fts->{COLUMN_NAME}) .'=' .$s->{-dbi}->quote($vts);
	$cts =$s->dbiquery($sql)->fetchrow_arrayref();
	$cts =$cts && $cts->[0] ||0;
	print "$sql --> $cts;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
	if (!$cts) {
	}
	elsif (0 && ($cts > $arg{-lim_rf})) {
		$cts -=1;
	}
	elsif ($cts >= $arg{-lim_rf} *2) {
		$cts -=$arg{-lim_rf};
		$arg{-lim_rf} *=2;
	}
	elsif ($cts >= $arg{-lim_rf}) {

lib/ARSObject.pm  view on Meta::CPAN

		$mpv =$mpv && $mpv->[0] ||'';
		print "$sql --> $mtc;\n"
			if $mpv && (exists($arg{-echo}) ? $arg{-echo} : $s->{-echo});
		$sql ='SELECT ' .$s->{-dbi}->quote_identifier($mpk)
			.' FROM '
			.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)
			.($mtv
			? ' WHERE ' .$s->{-dbi}->quote_identifier($mts)
				.'>=' .$s->{-dbi}->quote($mtv)
				.($mpv 
				 ? ' AND ' .$s->{-dbi}->quote_identifier($mpk)
					.'>=' .$s->{-dbi}->quote($mpv)
				 : '')
			: '')
			.' ORDER BY ' .$s->{-dbi}->quote_identifier($mts) .' ASC '
			.', ' .$s->{-dbi}->quote_identifier($mpk) .' ASC ';
		print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
		$lm =$s->{-dbi}->selectcol_arrayref($sql,{'MaxRows'=>$arg{-lim_rf}});
		return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'selectcol_arrayref',$sql)))
			if !$lm && $s->{-dbi}->errstr;
		# print $s->dsquot($lm),"\n";
		# die('TEST')
		# -form=>'HPD:HelpDesk_AuditLogSystem'
		# ,-master=>'HPD:Help Desk', -master_pk=>'Entry ID',-master_fk=>'Original Request ID', -master_ts=>'Last Modified Date'
	}
	my ($rw, $rd) =({});
	my ($cs, $cw) =($cts,0);
	while ($lm ? scalar(@$lm) : 1) {
	  $cw++;
	  foreach my $r ($s->query(-form=>$arg{-form}
		,-fields=>$arg{-fields}
		,-echo=>$arg{-echo}
		,$lm
		? (-query=>join(' AND '
				, $arg{-query} ? '(' .$arg{-query} .')' : ()
				, '(' .join(' OR '
					, map {"'" .($s->{'-meta-sql'}->{$tbl}->{-cols}->{$arg{-master_fk}} && $s->{'-meta-sql'}->{$tbl}->{-cols}->{$arg{-master_fk}}->{fieldName} || $arg{-master_fk})
						."'=\"$_\""
						} splice @$lm, 0, $arg{-lim_or}) .')'))
		: (-query=>join(' AND ', map {$_ ? "($_)" : ()
				} $arg{-query}, $fts && $vts ? "'" .$fts->{fieldName} ."'>=" .$vts : ()
				) ||'1=1'
			,-limit=>$arg{-lim_rf}
			,-start=>$cs)
		,-order=>$fts
			? [$fts->{fieldName} => 'asc', $fpk->{fieldName} => 'asc']
			: [$fpk->{fieldName} => 'asc']
		)) {
		$cs++;
		next if !$r->{$fpk->{fieldName}};
		my $sql ='';
		$rd =$s->dbiquery($fpksql .$s->{-dbi}->quote($r->{$fpk->{fieldName}}))->fetchrow_hashref();
		my $ru;
		foreach my $f (@flds) {
			next	if !$f->{fieldName} || !$f->{COLUMN_NAME} || !$f->{TYPE_NAME}
				|| !exists($r->{$f->{fieldName}});
			$rw->{$f->{fieldName}} =!defined($r->{$f->{fieldName}})
						? $r->{$f->{fieldName}}
						: $f->{TYPE_NAME} eq 'datetime'
						? strtime($s, $r->{$f->{fieldName}})
						: ($f->{dataType} =~/^(?:char)$/) && $f->{COLUMN_SIZE}
						? substr($r->{$f->{fieldName}}, 0, $f->{COLUMN_SIZE_DB} ||$f->{COLUMN_SIZE})
						: $r->{$f->{fieldName}};
			$rd->{$f->{COLUMN_NAME}} =$1
						if $rd
						&& defined($rd->{$f->{COLUMN_NAME}})
						&& ($f->{TYPE_NAME} =~/^(?:datetime|float)$/)
						&& ($rd->{$f->{COLUMN_NAME}}=~/^(.+)\.0+$/);
			$rd->{$f->{COLUMN_NAME}} =defined($rw->{$f->{fieldName}}) && ($rw->{$f->{fieldName}} =~/\.(\d+)$/)
						? sprintf('%.' .length($1) .'f', $rd->{$f->{COLUMN_NAME}})
						: $rd->{$f->{COLUMN_NAME}} =~/^(.+)\.0+$/
						? $1
						: $rd->{$f->{COLUMN_NAME}}
						if $rd 
						&& defined($rd->{$f->{COLUMN_NAME}})
						&& ($f->{TYPE_NAME} eq 'float');
			$rd->{$f->{COLUMN_NAME}} =substr($rd->{$f->{COLUMN_NAME}}, 0, $f->{COLUMN_SIZE_DB} ||$f->{COLUMN_SIZE})
						if $rd
						&& defined($rd->{$f->{COLUMN_NAME}})
						&& ($f->{dataType} =~/^(?:char)$/) && $f->{COLUMN_SIZE};
			$ru =1			if $rd
						&& (defined($rd->{$f->{COLUMN_NAME}})
							? !defined($rw->{$f->{fieldName}}) 
								|| ($rd->{$f->{COLUMN_NAME}} ne $rw->{$f->{fieldName}})
							: defined($rw->{$f->{fieldName}}));
		}
		if (!$rd) {
			next	if $arg{-filter}
				&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
			$sql ='INSERT INTO ' .$tbc .' ('
				.join(', '
					, map { !exists($rw->{$_->{fieldName}})
						|| !defined($rw->{$_->{fieldName}})
						? ()
						: $s->{-dbi}->quote_identifier($_->{COLUMN_NAME})
						} @flds)
				.') VALUES ('
				.join(', '
					, map { !exists($rw->{$_->{fieldName}})
						|| !defined($rw->{$_->{fieldName}})
						? ()
						: $s->{-dbi}->quote($rw->{$_->{fieldName}})
						} @flds)
				.')';
				$ci++;
		}
		elsif ($ru) {
			next	if (!exists($arg{-ckpush}) ||$arg{-ckpush})
				&& ($rd->{'_arsobject_insert'}
				||  $rd->{'_arsobject_update'}
				||  $rd->{'_arsobject_delete'});
			next	if $arg{-filter}
				&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
			$sql ='UPDATE ' .$tbc .' SET '
				.join(', '
					,(exists($arg{-ckpush}) && !$arg{-ckpush}
						&& $s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}
						? '_arsobject_insert=NULL, _arsobject_update=NULL, _arsobject_delete=NULL'
						: ())
					, map { !exists($rw->{$_->{fieldName}})
						? ()
						: ($s->{-dbi}->quote_identifier($_->{COLUMN_NAME}) .' ='
							.(!defined($rw->{$_->{fieldName}})
							? 'NULL'
							: $s->{-dbi}->quote($rw->{$_->{fieldName}})
							))
						} @flds)
				.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rw->{$fpk->{fieldName}});
			$cu++
		}
		if ($sql) {
			# local $s->{-dbi}->{LongTruncOk} =1;
			print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
			$s->{-dbi}->do($sql) 
			|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));
		}
	  }
	  if (!$fts && ($cs == $cw *$arg{-lim_rf})) {
		sleep($arg{-sleep} ||0);
		next;
	  }
	  elsif ($lm) {
		sleep($arg{-sleep} ||0);
		next;
	  }
	  last;
	}
	if ($arg{-unused} && ($fts ? $vts : 1)) {
		my $sql ='DELETE FROM ' .$tbc .' WHERE ' 
			.dbidsqq($s
				, $vts && $fts ? '(' .$fts->{COLUMN_NAME} .'<' .$s->{-dbi}->quote($s->strtime($vts||0)) .') AND (' .$arg{-unused} .')' : $arg{-unused}
				, $s->{'-meta-sql'}->{$tbl});
		print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
		my $n=	$s->{-dbi}->do($sql) 
			|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));
		$cd +=$n;
	}
 }
 join(', ', map {$_ ? $_ : ()} $ci && "new $ci", $cu && "upd $cu", $cd && "del $cd")
	||'up-to-date'
}


sub dbidsquery {	# DBI datastore - query data alike ARS
 my ($s, %arg) =@_;
 # -form => ARS form	|| -from => sql table name
 # -fields=> ARS fields || -select=>sql select list
 # -query=> ARS query	|| -where => sql where
 # -order => 
 # -filter=> undef
 # -undefs=>1
 # -strFields=>1|0
 my $m =$s->{'-meta-sql'}->{$s->sqlname($arg{-form})};
 my $sql =join(' ', 'SELECT'
	,(ref($arg{-fields})
		? join(', ', map {$s->{-dbi}->quote_identifier($m->{-fields}->{$_} || $m->{-ids}->{$_} || $_)
			} @{$arg{-fields}})
		: $arg{-fields} && ($arg{-fields} ne '*')
		? dbidsqq($s, $arg{-fields}, $m)
		: ($arg{-fields} ||$arg{-select} ||'*')
		)
	,'FROM'
	,($arg{-from}
		? $arg{-from}
		: join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $s->sqlname($arg{-form})))
	,($arg{-where}
		? 'WHERE ' .$arg{-where}
		: $arg{-query}
		? 'WHERE ' .dbidsqq($s, $arg{-query}, $m)
		: '')
	,(ref($arg{-order})
		? 'ORDER BY '
			.(do{	my $r ='';
				my $i =0;
				foreach my $e (@{$arg{-order}}) {
					$r .=	$i && ($e =~/^(asc|1)$/)
						? ' asc'
						: $i && ($e =~/^(desc|2)$/)
						? ' desc'
						: (($r ? ',' : '')
							.$s->{-dbi}->quote_identifier($m->{-fields}->{$e} || $m->{-ids}->{$e} || $e)
							);
					$i =!$i;
				}
				$r})
		: $arg{-order}
		? ('ORDER BY ' .$arg{-order})
		: '')
	);
 print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
 local $s->{-dbi}->{LongReadLen} =$s->{-dbi}->{LongReadLen} <= 1024 ? 4*64*1024 : $s->{-dbi}->{LongReadLen};
 my $h =$s->dbiquery($sql); 
 my $xu=exists($arg{-undefs}) && !$arg{-undefs};
 my $yc=$arg{-select} ||ref($arg{-fields}) 
	|| ($arg{-fields} && ($arg{-fields} eq '*'));
 my $ys=defined($arg{-strFields}) ? $arg{-strFields} : $s->{-strFields};
 local $s->{-strFields} =defined($arg{-strFields}) ? $arg{-strFields} : $s->{-strFields};
 my ($r, $r1, @r);
 while ($r =$h->fetchrow_hashref()) {
	$r1 ={map {	$xu && !defined($r->{$_})
			? ()
			: $m->{-cols}->{$_} && $m->{-cols}->{$_}->{fieldName} && $m->{-cols}->{$_}->{fieldId}
			? ($m->{-cols}->{$_}->{fieldName}
				=> 
				(!defined($r->{$_})
					? $r->{$_}
					: $ys && ($m->{-cols}->{$_}->{dataType} eq 'enum')
					? $s->strOut($arg{-form}, $m->{-cols}->{$_}->{fieldId}, $r->{$_})
					: ($m->{-cols}->{$_}->{TYPE_NAME} =~/^(?:datetime|float)$/) && ($r->{$_} =~/^(.+)\.0+$/)
					? $1
					: $r->{$_}))
			: $yc
			? ($_ => $r->{$_})
			: ()
		} keys %$r};
	next if $arg{-filter} && !&{$arg{-filter}}($s,$r1);
	push @r, $r1;
 }
 @r
}


sub dbidsqq {	# DBI datastore - quote/parse condition to SQL names
 my ($s,$sf,$mh) =@_;	# (self, query string, default sql metadata)
 if (0) {
	my $q =substr($s->{-dbi}->quote_identifier(' '),0,1);
	$sf =~s/$q([^$q]+)$q\.$q([^$q]+)$q/!$s->{'-meta-sql'}->{-forms}->{$1} ? "?1$q$1${q}.$q$2$q" : $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-fields}->{$2} ? $s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) .'.' .$s->{-dbi}-...
	$sf =~s/$q([^$q]+)$q/$s->{'-meta-sql'}->{-forms}->{$1} ? ($s->{-sqlschema} ? $s->{-dbi}->quote_identifier($s->{-sqlschema}) .'.' : '') .$s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) : $mh->{-fields}->{$1} ? $s->{-dbi}->quote_identi...
	return($sf);	
 }
 my $qs =$s->{-dbi}->quote('w') =~/^([^w]+)w/ ? $1 : "'";
 my $qi =$s->{-dbi}->quote_identifier('w') =~/^([^w]+)w/ ? $1 : '"';
 my $qsq=$s->{-dbi}->quote("'w") =~/^([^w]+)w/ ? $1 : "''";
 my $qiq=$s->{-dbi}->quote_identifier('"w') =~/^([^w]+)w/ ? $1 : '""';
 my $qit=$qi .'.' .$qi;
 my $sr ='';
 my $m =undef;
 while ($sf =~/^(.*?)(\Q$qs\E|\Q$qi\E)(.*)/) {
	if ($2 eq $qi) {
		$sr .=$1 .$2;
		$sf =$3;
		my ($st,$sn) =('','');
		while (1) {
			if (!($sf =~/^(.*?)(\Q$qiq\E|\Q$qit\E|\Q$qi\E)(.*)/)) {
				return($sr .($st ? $st .$qit : '') .$sn .$sf)
			}
			elsif ($2 eq $qiq) {
				$sn .=$1 .$2;
				$sf =$3;
				next
			}
			elsif ($2 eq $qit) {
				$st =$sn .$1;
				$sn ='';
				$sf =$3;
				next
			}
			else {
				$sn .=$1;
				$sf =$3;
				$st =$st && $s->{'-meta-sql'}->{-forms}->{$st} || $st;
				$sn =$st && $s->{'-meta-sql'}->{$st}
					? ($s->{'-meta-sql'}->{$st}->{-fields}->{$sn}
					|| $s->{'-meta-sql'}->{$st}->{-ids}->{$sn}
					|| $sn)
					: ($mh->{-fields}->{$sn}
					|| $mh->{-ids}->{$sn}
					|| ($s->{'-meta-sql'}->{-forms}->{$sn}
						&& (($s->{-sqlschema} ? $s->{-sqlschema} .$qit : '')
							.$s->{'-meta-sql'}->{-forms}->{$sn}))
					|| $sn);
				$sr .=($st ? $st .$qit : '') .$sn .$qi;
				last
			}
		}
	}
	elsif ($2 eq $qs) {
		$sr .=$1 .$2;
		$sf =$3;
		while (1) {
			if (!($sf =~/^(.*?)(\Q$qsq\E|\Q$qs\E)(.*)/)) {
				return($sr .$sf)
			}
			elsif ($2 eq $qsq) {

lib/ARSObject.pm  view on Meta::CPAN

	)
}


sub cgiesc {	# escape strings to html
	$_[0]->{-cgi}->escapeHTML(@_[1..$#_])
}


sub cgitfrm {	# table form layot
		# -form =>{form attrs}, -table=>{table attrs}, -tr=>{tr attrs}, -td=>{}, -th=>{}
 my ($s, %a) =$_[0];
 my $i =1;
 while (ref($_[$i]) ne 'ARRAY') {$a{$_[$i]} =$_[$i+1]; $i +=2};
 $s->cgi->start_form(-method=>'POST',-action=>'', $a{-form} ? %{$a{-form}} : ())
	# ,-name=>'test'
 .$s->{-cgi}->table($a{-table} ? $a{-table} : (), "\n"
 .join(''
	, map {	my $r =$_;
		$s->{-cgi}->Tr($a{-tr} ? $a{-tr} : (), "\n"
		.join(''
			, map { ($_ =~/^</
				? $s->{-cgi}->td($a{-td} || {-align=>'left', -valign=>'top'}, $_)
				: $s->{-cgi}->th($a{-th} || $a{-td} || {-align=>'left', -valign=>'top'}, $_)
				) ."\n"
				} @$r)
		) ."\n"
		} @_[$i..$#_])) ."\n"
 .$s->cgi->end_form()
}


sub smtpconnect {# Connect SMTP
 set(@_);	# (-smtphost) -> self->{-smtp}
 set($_[0],-die=>'Carp') if !$_[0]->{-die};
 my $s =shift;
 no warnings;
 local $^W =0; 
 eval('use Net::SMTP; 1') ||return(&{$s->{-die}}($@, $s->efmt('Net::SMTP')));
 $s->{-smtp} =eval {
		local $^W=undef; 
		eval("use Net::SMTP"); 
		$s->{-smtphost}
			? Net::SMTP->new($s->{-smtphost})
			: CORE::die($s->efmt('SMTP host name required'))
	};
 return(&{$s->{-die}}("SMTP host '" .($s->{-smtphost}||'') ."': $@\n")) 
	if !$s->{-smtp} ||$@;
 $s->{-smtp}
}


sub smtp {	# SMTP connection object
 return($_[0]->{-smtp}) if $_[0]->{-smtp};
 smtpconnect(@_)
}


sub smtpsend {	# SMTP mail msg send
		# -from||-sender, -to||-recipient, 
		# -data|| -subject + (-text || -html)
 my ($s, %a) =@_;
 return(&{$s->{-die}}("SMTP host not defined"))
	 if !$s->{-smtphost};
 local $s->{-smtpdomain} =$s->{-smtpdomain} 
			|| ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()}))
			|| 'nothing.net';
 $a{-from}	=$a{-from} ||$a{-sender} ||$ENV{REMOTE_USER} ||$ENV{USERNAME};
 $a{-from}	=&{$a{-from}}($s,\%a)	if ref($a{-from}) eq 'CODE';
 $a{-to}	=&{$a{-to}}($s,\%a)	if ref($a{-to}) eq 'CODE';
 $a{-to}	=[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})]
					if $a{-to} && !ref($a{-to}) && ($a{-to} =~/[,;]/);
 $a{-sender}	=$a{-sender} ||$a{-from};
 $a{-recipient}	=$a{-recipient} ||$a{-to};
 $a{-recipient}	=&{$a{-recipient}}($s,\%a) if ref($a{-recipient}) eq 'CODE';
 $a{-recipient}	=[grep {$_} split /\s*[,;]\s*/, ($a{-recipient} =~/^\s*(.*)\s*$/ ? $1 : $a{-recipient})]
					if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/);
 return(&{$s->{-die}}("SMTP e-mail recipients not defined"))
	if !$a{-recipient};
 if (!defined($a{-data})) {
	my $koi =(($a{-charset}||$s->charset()||'') =~/1251/);
	$a{-subject} =    ref($a{-subject}) eq 'CODE'
			? &{$a{-subject}}($s,\%a)
			: 'ARSObject'
		if ref($a{-subject}) ||!defined($a{-subject});
	$a{-data}  ='';
	$a{-data} .='From: ' .($koi	? $s->cptran('ansi','koi',$a{-from}) 
					: $a{-from})
			."\cM\cJ";
	$a{-data} .='Subject: '
			.($koi
			? $s->cptran('ansi','koi',$a{-subject})
			: $a{-subject}) ."\cM\cJ";
	$a{-data} .='To: ' 
			.($koi	
			? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}) 
			: (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}))
			."\cM\cJ" 
			if $a{-to};
	foreach my $k (keys %a) {
		next if $k =~/^-(data|subject|html|text|from|to|sender|recipient)$/;
		next if !defined($a{$k});
		my $n =$k =~/^-(.+)/ ? ucfirst($1) .':' : $k;
		$a{-data} .=$n .' ' .$a{$k} ."\cM\cJ";
	}
	$a{-data} .="MIME-Version: 1.0\cM\cJ";
	$a{-data} .='Content-type: '  .($a{-html} ? 'text/html' : 'text/plain')
			.'; charset=' .($a{-charset}||$s->charset())
			."\cM\cJ";
	$a{-data} .='Content-Transfer-Encoding: ' .($a{-encoding} ||'8bit') ."\cM\cJ";
	$a{-data} .="\cM\cJ";
	$a{-data} .=$a{-html} ||$a{-text} ||'';
 }
 local $^W=undef;
 $s->smtp->mail($a{-sender} =~/<\s*([^<>]+)\s*>/ ? $1 : $a{-sender})
	||return(&{$s->{-die}}("SMTP sender \'" .$a{-sender} ."' -> " .($s->smtp->message()||'?')));
 $s->smtp->to(ref($a{-recipient})
		? (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})
		: $a{-recipient}, {'SkipBad'=>1}) # , {'SkipBad'=>1}
	|| return(&{$s->{-die}}("SMTP recipient \'" 
		.(ref($a{-recipient}) ? join(', ', (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})) : $a{-recipient}) ."' -> " .($s->smtp->message()||'?')));
 $s->smtp->data($a{-data})
	||return(&{$s->{-die}}("SMTP data '" .$a{-data} ."' -> " .($s->smtp->message()||'?')));
 my $r =$s->smtp->dataend()
	||return(&{$s->{-die}}("SMTP dataend -> " .($s->smtp->message()||'?')));
 $r ||1;
}


sub soon {	# Periodical execution of this script
		# (minutes ||sub{}, ?log file, ?run command, ?soon command)
		# minutes: undef - clear sched, run once || sub{} -> number
		# log file: empty || full file name || var file name
		# run  command: empty || 'command line' || [command line] || sub{}
		# soon command: empty || 'command line' || [command line] || []
		# empty run command - only soon command will be scheduled
		# empty soon command - sleep(minutes*60) will be used
		# !defined(minutes) - soon command will be deleted from schedule 
		#	and run command will be executed once
		# [soon command,... [arg,...],...] - schedule cleaning hint:
		#	join(' ',@{[soon,...arg]}) used to clean schedule
		#	join('', @{[arg,...]}) used in soon command
 my ($s, $mm, $lf, $cr, $cs) =@_;
 $lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
 my $wl;
 if (ref($cs) ? scalar(@$cs) : $cs) {
	return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
		if $^O ne 'MSWin32';
	if (defined($mm) && ($^O eq 'MSWin32') && eval('use Win32::Event; 1')) {
		# MSDN: 'CreateEvent', 'Kernel Object Namespaces'
		my $q =_sooncl($s, $cs, 1);
		my $n =$q;
		   $n =~s/[\\]/!/g;
		   $n ="Global\\$n";
		# sleep(60);
		$wl =Win32::Event->new(0,0,$n);
		# $s->fstore(">>$lf", $s->strtime() ."\t$$\tWin32::Event->new(0,0,$n) -> " .join(', ', $wl &&1 ||0, $^E ? ($^E +0) .".'$^E'" : ()) ."\n")
		#	if $lf;
		if ($wl && $^E && ($^E ==183)) {
			print "Already '$q', done.\n";
			$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tAlready '$q', done.\n")
				if $lf;
			return(0);
		}
	}
	_sooncln($s, $mm, $lf, $wl ? '' : $cr, $cs, 1);
 }
 my $r =1;
 while (1) {
	if (!$cr) {
	}
	elsif (ref($cr) eq 'CODE') {
		local *OLDOUT;
		local *OLDERR;
		if ($lf) {
			eval{fileno(STDOUT) && open(OLDOUT, '>&STDOUT')};
			eval{fileno(STDERR) && open(OLDERR, '>&STDERR')};
			open(STDOUT, ">>$lf");
			open(STDERR, ">>$lf");
		}
		$r =&$cr(@_);
		if ($lf) {
			eval{fileno(OLDOUT) && close(STDOUT) && open(STDOUT, '>&OLDOUT')};
			eval{fileno(OLDERR) && close(STDERR) && open(STDERR, '>&OLDERR')};
		}

lib/ARSObject.pm  view on Meta::CPAN

	}
 }
 $r
}



sub _sooncl {	# soon() command line former
 my ($s, $cs, $q) =@_;
 my $nc;
 my $qry =$cs;
 if (ref($cs)) {
	return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
		if $^O ne 'MSWin32';
	$cs->[0] =Win32::GetFullPathName($cs->[0])
		if ($^O eq 'MSWin32') && ($cs->[0] !~/[\\\/]/);
	$cs->[0] = $cs->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cs->[0]
		if $cs->[0] =~/\.dll$/i;
	$qry =$q ? join(' ', map {   $nc
				? ()
				: !defined($_)
				? '""'
				: ref($_)
				? (do{$nc =$_->[0]})
				: $_
				} @$cs)
		: join(' ', map {!defined($_) ? '""' : ref($_) ? join('', @$_) : $_
				} @$cs);
 }
 $qry
}


sub _sooncln {	# soon() cleaner
 my ($s, $mm, $lf, $cr, $cs, $strt) =@_;
 $lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
 if (ref($cs) ? scalar(@$cs) : $cs) {
	my $nc;
	my $qry =_sooncl($s, $cs, 1);
	print "Starting '$qry'...\n" if $strt && defined($mm);
	$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tStarting '$qry'...\n")
		if $strt && $lf && defined($mm);
	sleep(int(rand(20))) if $strt && defined($mm) && $cr;
	foreach my $l (`at`) {
		next if $nc
			? $l !~/\Q$qry\E/i
			: $l !~/\Q$qry\E[\w\d\s]*[\r\n]*$/i;
		next if $l !~/(\d+)/;
		my $v =$1;
		my $cmd ="at $v /d";
		print("$cmd # $l\n");
		$s->fstore(">>$lf", $s->strtime() ."\t$$\t$cmd # $l\n")
			if $lf;
		system($cmd);
	}
 }
 1
}


sub cfpinit {	# Field Player: init data structures
 my ($s) =@_;	# (self) -> self
 $s->{-fphc} ={};
 $s->{-fphd} ={};
 my $dh ={};
 my $dp =undef;
 my $ah ={};
 my $ak;
 my $bf =undef;
 foreach my $f (@{$s->{-fpl}}) {
	if (ref($f) && $f->{-key} && $f->{-namecgi}) {
		$ak =$f->{-namecgi};
		last
	}
 }
 foreach my $f (@{$s->{-fpl}}) {
	if (ref($f) ne 'HASH') {
		if (!defined($dp)) {
			$dp =$f ||'-unknown';
		}
		elsif (!defined($f)) {
			delete $dh->{$dp};
			delete $dh->{-record} if $dp eq '-formdb';
			$dp =undef;
		}
		else {
			$dh->{$dp} =$f;
			delete $dh->{-record} if $dp eq '-formdb';
			$dp =undef;
		}
	}
	else {
		@$f{keys %$dh} =values %$dh;
		if ($f->{-metadb} && $f->{-formdb} && $s->{-meta} && $s->{-meta}->{$f->{-formdb}}) {
			my $fm =$f->{-metadb};
			$fm =	($fm =~/^\d+$/ 
					? $s->{-meta}->{$f->{-formdb}}->{-fldids}->{$fm}
					: $s->{-meta}->{$f->{-formdb}}->{-fields}->{$fm})
				|| &{$s->{-die}}($s->efmt('Field not found',$s->{-cmd},undef,'cfpinit',$f->{-formdb},$f->{-metadb}));
			$f->{-name}   =$fm->{fieldName} if !$f->{-name};
			$f->{-namelbl}=$fm->{fieldLbll} if !exists($f->{-namelbl});
			$f->{-values} =schvals($s, $f->{-formdb}, $fm)
				if !($f->{-values} ||$f->{-labels})
				&& schvals($s, $f->{-formdb}, $fm);
			$f->{-labels} =schlblsl($s, $f->{-formdb}, $fm)
				if !$f->{-labels}
				&& schlbls($s, $f->{-formdb}, $fm);
			$f->{-value}  =$fm->{defaultVal}
				if !exists($f->{-value})
				&& exists($fm->{defaultVal});
		}
		if (!$f->{-namecgi}) {
			$f->{-namecgi} =$f->{-name};
			$f->{-namecgi} =~s/[\s-]/_/g
				if $f->{-namecgi};
		}
		if (!$f->{-namedb}) {
			$f->{-namedb} =$f->{-name};
		}
		$s->{-fphc}->{$f->{-namecgi}} =$f if $f->{-namecgi};
		$s->{-fphd}->{$f->{-namedb}}  =$f if $f->{-namedb};

lib/ARSObject.pm  view on Meta::CPAN

		|| (($f->{-record}||'') ne $frn)
		};
 my $vy  =0;
 my $fvu =sub{	return(undef)
			if (ref($_[1]->{-values}) eq 'ARRAY') 
			&& !scalar(@{$_[1]->{-values}});
		my $v =cfpvv(@_);
		$v =undef  if defined($_[1]->{-undef}) && defined($v) && ($_[1]->{-undef} eq $v);
		$vy=1 if defined($v) && ($v ne '') && (!$_[1]->{-master} ||$_[1]->{-key});
		$v =cfpvv($_[0], $_[1]->{-master}) if $_[1]->{-master} && !$_[1]->{-key};
		return($v) if !$_[2] || (defined($_[1]->{-vftran}) && !$_[1]->{-vftran});
		!defined($v)
		? $v
		: (ref($_[1]->{-labels}) eq 'HASH') && exists($_[1]->{-labels}->{$v})
		? $_[1]->{-labels}->{$v}
		: $v;
		};
 local $_;
 if ($frn || $s->{-fpbn}) {
	my $n =$frn =~/^(.+?)\d+$/ ? $1 : $frn;
	if ($n ne ($s->{-fpbn}||'')) {
		$s->{-fpbn} =$n;	# buffer values
		$s->{-fpbv} =undef;     # buffer name == record common name
		if ($ae =~/^(?:vfentry|entry)$/) {
			foreach my $ff (@{$s->{-fpl}}) {
				next if &$ffc($s, $ff) || !$ff->{-master};
				$frk =$ff;
				last;
			}
		}
	}
 }
 if (!$ae) {
 }
 elsif (ref($ae) eq 'CODE' && ($ord eq '-action')) {
	$r =eval{&$ae($s, $act, $ord, $rp, $f, $_ =cfpvv($s,$f), cfpvp($s,$f)
		, {map {&$ffc($s, $_)
			? ()
			: ($_->{-namedb} => &$fvu($s, $_))
			} cfpused($s)}
		)}
 }
 elsif (ref($ae) eq 'CODE') {	# -preact
	$r =eval{&$ae($s, $act, $ord, $rp, $f, $_ =cfpvv($s, $f), cfpvp($s,$f)
		, {map {&$ffc($s, $_) || !defined(cfpv($s, $_))
			? ()
			: ($_->{-namedb} => cfpv($s, $_))
			} @{$s->{-fpl}}}
		)}
 }
 elsif ($ae =~/^(?:vfentry|entry)$/ && ref($s->{-fpbv})) {
	$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});
	$r ={} if !$r;
 }
 elsif ($ae eq 'vfentry') {	# -preact
	my $fs =$f->{-vfname} ||$af->{-vfname};
	my $fn =undef;
	my $fv =undef;
	if ($frk && $fs && ($fn =$frk->{-namedb}) && defined($fv=cfpv($s, $frk->{-master}))) {
		$s->{-fpbv} =$f->{-namedb}
			? $s->vfdata($fs, sub{defined($_->{$fn}) && ($_->{$fn} eq $fv)})
			: [];
		$r =shift @{$s->{-fpbv}} if $s->{-fpbv} && scalar(@{$s->{-fpbv}});
		$r ={} if !$r;
	}
	elsif ($fs) {
		$r =undef;
		if (defined($fv=cfpv($s, $f))) {
			$fn =$f->{-namedb}
		}
		elsif ($af->{-namedb} && ($fv =cfpv($s, $af))) {
			$fn =$af->{-namedb};
		}
		elsif ($fn =cfpnd($s, cfpv($s, $af))) {
			$fv =cfpv($s, $fn)
		}
		if ($fn && defined($fv)) {
			$r =undef;
			my $fa =$s->vfdata($fs);
			foreach my $e (@$fa) {
				next if !defined($e->{$fn}) || ($e->{$fn} ne $fv);
				$r =$e;
				last
			}
			$@="Not found '$fn'=\"$fv\""
				if !$r;
		}
		else {
			$@ =$fn 
			? "Key '$fn' not defined at vfentry('$fs')"
			: "Key not defined at vfentry('$fs')"
		}
	}
	else {
		$@ ="Nothing to do at 'vfentry', '-vfname' not defined"
	}
 }
 elsif ($ae eq 'vfhash') {	# -preact
	my $fs =$f->{-vfname} ||$af->{-vfname};
	my $fn =undef;
	my $fv =undef;
	if (defined($fv=cfpv($s, $f))) {
		$fn =$f->{-namedb}
	}
	elsif ($af->{-namedb} && ($fv =cfpv($s, $af))) {
		$fn =$af->{-namedb};
	}
	elsif ($fn =cfpnd($s, cfpv($s, $af))) {
		$fv =cfpv($s, $fn)
	}
	$r =undef;
	if (!$fs) {
		$@ ="Nothing to do at 'vfhash', '-vfname' not defined"
	}
	elsif (!$fn) {
		$@ ="Key not defined at 'vfhash'"
	}
	elsif (!defined($fv)) {
		$@ ="Key '$fn' not defined at 'vfhash'"
	}
	else {
		$r =$s->vfhash($fs, $fn, $fv);
		$@="Not found '$fn'=\"$fv\""
			if !$r;
	}
 }
 elsif ($ae eq 'entry') {	# -preact
	my $fn =undef;
	my $fv =undef;
	if (!$frm) {
		$r =undef;
		$@ ="Form not defined"
	}
	elsif ($frk && ($fn=$frk->{-namedb}) && ($fv =cfpv($s, $frk->{master}))) {
		$s->{-fpbv} =$f->{-namedb}
			? eval{$s->connect()
				&& $s->query(-form=>$frm
				,-fields=>'*'
				,-where=>"'$fn'=" .$s->arsquot($fv))}

lib/ARSObject.pm  view on Meta::CPAN

			$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});
			$r ={} if !$r;
		}
		else {
			$r =undef
		}
	}
	elsif ($f && ($fv =cfpv($s, $f))) {
		$r =eval{$s->connect()
				&& $s->entry(-form=>$frm
				,-id=>$fv)};
	}
	elsif (   (($fn =$af->{-namedb}) && defined($fv =cfpv($s, $af)))
	       || (($fn =cfpnd($s, cfpv($s, $af))) && defined($fv =cfpv($s, $fn)))
		) {
		$r =eval{$s->connect()
				&& $s->query(-form=>$frm
				,-fields=>'*'
				,-where=>"'$fn'=" .$s->arsquot($fv))};
		if ($r) {
			$r =shift @$r;
			$@ ="Not found '$fn'=\"$fv\""
				if !$r
		}
	}
	else {
		$r =undef;
		$@ ="Key not defined"
	}
 }
 elsif ($ae eq 'entryNew') {	# -preact
	$r =eval{$s->connect()
		&& $s->entryNew(-form => $frm)}
		if $frm;
 }
 elsif ($ae eq 'entryIns') {	# -action
	my $fs =$f->{-vfname} ||$af->{-vfname};
	$r =eval{$s->connect()
		&& $s->entryIns(-form=>$frm
			, map {	&$ffc($s, $_) ||(exists($_->{-entryIns}) && !$_->{-entryIns})
			? ()
			: ($_->{-namedb} => &$fvu($s, $_))
			} cfpused($s))}
		if $frm;
	$r =1 if ref($r);
	if (!$r) {
		$@ ="Unknown 'entryIns' error" if !$@
	}
	elsif (!$fs ||!$f->{-key}) {
	}
	elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {
		$s->vfclear($fs);
	}
	elsif (($af->{-vfrenew} || $f->{-vfrenew}) && $s->{"${fs}-store"}) {
		eval{$s->vfclear($fs); $s->vfrenew($fs)}
	}
	elsif ($af->{-vfedit} || $f->{-vfedit}) {
		my $fn =$f->{-namedb} ||$af->{-namedb};
		my $ft =defined($f->{-vftran}) ? $f->{-vftran} : $af->{-vftran};
		my $fv =cfpv($s, $f);
		my $fa =$s->vfdata($fs);
		push @$fa, {$f->{-namedb} ? ($f->{-namedb}=>$r) : ()
				,map { &$ffc($s, $_) ||(exists($_->{-vfstore}) && !$_->{-vfstore})
					? ()
					: ($_->{-namedb} => &$fvu($s, $_, $ft))
					} cfpused($s)};
		$s->vfstore($fs);
		$s->vfclear($fs);
	}
 }
 elsif ($ae eq 'entryUpd') {	# -action
	my $fs =$f->{-vfname} ||$af->{-vfname};
	$r =eval{$s->connect()
		&& $s->entryUpd(-form=>$frm, -id=>cfpvv($s,$f)
		, map { &$ffc($s, $_) ||(exists($_->{-entryUpd}) && !$_->{-entryUpd})
			? ()
			: ($_->{-namedb} => &$fvu($s, $_))
			} cfpused($s))}
		if $frm && cfpvv($s,$f);
	if (!$r) {
		$@ ="Unknown 'entryUpd' error" if !$@
	}
	elsif (!$f->{-key} ||!$fs) {
	}
	elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {
		$s->vfclear($fs);
	}
	elsif (($af->{-vfrenew} || $f->{-vfrenew}) && $s->{"${fs}-store"}) {
		eval{$s->vfclear($fs); $s->vfrenew($fs)}
	}
	elsif ($af->{-vfedit} || $f->{-vfedit}) {
		my $fn =$f->{-namedb} ||$af->{-namedb};
		my $ft =defined($f->{-vftran}) ? $f->{-vftran} : $af->{-vftran};
		my $fv =cfpv($s, $f);
		my $fa =$s->vfdata($fs);
		foreach my $e (@$fa) {
			next if !defined($e->{$fn}) || ($e->{$fn} ne $fv);
			foreach my $f1 (cfpused($s)) {
				next	if &$ffc($s, $f1) ||(exists($f1->{-vfstore}) && !$f1->{-vfstore});
				$e->{$f1->{-namedb}} =&$fvu($s, $f1, $ft);
			}
			last;
		}
		$s->vfstore($fs);
		$s->vfclear($fs);
	}
 }
 elsif ($act eq 'entryDel') {	# -action
	my $fs =$f->{-vfname} ||$af->{-vfname};
	$r =eval{$s->connect()
		&& $s->entryDel(-form=>$frm
		, -id=>cfpvv($s,$f))}
		if $frm && cfpvv($s,$f);
	if (!$r) {
		$@ ="Unknown 'entryDel' error" if !$@
	}
	elsif (!$fs ||!$f->{-key}) {
	}
	elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {
		$s->vfclear($fs);
	}
	elsif (($af->{-vfrenew} || $f->{-vfrenew}) && $s->{"${fs}-store"}) {
		eval{$s->vfclear($fs); $s->vfrenew($fs)}
	}
	elsif ($af->{-vfedit} || $f->{-vfedit}) {
		my $fn =$f->{-namedb} ||$af->{-namedb};
		my $fv =cfpv($s, $f);
		my $fa =$s->vfdata($fs);
		my ($i,$j)  =(0, undef);
		foreach my $e (@$fa) {
			if (defined($e->{$fn}) && ($e->{$fn} eq $fv)) {
				$j =$i;				
				last;
			}
			$i++
		}
		splice(@$fa, $i, 1);
		$s->vfstore($fs);
		$s->vfclear($fs);
	}
 }
 elsif ($ae eq 'entrySave') {	# -action
	my $a =cfpvv($s,$f) ? 'entryUpd' : cfpvp($s,$f) ? 'entryDel' : 'entryIns';
	if ($a eq 'entryIns') { # $vy= 1 if cfpvv($s,$f)
		map { &$ffc($s, $_) ||(exists($_->{-entryIns}) && !$_->{-entryIns})
			? ()
			: ($_->{-namedb} => &$fvu($s, $_))
			} cfpused($s);
		$a = $vy
			? $a
			: ($a eq 'entryIns')
			? ''
			: ($a eq 'entryUpd') && cfpvp($s,$f)
			? 'entryDel'
			: $a;
	}
	$s->{-cgi}->param($f->{-namecgi}, cfpvp($s,$f))
		if ($a eq 'entryDel') && $f->{-namecgi};
	$r =!$a
	? 1
	: ref($act) eq 'HASH'
	? cfpaction($s, {%$act, -action => $a}, @_[2..$#_])
	: cfpaction($s, $a, @_[2..$#_])
 }
 if ((ref($r) eq 'HASH') && ($ord eq '-preact')) {
	foreach my $f1 (map {	&$ffc($s, $_) || !$_->{-namecgi}
				? ()
				: ($_)
				} @{$s->{-fpl}}) {
		next if !exists($r->{$f1->{-namedb}});
		my $u =$s->cfpused($f1);
		my $v =$r->{$f1->{-namedb}};
		if (defined($v)
		||  defined($s->{-cgi}->param($f1->{-namecgi}))) {
			$s->{-cgi}->param($f1->{-namecgi}, $v);
			$s->{-cgi}->param($f1->{-namecgi} .'__C_', '')
				if $u && ($f1->{-values} || $f1->{-labels});
		}
		if (defined($v)
		&& (defined($f1->{-vftran}) ? $f1->{-vftran} : defined($f->{-vftran}) ? $f->{-vftran} : $af->{-vftran})
		&& (ref($f1->{-labels}) eq 'HASH') && !exists($f1->{-labels}->{$v})) {
			foreach my $k (keys %{$f1->{-labels}}) {
				next if $v ne $f1->{-labels}->{$k};
				$v =$k;
				$s->{-cgi}->param($f1->{-namecgi}, $v);
				last;
			}
			print &{$s->{-fpmsg}}($s, 'Warning'