ARSObject

 view release on metacpan or  search on metacpan

lib/ARSObject.pm  view on Meta::CPAN

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) =@_;
 foreach my $k (keys %a) {
	$s->{$k} =$a{$k}
 }
 if ($a{-die}) {
	if ($a{-die} =~/^Carp/) {
		eval('use ' .$a{-die} .';');
		$s->{-die} =\&Carp::confess;
		$s->{-warn}=\&Carp::carp;
	}
	elsif ($a{-die} =~/^CGI::Carp/) {
		eval('use ' .$a{-die} .';');
		$s->{-die} =\&CGI::Carp::confess;
		$s->{-warn}=\&CGI::Carp::carp;
		if ($s->{-diemsg}) {
			my $dm =$s->{-diemsg};
			CGI::Carp::set_message(sub{&$dm(@_); $s->disconnect() if $s;})
		}
	}
	elsif ($a{-die} =~/^CGI::Die/) {
		eval('use Carp;');
		$s->{-die} =\&Carp::confess;
		$s->{-warn}=\&Carp::carp;
		my $sigdie =$SIG{__DIE__};
		$SIG{__DIE__} =sub{
			return if ineval();
			if ($s && $s->{-diemsg}) {
				&{$s->{-diemsg}}(@_)
			}
			else {
				print   $s->{-cgi}->header(-content=>'text/html'
					,($ENV{SERVER_SOFTWARE}||'') =~/IIS/ ? (-nph=>1) : ()
					)
					, "<h1>Error:</h1>"
					, $s->{-cgi}->escapeHTML($_[0])
					, "<br />\n"
					if $s && $s->{-cgi}
			}
			$s->DESTROY() if $s;
			$s =undef;
			# $SIG{__DIE__} =$sigdie;
			# &$sigdie(@_) if ref($sigdie) eq 'CODE';
			# CORE::die($_[0]);
		};
		$SIG{__WARN__} =sub{
			return if !$^W ||ineval();
			if ($s && $s->{-warnmsg}) {
				&{$s->{-warnmsg}}(@_)
			}
			else {
				print   '<div style="font-weight: bolder">Warnig: '
					, $s->{-cgi}->escapeHTML($_[0])
					, "<div>\n"
					if $s && $s->{-cgi}
			}
			# CORE::warn($_[0]);
		} if $^W;
	}
 }
 elsif ($a{-vfbase}) {
	if ($a{-vfbase} !~/[\\\/]/) {
		my $v =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0;
		$s->{-vfbase} =$v =~/^(.+?[\\\/])[^\\\/]+$/ ? $1 .$a{-vfbase} : $a{-vfbase};
	}
 }
 $s
}


sub ineval {	# is inside eval{}?
		# for PerlEx and mod_perl
		# see CGI::Carp::ineval comments and errors
 return $^S	if !($ENV{GATEWAY_INTERFACE}
			&& ($ENV{GATEWAY_INTERFACE} =~/PerlEx/))
		&& !$ENV{MOD_PERL};
 my ($i, @a) =(1);
 while (@a =caller($i)) {
	return(0) if $a[0] =~/^(?:PerlEx::|Apache::Perl|Apache::Registry|Apache::ROOT)/i;
	return(1) if $a[3] eq '(eval)';
	$i +=1;
 }
 $^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

lib/ARSObject.pm  view on Meta::CPAN

sub cpcon {		# Translate to console codepage
   $_[0] && $_[0]->{-cpcon}
 ? &{$_[0]->{-cpcon}}(@_)
 : $#_ <2
 ? $_[1]
 : (@_[1..$#_])
}


sub sfpath {		# self file path
			# () -> script's dir
			# (subpath) -> dir/subpath
 my $p =$0 =~/[\\\/]/ ? $0 : $^O eq 'MSWin32' ? Win32::GetFullPathName($0) : '';
 $_[1]
 ? (($p =~/^(.+?[\\\/])[^\\\/]+$/ ? $1 : '') .$_[1])
 : ($p =~/^(.+?)[\\\/][^\\\/]+$/ ? $1 : '')
}



sub fopen {		# Open file
 my $s =shift;		# ('-b',filename) -> success
 my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
 my $f =$_[0]; $f ='<' .$f if $f !~/^[<>]/;
 eval('use IO::File');
 my $h =IO::File->new($f) || return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open file','fopen',$f)));
 $h->binmode() if $h && ($o =~/b/);
 $h
}


sub fdirls {		# Directory listing
 my $s =shift;		# ('-',pathname, ?filter sub{}(self, path, $_=entry), ? []) -> (list) || [list]
 my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
 my ($f, $cf, $cs) =@_;
 local *FILE; opendir(FILE, $f) || return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open dir','fdirls',$f)));
 local $_;
 my ($r, @r);
 if ($cs) {
	while (defined($r =readdir(FILE))) {
		push @$cs, $r if !$cf ||&$cf($s,$f,$_ =$r)
	}
	closedir(FILE);
	return $cs;
 }
 else {
	while (defined($r =readdir(FILE))) {
		push @r, $r if !$cf ||&$cf($s,$f,$_ =$r)
	}
	closedir(FILE);
	return @r;
 }
}


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);

lib/ARSObject.pm  view on Meta::CPAN

 ? $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}

lib/ARSObject.pm  view on Meta::CPAN

	$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;
	local $_;
	foreach my $e (ARS::ars_GetListEntryWithFields($s->{-ctrl}, $f, $q
		, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
		, $a{-first} ||$a{-start} ||0
		, $fl
		, @fs)) {
		if (!ref($e)) {
			$_ =$id =$e
		}
		elsif (!defined(eval{&$c($s, $f, $_ =$id, entryOut($s, $f, $e))}) && $@) {
			last if $@ =~/^last[\r\n]*$/;
			next if $@ =~/^next[\r\n]*$/;
			return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},'eval(-for)')));
		}
	}
	return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},'undef','ars_GetListEntryWithFields')))
		if !defined($id) && $ARS::ars_errstr;
	return($s);
 }
 elsif ($c) {
	my $i =undef;
	local $_ ='';
	foreach my $e (ARS::ars_GetListEntry($s->{-ctrl}, $f, $q
		, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
		, $a{-first} ||$a{-start} ||0
		, $fl
		, @fs)) {
		if ($i)	{
			$i =0;
			$_ =$_ .($fl->[0]->{separator}) .$e
				if $a{-fields};
		}
		else {
			$i =1;
			$_ =$e;
			next
		}
		if (!defined(eval{&$c($s, $f, $_
			, $a{-fetch}
				? $s->entry(-from=>$f, -id=>$_
					, ref($a{-fetch}) ? (-fields => $a{-fetch}) : ())
				: ())}) && $@) {
			last if $@ =~/^last[\r\n]*$/;
			next if $@ =~/^next[\r\n]*$/;
			return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},'eval(-for)')));
		}
	}
	return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntry')))
		if !defined($i) && $ARS::ars_errstr;
	return($s)
 }
 elsif ($a{-fields} && !ref($a{-fields}->[0])) {
	my @r =ARS::ars_GetListEntryWithFields($s->{-ctrl}, $f, $q
		, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
		, $a{-first} ||$a{-start} ||0
		, $fl

lib/ARSObject.pm  view on Meta::CPAN

		$q  =$3;
		$r .=$1;
		if ($2 eq ')')	{$r .=$2; last}
		else		{$r .=_qsubst($s, $2, $q, $f)}
	}
	$_[2] =$q;
 }
 elsif ($c =~/['"]/) {
	my $cq =$s->strquot($c);
	$cq =substr($cq,1,-1);
	$r =$c;
	while ($q =~/^(.*?)(\Q$c\E|\Q$cq\E)(.*)/) {
		$q =$3;
		$r .=$1 .$2;
		last if $2 eq $c;
	}
	$_[2] =$q;
 }
 elsif ($c eq ',') {
	my @r;
	while ($q =~/^(.*?)(['"(]|\Q$c\E)(.*)/i) {
		$q =$3;
		$r .=$1;
		if ($2 eq $c) {
			push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r);
			$r ='';
		}
		else {
			$r .=_qsubst($s, $2, $q, $f);
		}
	}
	$r .=$q;
	push @r, ($r =~/^\s*(.*?)\s*$/ ? $1 : $r) if $r ne '';
	return(@r)
 }
 else {
	$r =$c .$q
 }
 $r
}


sub entry {	# ars_GetEntry
		# (-from=>form, -id=>entryId, ?-for=>{}, ?-fields=>[internalId,...])
		#	-> {fieldName => value}
 #		# Field Ids translated using -schdn/-schid
 # -from ||-form ||-schema => schema name
 # -id => entryId
 # -fields => [internalId, fieldName,...]
 # -for => {} # steady hash to store each entry fetched
 # ?-echo=>1
 #
 # ars_GetEntry(ctrl,schema,entry_id,...) -> (internalId => value,...)
 # no ars_GetEntryBLOB(ctrl,schema,entry_id,field_id,locType,locFile)
 # no ars_EncodeDiary(diaryEntryHash1, ... diaryEntryHashN)
 # encoded 'Status-History'
 # decoded 'diary'
 #
 my ($s, %a) =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-from};
 print $s->cpcon("entry(-form=>'$f',-id=>'$a{-id}')\n")
	if $s->{-echo} || $a{-echo};
 my %r =ARS::ars_GetEntry($s->{-ctrl},$f,$a{-id}
	,$a{-fields} 
		? (map {/^\d+$/ ? $_ : schdn($s, $f, $_)->{fieldId}} @{$a{-fields}})
		: ()
	);
 if (%r) {
	my $rr =$a{-for} ||{};
	undef(@{$rr}{keys %$rr}) if %$rr;
	# @{$rr}{map {schid($s,$f,$_)->{fieldName}} keys %r} =values %r;
	# return($rr);
	local $_;
	local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entry(-form=>'$f',-id=>'$a{-id}')";
	foreach my $id (keys %r) {
		my $ff =schdi($s,$f,$id);
		if ($ff) {
			$rr->{$ff->{fieldName}} 
				= !$s->{-strFields}
				? $r{$id}
				: $ff->{strOut}
				? &{$ff->{strOut}}($s,$f,$ff,$_=$r{$id})
				: strOut($s,$f,$id,$r{$id})
		}
		else {
			$rr->{$id} =$r{$id}
		}
	}
	return($rr)
 }
 return($ARS::ars_errstr
	? &{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'entry',-form=>$f,-id=>$a{-id}))
	: {})
}


sub entryOut {	# Format entry hash ref for output
		# (schema, entry, ?sample) -> entry
 my ($s, $f, $r, $rr) =@_;
 if ($rr) {
	undef(@{$rr}{keys %$rr}) if %$rr;
 }
 else {
	$rr ={}
 }
 local $_;
 foreach my $id (keys %$r) {
	my $ff =schdi($s,$f,$id);
	my $v  =$r->{$id};
	if ($ff) {
		$rr->{$ff->{fieldName}} 
			= !$s->{-strFields}
			? $r->{$id}
			: $ff->{strOut}
			? &{$ff->{strOut}}($s,$f,$ff,$_=$v)
			: strOut($s,$f,$id,$v);
	}
	else {
		$rr->{$id} =$r->{$id}
	}
 }

lib/ARSObject.pm  view on Meta::CPAN

	next if (ref($ds1->{$k}) && ref($ds2->{$k}))
		&& !dscmp($s,$ds1,$ds2);
	next if (defined($ds1->{$k}) && defined($ds2->{$k}))
		&& ($ds1->{$k} eq $ds2->{$k});
	next if $ee && (!defined($ds2->{$k}) ||($ds2->{$k} eq ''))
		&& (!defined($ds1->{$k}) ||($ds1->{$k} eq ''));
	$r->{$k} =$ds2->{$k}; $rr =1;
 }
 $rr ? $r : undef
}


sub entryNew {	# New {field => value}
		# (-form=>form, field=>value,...) -> {field=>value,...}
		# ?'Incident Number'=>1 for 'HPD:Help Desk'
 my ($s, %a) =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-into} ||$a{-for};
 delete @a{qw(-schema -form -from -into -for)};
 local $_;
 local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entryNew(-form=>'$f'," 
		.join(',', map {!defined($a{$_}) 
			? "$_=>undef"
			: ref($a{$_})
			? ("$_=>" .dsquot($s, $a{$_}))
			: ("$_=>" .strquot($s, $a{$_}))
			} sort keys %a)
		.')';
 foreach my $k (%{$s->{-meta}->{$f}->{-fields}}) {
	my $ff =$s->{-meta}->{$f}->{-fields}->{$k};
	next	if !$ff
		|| exists($a{$k})
		|| ((!defined($ff->{defaultVal}) || ref($ff->{defaultVal}))
		   && !$s->{-metaid}->{$ff->{fieldId}}->{defaultVal});
	$a{$k} =defined($s->{-metaid}->{$ff->{fieldId}}->{defaultVal})
		? $s->{-metaid}->{$ff->{fieldId}}->{defaultVal}
		: $ff->{defaultVal};
	$a{$k} =$s->{-metaid}->{$ff->{fieldId}}->{strOut}
		? &{$s->{-metaid}->{$ff->{fieldId}}->{strOut}}($s,$f,$s->{-metaid}->{$ff->{fieldId}},$_=$a{$k})
		: strOut($s, $f, $ff->{fieldId},$_=$a{$k})
		if $s->{-strFields};
 }
 if ($f eq 'HPD:Help Desk') {
	if ($a{'Incident Number'} && (length($a{'Incident Number'}) ==1)) {
		$a{'Incident Number'} =$s->entryIns(-form=>'HPD:CFG Ticket Num Generator', 'DataTags'=>'za')
	}
	elsif (defined($a{'Incident Number'}) && !$a{'Incident Number'}) {
		delete $a{'Incident Number'}
	}
 }
 \%a
}


sub entryIns {	# ars_CreateEntry
		# (-form=>form, field=>value) -> id
		# ?-echo=>1
		# ?'Incident Number'=>1 for 'HPD:Help Desk'
 my ($s, %a) =@_;
 my $f =$a{-schema} ||$a{-form} ||$a{-into};
 my $r;
 print $s->cpcon("entryIns(-form=>'$f')\n")
	if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
 delete @a{qw(-schema -form -from -into -echo)};
 local $_;
 local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entryIns(-form=>'$f'," 
		.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;
 delete $s->{-entryNo};
 if ($f eq 'HPD:Help Desk') {
	my $ii=schdn($s,$f,'Incident Number')->{fieldId};
	$a{$ii} =$s->entryIns(-form=>'HPD:CFG Ticket Num Generator', 'DataTags'=>'za')
		if length($a{$ii}) <2;
	$s->{-entryNo} =$a{$ii};
	$r =ARS::ars_CreateEntry($s->{-ctrl}, $f, %a)
 }	
 else {
	$r =$s->{-entryNo} =ARS::ars_CreateEntry($s->{-ctrl}, $f, %a)
 }
 if (!$r) {
	my $t =$s->efmt($ARS::ars_errstr,$s->{-cmd});
	return(&{$s->{-die}}($t))	if !$r &&  $ARS::ars_errstr;
	# warn($t)			if !$r && !$ARS::ars_errstr;
 }
 $r ||$s
}


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}) {
		$arg{-lim_rf} +=$cts;
		$cts =0;
	}
	else {
		$cts =0;
	}
	$vts =$s->timestr($vts) if $vts =~/\s/;
	$vts =$s->timestr($vts) if $vts =~/^(.+)\.0+$/;
 }
 if ($s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}
	&& (!exists($arg{-ckpush}) ||$arg{-ckpush})) {
	local $s->{-strFields} =0;
	my $sql ='SELECT * FROM ' .$tbc 
		.' WHERE _arsobject_insert=1 OR _arsobject_update=1 OR _arsobject_delete=1'
		.' ORDER BY ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' asc';
	print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
	my $dbq =$s->dbiquery($sql);
	my ($rd, @rq) =({});
	while (($rd && ($rd =$dbq->fetchrow_hashref())) ||scalar(@rq)) {
		if ($rd) {
			push @rq, $rd;
			next if scalar(@rq) <$arg{-lim_or};
		}
		else {
			next if !scalar(@rq)
		}
		my $arq =join(' OR '
			, map {	$_->{$fpk->{COLUMN_NAME}}
					&& ($_->{_arsobject_update} ||$_->{_arsobject_delete})
				? "'" .$fpk->{fieldName} ."'=" .$s->arsquot($_->{$fpk->{COLUMN_NAME}})
				: () } @rq);
		my %ars =$arq
			? map { ($_->{$fpk->{fieldName}} => $_)
				} $s->query(-form=>$arg{-form}
				,-fields=>$arg{-fields}
				,-echo=>$arg{-echo}
				,-query=>join(' AND '
					, $arg{-query} ? '(' .$arg{-query} .')' : ()
					, "($arq)"))
			: ();
		foreach my $rd (@rq) {
			my $ra =$ars{$rd->{$fpk->{COLUMN_NAME}}};
			my $rw ={};
			foreach my $f (@flds) {
				next	if !$f->{fieldName} || !$f->{COLUMN_NAME} || !$f->{TYPE_NAME}
					|| !exists($rd->{$f->{COLUMN_NAME}})
					|| !$f->{fieldId}
					|| $f->{IS_JOINED} ||$f->{DISPLAY_ONLY}
					|| $f->{IS_PK} 
					|| (($f->{fieldId}||'') =~/^(1|2|3|5|6|15|179)$/);
				$rd->{$f->{COLUMN_NAME}} =$1
							if defined($rd->{$f->{COLUMN_NAME}})
							&& ($f->{TYPE_NAME} =~/^(?:datetime|float)$/)
							&& ($rd->{$f->{COLUMN_NAME}}=~/^(.+)\.0+$/);
				$rd->{$f->{COLUMN_NAME}} =defined($ra->{$f->{fieldName}}) && ($ra->{$f->{fieldName}} =~/\.(\d+)$/)
							? sprintf('%.' .length($1) .'f', $rd->{$f->{COLUMN_NAME}})
							: $rd->{$f->{COLUMN_NAME}} =~/^(.+)\.0+$/
							? $1
							: $rd->{$f->{COLUMN_NAME}}
							if $ra
							&& ($f->{TYPE_NAME} eq 'float')
							&& defined($rd->{$f->{COLUMN_NAME}});
				$rw->{$f->{fieldName}} =!defined($rd->{$f->{COLUMN_NAME}})
							? $rd->{$f->{COLUMN_NAME}}
							: $f->{TYPE_NAME} eq 'datetime'
							? timestr($s, $rd->{$f->{COLUMN_NAME}})
							: $rd->{$f->{COLUMN_NAME}};
			}
			if ($rd->{_arsobject_delete}) {
				$rd->{_arsobject_insert} =$rd->{_arsobject_update} =undef;
				next	if $arg{-filter}
					&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
				sleep($arg{-sleep} ||0);
				$cd++;
				$s->entryDel(-form=>$arg{-form}, -echo=>$arg{-echo}
						,-id=>$rd->{$fid->{COLUMN_NAME}});
			}
			elsif ($rd->{_arsobject_update}) {
				$rd->{_arsobject_insert} =$rd->{_arsobject_delete} =undef;
				next	if $arg{-filter}
					&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
				$rw ={map {	!defined($rw->{$_}) && !defined($ra->{$_})
						? ()
						: !defined($rw->{$_}) ||!defined($ra->{$_})
						? ($_ => $rw->{$_})
						: $rw->{$_} ne $ra->{$_}
						? ($_ => $rw->{$_})
						: ()
						} keys %$rw}
					if $ra;
				if (scalar(%$rw)) {
					sleep($arg{-sleep} ||0);
					$cu++;
					$s->entryUpd(-form=>$arg{-form}, -echo=>$arg{-echo}
						,-id=>$rd->{$fid->{COLUMN_NAME}}
						, %$rw);
				}
			}
			elsif ($rd->{_arsobject_insert}) {
				$rd->{_arsobject_update} =$rd->{_arsobject_delete} =undef;
				next	if $arg{-filter}
					&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
				sleep($arg{-sleep} ||0);
				$ci++;
				$s->entryIns(-form=>$arg{-form}, -echo=>$arg{-echo}
					, map {defined($rw->{$_}) ? ($_ => $rw->{$_}) : ()} keys %$rw);
			}
			my $sql = $rd->{_arsobject_insert} || $rd->{_arsobject_delete}
				? ('DELETE FROM ' .$tbc 
					.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rd->{$fpk->{COLUMN_NAME}}))
				: ('UPDATE ' .$tbc .' SET '
					.join(', ', map { !exists($rd->{$_})
						? ()
						: ($s->{-dbi}->quote_identifier($_) .' =NULL')
						} '_arsobject_insert','_arsobject_update', '_arsobject_delete')
					.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rd->{$fpk->{COLUMN_NAME}}));
			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}));
		}
		@rq =();
	}
 }	
 if ($arg{-ckdel}) {
	my $cnl ='';
	my $dbr =[];
	while ($dbr) {
	  my $sql ='SELECT ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) 
		.' FROM ' .$tbc 
		.($cnl ||$s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}
			? ' WHERE ' .join(' AND ', map {$_ ? "($_)" : ()
				} ($s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert} ? '_arsobject_insert IS NULL OR _arsobject_insert=0' : '')
				, ($cnl ? $s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .'<=' .$s->{-dbi}->quote($cnl) : ''))
			: '')
		.' ORDER BY 1 desc';
	  print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
	  my $dbq =$s->dbiquery($sql);
	  my @cnd;
	  my @rms;
	  while (($dbr && ($dbr =$dbq->fetchrow_arrayref())) ||scalar(@cnd)) {
		if ($dbr) {
			push @cnd, $dbr->[0] =~/^([^\s]+)/i ? $1 : $dbr->[0];
		}
		if ($dbr ? scalar(@cnd) >=$arg{-lim_or} : scalar(@cnd)) {
			my %ars =map { ($_->{$fpk->{fieldName}} => 1)
				} $s->query(-form=>$arg{-form}
				,-fields=>[$fpk->{fieldName}]
				,-echo=>$arg{-echo}
				,-query=>join(' AND '
					, $arg{-query} ? '(' .$arg{-query} .')' : ()
					, '(' .join(' OR ', map {"'" .$fpk->{fieldName} ."'=" .$s->arsquot($_)
						} @cnd) .')')
				);
			my @del =map {	$ars{$_}
					? ()
					: !$arg{-filter} || &{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},undef,$_)
					? $_
					: ()
					} @cnd;
			if (scalar(@del)) {
				$cnl =$del[$#del];
				$sql ="DELETE FROM $tbc WHERE "
					.join(' OR ', map {$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .'=' .$s->{-dbi}->quote($_)
							} @del);
				push @rms, $sql;
				$cd +=scalar(@del);
			}
			@cnd =();
			sleep($arg{-sleep} ||0);
			if (scalar(@del)) {
				$dbq->finish();
				last;
			}
		}
	  }
	  foreach $sql (@rms) {
				print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
				$@ ='Unknown error';
				$s->{-dbi}->do($sql)
				|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));
	  }
	}
 }
 if (!exists($arg{-ckupd}) || $arg{-ckupd}) {
	my $sqlm=0;
	local $s->{-strFields} =0;
	my $fpksql ='SELECT * FROM ' .$tbc .' WHERE ' .$fpk->{COLUMN_NAME} .'=';
	my $lm;
	if ($arg{-master} && $arg{-master_fk} && $fts) {
		my $mtb =$s->sqlname($arg{-master});
		my $mts =$arg{-master_ts} && ($s->{'-meta-sql'}->{$mtb}->{-fields}->{$arg{-master_ts}} ||$arg{-master_ts});
		my $mpk =$arg{-master_pk} && ($s->{'-meta-sql'}->{$mtb}->{-fields}->{$arg{-master_pk}} ||$arg{-master_pk});
		my $mfk =$arg{-master_fk} && ($s->{'-meta-sql'}->{$tbl}->{-fields}->{$arg{-master_fk}} ||$arg{-master_fk});
		if (!$mts ||!$mpk) {
			my $flds =$s->{'-meta-sql'}->{$tbl}->{-cols};
			foreach my $fn (sort keys %$flds) {
				$mts =$fn if !$mts && $flds->{$fn}->{IS_TIMESTAMP};
				$mpk =$fn if !$mpk && $flds->{$fn}->{IS_PK}
						&& ($flds->{$fn}->{IS_PK} eq '1');
				last if $mts && $mpk;
			}
		}
		my $sql ='SELECT max(d.' .$s->{-dbi}->quote_identifier($fts->{COLUMN_NAME}) .')'
				.', max(m.' .$s->{-dbi}->quote_identifier($mts) .')'
			.' FROM '
			.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)
			." m, $tbc d"
			.' WHERE m.' .$s->{-dbi}->quote_identifier($mpk)
			.'=d.' .$s->{-dbi}->quote_identifier($mfk);
		my $mtv = $s->dbiquery($sql)->fetchrow_arrayref();
		print "$sql --> " .($mtv ? join(', ', map {$s->{-dbi}->quote(defined($_) ? $_ : 'undef')} @$mtv) : "'undef'") .";\n"
				if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
		$mtv =!$mtv ||!$mtv->[0] ||!$mtv->[1]
			? ''
			: $mtv->[0] lt $mtv->[1]
			? $mtv->[0]
			: $mtv->[1];
		$sql ='SELECT count(*) FROM '
			.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)
			.' WHERE '
			.$s->{-dbi}->quote_identifier($mts) .'=' .$s->{-dbi}->quote($mtv);
		my $mtc =$s->dbiquery($sql)->fetchrow_arrayref();
		$mtc =$mtc && $mtc->[0] ||0;
		my $mpv =$mtc >=($arg{-lim_rf} -$arg{-lim_rf} *0.1)
			? $s->dbiquery('SELECT max(m.' .$s->{-dbi}->quote_identifier($mpk) .'), count(*)'
				.' FROM '
				.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $mtb)
				." m, $tbc d"
				.' WHERE m.' .$s->{-dbi}->quote_identifier($mpk)
				.'=d.' .$s->{-dbi}->quote_identifier($mfk)
				.' AND m.' .$s->{-dbi}->quote_identifier($mts) .'=' .$s->{-dbi}->quote($mtv)
				)->fetchrow_arrayref()
			: '';
		$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

lib/ARSObject.pm  view on Meta::CPAN

	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')};
		}
	}
	else {
		my $cmd =$cr;
		if (ref($cr) eq 'ARRAY') {
			$cr->[0] =Win32::GetFullPathName($cr->[0])
				if ($^O eq 'MSWin32') && ($cr->[0] !~/[\\\/]/);
			$cr->[0] = $cr->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cr->[0]
				if $cr->[0] =~/\.dll$/i;
			$cmd =join(' ', @$cr);
		}
		if ($lf) {
			$cmd ="$cmd >>$lf 2>>\&1";
			print(($cs ? '' : "\n") ."$cmd\n");
			$s->fstore(">>$lf", ($cs ? '' : "\n") .$s->strtime() ."\t$$\t$cmd\n");
			if (system($cmd) <0) {
				$r =0;
				print("Error $!\n");
				$s->fstore(">>$lf", $s->strtime() ."\t$$\t$!\n");
			}
		}
		else {
			print(($cs ? '' : "\n") ."$cmd\n");
			if (system(ref($cr) ? @$cr : $cr) <0) {
				$r =0;
				print("Error $!\n");
			}
		}
	}
	last if $cs || !defined($mm);
	my $mmm =ref($mm) eq 'CODE' ? &$mm($s) : $mm;
	print "sleep(", $mmm *60, ")...\n";
	$s->fstore(">>$lf", $s->strtime() ."\t$$\tsleep(" .($mmm*60) .")...\n")
		if $lf;
	sleep($mmm *60);
 }
 if (defined($mm) && (ref($cs) ? scalar(@$cs) : $cs)) {
	_sooncln($s, $mm, $lf, $cr, $cs, 0) if !$wl;
	my $t1 =$s->strtime($s->timeadd(
		sprintf('%.0f', time()/60) *60
		, 0,0,0,0
		, ref($mm) eq 'CODE' ? &$mm($s) : $mm
		));
	$t1 =$1 if $t1 =~/\s([^\s]+)/;
	my $cmd ="at $t1 /interactive " ._sooncl($s, $cs);
	print("$cmd\n");
	$s->fstore(">>$lf", $s->strtime() ."\t$$\t$cmd\n")
		if $lf;
	if (system($cmd) <0) {
		print("Error $!\n");
		$s->fstore(">>$lf", $s->strtime() ."\t$$\t$!\n")
			if $lf;
	}
 }
 $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});
		}

lib/ARSObject.pm  view on Meta::CPAN

		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'
				, ($af->{-namelbl} ||$af->{-namecgi}) 
				.': '
				."'" .($f1->{-namelbl}||$f1->{-namedb}) 
				."' == ?\"$v\"?")
				if $u 
				&& !exists($f1->{-labels}->{$v})
				&& (defined($f1->{-lbtran}) && !$f1->{-lbtran})
		}
	}
 }
 $r
}


sub cfprun {	# Field Player: run
		# (self, msg sub{}
		# , form row sub{}, form top, form bottom) -> success
 my ($s, $cmsg, $cfld, $cfld0, $cfld1) =@_;
 my $hmsg =ref($cmsg) eq 'HASH' 
	? $cmsg 
	: ($s->{-lang} ||'') =~/^ru/i
	? {'Error'=>'Îøèáêà', 'Warning'=>'Ïðåäóïðåæäåíèå', 'Success'=>'Óñïåøíî'
		,'Executing'=>'Âûïîëíåíèå', 'Done'=>'Âûïîëíåíî'}
	: {};
 $cmsg =sub{"\n<br /><font style=\"font-weight: bolder\""
		.($_[1] =~/^(?:Error|Warning)/ ? ' color="red"' : '')
		.'>'
		.(defined($_[1]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[1]} ||$_[1]) : 'undef')
		.": "
		.(defined($_[2]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[2]} ||$_[2]) : 'undef')
		."</font>"
		# 'Error', 'Warning',
		# 'Executing', 'Done'('Success', 'Error')
		}
	if !$cmsg || (ref($cmsg) ne 'CODE');
 my $emsg =sub{	
		$CGI::Carp::CUSTOM_MSG
		? &$CGI::Carp::CUSTOM_MSG($_[1])
		: print(&$cmsg($_[0], 'Error', $_[1]))
		};
 $cfld =sub{"\n<tr><th align=\"left\" valign=\"top\">"
		. ($_[1]->{-namehtml}
			? &{$_[1]->{-namehtml}}(@_)
			: $_[0]->{-cgi}->escapeHTML($_[1]->{-namelbl}||''))
		. "</th>\n<td align=\"left\" valign=\"top\">"
		. $_[2]
		. "</td></tr>"
		}
	if !$cfld;
 $cfld0="\n<table>"	if !$cfld0;
 $cfld1="\n</table>"	if !$cfld1;
 $s->cgi();
 cfpinit($s);
 local $s->{-fpmsg} =$cmsg;
 my $err;
 my $act;
 my $acf;
 my $aec;
 my $arv;
 foreach my $f (@{$s->{-fpl}}) {
	next	if (ref($f) ne 'HASH')
		|| (exists($f->{-used}) && !$f->{-used});
	if ($f->{-preact} && ($f->{-preact} !~/^\d$/) && cfpvv($s, $f)) {
		$acf =1;
		$act =[] if !$act;
		push @$act, $f
	}
	if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {
		$aec =cfpvv($s, $f);
	}
	if ($f->{-key} && $act && !$err) {
		$arv =1;
		foreach my $a (@$act) {
			$arv =cfpaction($s, $a, '-preact', $arv, $f);
			next if $arv;
			$err =$@;
			last
		}
		$act =undef;
		if (!$arv) {
			&$emsg($s, $err ||"Unknown 'cfpaction' error");
			$err =1;
			last;
		}
	}
	if ($f->{-key}) {
		$act =undef;
	}
	next if !cfpused($s, $f);
	my $fn =cfpn($s, $f);
	if (!$f->{-reset}
		? undef
		: ref($f->{-reset}) eq 'CODE'
		? &{$f->{-reset}}($s, $f)
		: ref($f->{-reset}) eq 'ARRAY'
		? grep {cfpvcc($s, $_)} @{$f->{-reset}}
			# ??? read from URL interpreted as changed listbox
		: $f->{-reset}
		? cfpvcc($s, $f->{-reset})
		: undef
		) {
		$s->{-cgi}->delete($fn);
	}
	my $fv =exists($f->{-computed})
		? (ref($f->{-computed}) eq 'CODE'
			? &{$f->{-computed}}($s, $f)
			: ref($f->{-computed}) eq 'ARRAY'
			? cfpvv($s, @{$f->{-computed}})
			: $f->{-computed})
		: cfpvv($s, $f);
	local $_ =$fv;
	if (!($f->{-action} || $f->{-preact}) && $f->{-namecgi}) {
		if (defined($fv)) {
			if ((defined($f->{-lbtran}) ? $f->{-lbtran} : 0)
			&& (ref($f->{-labels}) eq 'HASH') && !exists($f->{-labels}->{$fv})) {
				foreach my $k (keys %{$f->{-labels}}) {
					next if $fv ne $f->{-labels}->{$k};
					$fv =$k;
					last;
				}
				print &$cmsg($s, 'Warning'
					, "'" .($f->{-namelbl} ||$f->{-namecgi} ||$f->{-namedb})
					."' == ?\"$fv\"?")
					if !exists($f->{-labels}->{$fv})
					&& !$f->{-lbadd}
			}			
			if ((defined($f->{-lbadd}) ? $f->{-lbadd} : 0)) {
				$f->{-values} =do{use locale;
					[sort {lc($f->{-labels}->{$a}) cmp lc($f->{-labels}->{$b})} keys %{$f->{-labels}}]}
					if (ref($f->{-labels}) eq 'HASH')
					&& !$f->{-values};
				push @{$f->{-values}}, $fv
					if (ref($f->{-values}) eq 'ARRAY')
					&& !grep /^\Q$fv\E$/, @{$f->{-values}};
			}
		}
		$f->{-labels} =&{$f->{-labels}}($s, $f, $_ =$fv)
			if ref($f->{-labels}) eq 'CODE';
		$f->{-values} =&{$f->{-values}}($s, $f, $_ =$fv)
			if ref($f->{-values}) eq 'CODE';
		$f->{-values} =do{use locale;
				[sort {lc($f->{-labels}->{$a}) cmp lc($f->{-labels}->{$b})} keys %{$f->{-labels}}]}
			if $f->{-labels}
			&& !$f->{-values};
		if ($f->{-values}
		&& (!defined($fv) || !grep /^\Q$fv\E$/, @{$f->{-values}})) {
			$fv =$f->{-values}->[0];
			$fv ='' if !defined($fv);
			$s->{-cgi}->delete("${fn}__C_")	if $f->{-change};
		}
		if (defined($fv)) {
			$s->{-cgi}->param($fn, $fv);
			$s->{-cgi}->param("${fn}__PV_", $fv)
				if !defined($s->{-cgi}->param("${fn}__PV_"));
		}
		else {
			$s->{-cgi}->delete($fn);
		}
	}
	foreach my $q ('-change', '-changelb') {
		next if !$f->{$q};
		last if !cfpvcc($s, $f);
		my $c =ref($f->{$q}) eq 'CODE' ? &{$f->{$q}}($s, $f, $_ =$fv) : $f->{$q};
		$c =ref($c) ne 'HASH' ? undef : ref($c->{$fv}) eq 'HASH' ? $c->{$fv} : $c;
		if (ref($c) eq 'HASH') {
			foreach my $k (keys %$c) {
				next if $k =~/^-/;
				defined($c->{$k})
				? $s->{-cgi}->param(cfpn($s, $k)
					, ref($c->{$k}) eq 'CODE'
					? &{$c->{$k}}($s, $f, $_ =$fv)
					: $c->{$k}
					)
				: $s->{-cgi}->delete(cfpn($s, $k))
			}
		}
	}
	if (my $ev =!$aec || !$f->{-error}
		? undef
		: ref($f->{-error}) eq 'CODE'
		? &{$f->{-error}}($s, $f, $_ =$fv, cfpvp($s, $f), $aec)
		: !ref($f->{-error}) && (!defined($fv) || ($fv eq ''))
		? $f->{-error}
		: undef
		) {
		print &$cmsg($s, 'Error', "'" .$f->{-namelbl} ."' - $ev");
		$err =1;
	}
	if (my $ev =!$f->{-warn}
		? undef
		: ref($f->{-warn}) eq 'CODE'
		? &{$f->{-warn}}($s, $f, $_ =$fv, cfpvp($s, $f), $aec)
		: !ref($f->{-warn}) && (!defined($fv) || ($fv eq ''))
		? $f->{-warn}
		: undef
		) {
		print &$cmsg($s, 'Warning', "'" .$f->{-namelbl} ."' - $ev");
	}
 }
 return(undef)
	if $err;
 $act =	$acf =$arv =undef;
 foreach my $f (@{$s->{-fpl}}) {
	next	if (ref($f) ne 'HASH')
		|| (exists($f->{-used}) && !$f->{-used});
	next if !cfpused($s, $f);
	if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {
		$acf =1;
		$act =[] if !$act;
		push @$act, $f
	}
	if ($f->{-key} && $act && !$err) {
		$arv =1;
		foreach my $a (@$act) {
			print &$cmsg($s, 'Executing', ($a->{-namelbl} ||$a->{-namecgi} ||'') .' ', $arv)
				if $a->{-namelbl} ||$a->{-namecgi};
			$arv =cfpaction($s, $a, '-action', $arv, $f);
			next if $arv;
			$err =$@;
			last;
		}
		$act =undef;
		if (!$arv) {
			&$emsg($s, $err ||"Unknown 'cfpaction' error");
			$err =1;
			last;
		}
	}
	if ($f->{-key}) {
		$act =undef;
	}
 }
 if ($acf) {
	print &$cmsg($s, 'Done', $err ? ('Error', $@) : ('Success', $arv))
 }
 return(undef)
	if $err;
 return(1)
	if $acf;
 foreach my $f (@{$s->{-fpl}}) {
	next	if (ref($f) ne 'HASH')
		|| (exists($f->{-used}) && !$f->{-used});
	next if exists($f->{-widget}) && !defined($f->{-widget});
	next if !$f->{-namecgi};
	my $u =cfpused($s, $f);
	next if $u && !($f->{-hidden} ||((ref($f->{-values}) eq 'ARRAY') && !scalar(@{$f->{-values}})));
	print 	defined(cfpvp($s, $f)) 
		? '<input type="hidden" name="' .$f->{-namecgi} .'__PV_" value="' 
			.$s->{-cgi}->escapeHTML(cfpvp($s, $f))
			.'" />' ."\n"
		: ''
		, !$u
		? (	defined($s->{-cgi}->param($f->{-namecgi}))
			? '<input type="hidden" name="' .$f->{-namecgi} .'" value="'
				.$s->{-cgi}->escapeHTML($s->{-cgi}->param($f->{-namecgi}))
				.'" />' ."\n"
			: '')
		: defined(cfpvv($s, $f))
		? '<input type="hidden" name="' .$f->{-namecgi} .'" value="'
			.$s->{-cgi}->escapeHTML(cfpvv($s, $f))
			.'" />' ."\n"
		: '';
 }
 print ref($cfld0) ? &{$cfld0}($s) : $cfld0;
 my $bb ='';
 foreach my $f (@{$s->{-fpl}}) {
	next	if (ref($f) ne 'HASH')
		|| (exists($f->{-used}) && !$f->{-used});
	next if !cfpused($s, $f);
	next if exists($f->{-widget}) && !defined($f->{-widget});
	next if $f->{-hidden} ||((ref($f->{-values}) eq 'ARRAY') && !scalar(@{$f->{-values}}));
	my $bf =$f->{-action} ||$f->{-preact};
	if ($f->{-action} ||$f->{-preact}) {
		$bb .=' ' if $bb;
		$bb .=	exists($f->{-widget}) && !$f->{-widget}
			? ''
			: !ref($f->{-widget}) && $f->{-widget}
			? $f->{-widget}
			: ref($f->{-widget}) eq 'CODE'
			? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
			: !$f->{-namecgi}
			? ''
			: ref($f->{-widget}) eq 'HASH'
			? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
				, %{$f->{-widget}})
			: $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
				, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-class -style));
		next
	}
	elsif ($bb) {
		print &$cfld($s, {}, $bb);
		$bb ='';
	}
	print &$cfld($s
	, $f->{-action} ||$f->{-preact}
		? {}
		: $f
	, (!$f->{-widget0}
		? ''
		: ref($f->{-widget0}) eq 'CODE'
		? &{$f->{-widget0}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
		: $f->{-widget0})
	. (!($f->{-action} || $f->{-preact}) && $f->{-namecgi} && defined(cfpvp($s, $f))
		? '<input type="hidden" name="' .$f->{-namecgi} .'__PV_" value="' 
			.$s->{-cgi}->escapeHTML(cfpvp($s, $f))
			.'" />'
		: ''
		)
	. (!ref($f->{-widget}) && exists($f->{-widget})
	? $f->{-widget}
	: ref($f->{-widget}) eq 'CODE'
	? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
	: !$f->{-namecgi}
	? ''
	: ref($f->{-widget}) eq 'HASH'
	? (	 $f->{-values}
		? $s->cgiselect(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
			, -onchange=>1
			, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-values -labels)
			, -id => $f->{-namecgi}
			, %{$f->{-widget}})
		: $f->{-rows}
		? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
			, -id => $f->{-namecgi}
			, %{$f->{-widget}})
		: $f->{-action} ||$f->{-preact}
		? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
			, -id => $f->{-namecgi}
			, %{$f->{-widget}})
		: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
			, -id => $f->{-namecgi}
			, %{$f->{-widget}})
			)
	: (	 $f->{-values}
		? $s->cgiselect(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
			, -id => $f->{-namecgi}
			, -onchange=>1			
			, map {	my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
				defined($v) ? ($_=>$v) : ()} qw(-values -labels -onchange -readonly -disabled -class -style))
		: $f->{-rows}
		? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
			, -id => $f->{-namecgi}
			, map {	my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
				defined($v) ? ($_=>$v) : ()} qw(-rows -columns -maxlength -readonly -class -style))
		: $f->{-action} ||$f->{-preact}
		? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
			, -id => $f->{-namecgi}
			, map {	my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
				defined($v) ? ($_=>$v) : ()} qw(-class -style))
		: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
			, -id => $f->{-namecgi}
			, map {	my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
				defined($v) ? ($_=>$v) : ()} qw(-size -maxlength -readonly -disabled -class -style))
			)
	)
	. (!$f->{-widget1}
		? ''
		: ref($f->{-widget1}) eq 'CODE'
		? &{$f->{-widget1}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
		: $f->{-widget1})
	);
 }
 if ($bb) {
	print &$cfld($s, {}, $bb);
	$bb ='';
 }
 print ref($cfld1) ? &{$cfld1}($s) : $cfld1;
 $err ? undef : 1
}