ARSObject

 view release on metacpan or  search on metacpan

lib/ARSObject.pm  view on Meta::CPAN

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) =@_;
 foreach my $k (keys %a) {
	$s->{$k} =$a{$k}

lib/ARSObject.pm  view on Meta::CPAN

		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]}) .'}'

lib/ARSObject.pm  view on Meta::CPAN

}



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]/)));
						}
					}
				}
			}

lib/ARSObject.pm  view on Meta::CPAN

				)
			: ()
			)
		: $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')) {

lib/ARSObject.pm  view on Meta::CPAN

 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;
	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
		, @fs);
	if (@r) {
		my @rr;
		for (my $i =0; $i <$#r; $i +=2) {
			push @rr, entryOut($s, $f, $r[$i+1])
		}
		return(@rr)
	}
	return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntryWithFields')))
		if $ARS::ars_errstr;
	return(())
 }
 else {
	my @r =ARS::ars_GetListEntry($s->{-ctrl}, $f, $q
		, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
		, $a{-first} ||$a{-start} ||0
		, $fl
		, @fs);
	if (@r) {
		my @rr;
		if ($a{-fields}) {
			for (my $i =0; $i <$#r; $i +=2) {
				push @rr, $r[$i]
					.($fl->[0]->{separator})
					. $r[$i+1]
			}
		}
		elsif ($a{-fetch}) {
			for (my $i =0; $i <$#r; $i +=2) {
				push @rr
				, $s->entry(-from=>$f, -id=>$r[$i]
					, ref($a{-fetch}) ? (-fields=>$a{-fetch}) : ())
			}
		}
		else {
			for (my $i =0; $i <$#r; $i +=2) { push @rr, $r[$i] }
		}
		return(@rr)
	}
	return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntry')))
		if $ARS::ars_errstr;
	return(())
 }
}


sub _qsubst {	# query condition string substitutions
		# (''|char, expr string, form) -> translated
 my ($s, $c, $q, $f) =@_;
 return($q) if !defined($q) ||($q eq '');
 my $r ='';
 if (!$c) {
	while ($q =~/^(.*?)(['"]|#[\w]+[\w\d]+\()(.*)/) {
		$r .=$1;
		$q  =$3;
		if (!defined($q)) {
			$q =''
		}
		elsif (substr($2,0,1) eq "'") {
			if ($q =~/^([^']+)'(.*)/) {
				$q =$2;
				my $n =$1;
				$r .="'" .($n =~/^\d+$/ ? $n : schdn($s,$f,$n)->{fieldId}) ."'";
			}
			else {
				$r .="'"
			}
		}
		else {
			$r .=_qsubst($s, $2, $q, $f)
		}
	}
	$r .=$q if defined($q);
 }
 elsif ($c eq '(') {
	$r =$c;
	while ($q =~/^(.*?)([()'"])(.*)/) {
		$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) {

lib/ARSObject.pm  view on Meta::CPAN

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


sub entryDif {	# Diff hash refs
		# ({old}, {new}, exclude empty) -> {to update}
 my($s, $ds1, $ds2, $ee) =@_;
 return(undef) if (ref($ds1) ||'') ne (ref($ds2) ||'');
 return(undef) if (ref($ds1) ||'') ne 'HASH';
 my ($r, $rr) =({});
 foreach my $k (keys %$ds2) {
	next if !defined($ds1->{$k}) && !defined($ds2->{$k});
	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 $_;

lib/ARSObject.pm  view on Meta::CPAN

		: $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})) {

lib/ARSObject.pm  view on Meta::CPAN

							: $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 '*'));

lib/ARSObject.pm  view on Meta::CPAN

				$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) {
				$sr .=$1 .$2;
				$sf =$3;
				next
			}
			else {
				$sr .=$1 .$2;
				$sf =$3;
				last
			}
		}
	}
 }
 $sr .$sf
}



sub cgi {	# CGI object
 return($_[0]->{-cgi}) if $_[0]->{-cgi};
 cgiconnect(@_)
}


sub cgiconnect {# Connect CGI
 my $s =shift;
 no warnings;
 local $^W =0; 
 $ENV{HTTP_USER_AGENT} =$ENV{HTTP_USER_AGENT}||'';
 $ENV{PERLXS} ='PerlIS' if !$ENV{PERLXS} && ($^O eq 'MSWin32') && $0 =~/[\\\/]perlis\.dll$/i;
 eval('use CGI; 1')
	||return(&{$s->{-die}}($s->efmt('No CGI')));
 $s->{-cgi} =$CGI::Q =$CGI::Q =eval{CGI->new(@_)}
	||return($s->{-die}
		? &{$s->{-die}}($s->efmt($@, undef, undef, 'cgi'))
		: CORE::die($s->efmt($@, undef, undef, 'cgi')));
 $s->set(-die=>'CGI::Carp fatalsToBrowser') if !$s->{-die};
 return(&{$s->{-die}}($s->efmt($s->{-cgi}->{'.cgi_error'}, undef, undef, 'cgi')))
	if $s->{-cgi}->{'.cgi_error'};
 if (1) {	# parse parameters
		# __C_ change(d), 
		# __O_ open, __L_ listbox choise, __S_ set, __X_ close
		# __P_ previous value
		# __B_ button for javascript
	foreach my $p ($s->{-cgi}->param) {
		if ($p =~/^(.+?)__S_$/) {
			$s->{-cgi}->param($1, $s->{-cgi}->param("$1__L_"));
			$s->{-cgi}->param("$1__C_", 1);
			$s->{-cgi}->delete("$1__L_");
		}
		elsif ($p =~/^(.+?)__X_$/) {
			if (defined($s->{-cgi}->param("$1__P_"))) {
				$s->{-cgi}->param($1, $s->{-cgi}->param("$1__P_"));
			}
			else {
				$s->{-cgi}->delete($1);
			}
			$s->{-cgi}->delete("$1__L_");
		}
	}
	foreach my $p ($s->{-cgi}->param) {
		if ($p =~/^(.+?)__L_$/) {
		#	$s->{-cgi}->param($1, $s->{-cgi}->param("$1__L_"));
		#	$s->{-cgi}->param("$1__C_", 1);
			$s->{-cgi}->delete("$1__L_");
		}
	}
 }
 $s->{-cgi}
}


sub cgipar {	# CGI parameter
 $_[0]->{-cgi}->param(@_[1..$#_])
}


sub cgiurl {	# CGI script URL
 local $^W =0;	# $ENV{PATH_INFO}
 if ($#_ >0) {
	my $v =($_[0]->{-cgi}||$_[0]->cgi)->url(@_[1..$#_]);
	if ($v) {}
	elsif (!($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {}
	elsif (($#_ >2) ||(($#_ ==2) && !$_[2])) {}
	elsif ($_[1] eq '-relative') {
		$v =$ENV{SCRIPT_NAME};
		$v =$1 if $v =~/[\\\/]([^\\\/]+)$/;
	}
	elsif ($_[1] eq '-absolute') {
		$v =$ENV{SCRIPT_NAME}
	}
	return($v)
 }
 else {	
	# MSDN: "GetServerVariable (ISAPI Extensions)"
	# ms-help://MS.MSDNQTR.v90.en/wcecomm5/html/wce50lrfGetServerVariableISAPIExtensions.htm
	# http:// $ENV{HTTP_HOST} : $ENV{SERVER_PORT} / ($ENV{PATH_INFO} | $ENV{SCRIPT_NAME})
	# + $ENV{QUERY_STRING}
	my $v =($_[0]->{-cgi}||$_[0]->cgi)->url();
	if ($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/)) {
		$v .= (($v =~/\/$/) ||($ENV{SCRIPT_NAME} =~/^\//) ? '' : '/')
			.$ENV{SCRIPT_NAME}
			if ($v !~/\w\/\w/) && $ENV{SCRIPT_NAME};
	}
	return($v)
 }
}


sub cgitext {	# CGI textarea field
 $_[0]->{-cgi}->textarea(@_[1..$#_])
	# -default=>$v, -override=>1
}


sub cgistring {	# CGI string field
 $_[0]->{-cgi}->textfield(@_[1..$#_])
}


sub cgiselect {	# CGI selection field composition
		# -onchange=>1 reloads form
 my ($s, %a) =@_;
 my $cs =$a{-onchange} && (length($a{-onchange}) ==1);
 ($cs
 ? '<input type="hidden" name="' .$a{-name} .'__C_" value="" />'
 : '')
 .$s->{-cgi}->popup_menu(%a
	, $a{-labels} && !$a{-values}
	? (-values => do{use locale; [sort {$a{-labels}->{$a} cmp $a{-labels}->{$b}} keys %{$a{-labels}}]})
	: ()
	, $cs
	? (-onchange => '{window.document.forms[0].' .$a{-name} .'__C_.value="1"; window.document.forms[0].submit(); return(false)}')
	: ()
	)
 .( $cs && ($a{-onchange}=~/^\d/) && $s->{-cgi}->param($a{-name} .'__C_')
  ? '<script for="window" event="onload">window.document.forms[0].' .$a{-name} .'.focus()</script>'
  : '')
}


sub cgiddlb {	# CGI drop-down listbox field composition
		# -strict=> - disable text edit, be alike cgiselect
 my ($s, %a) =@_;
 $s->cgi();
 my $n =$a{-name};
 my $nl="${n}__L_";
 my $av=sub{	return($a{-values}) if $a{-values};
		use locale;
		$a{-values} =[
			  $a{-labels0}
			? sort {(defined($a{-labels0}->{$a}) ? $a{-labels0}->{$a} : '') 
			cmp (defined($a{-labels0}->{$b}) ? $a{-labels0}->{$b} : '')
				} keys %{$a{-labels0}}
			: ()
			, (sort {(defined($a{-labels}->{$a}) ? $a{-labels}->{$a} : '') 
			cmp (defined($a{-labels}->{$b}) ? $a{-labels}->{$b} : '')
				} keys %{$a{-labels}})
			, $a{-labels1}
			? sort {(defined($a{-labels1}->{$a}) ? $a{-labels1}->{$a} : '') 
			cmp (defined($a{-labels1}->{$b}) ? $a{-labels1}->{$b} : '')
				} keys %{$a{-labels1}}
			: ()
				];
		foreach my $e ('-labels0','-labels1') {
			next if !$a{$e};
			foreach my $k (keys %{$a{$e}}) {
				$a{-labels}->{$k} =$a{$e}->{$k}
			}
		}
		$a{-values}
		};
 my $ac=$a{-class} ? ' class="' .$a{-class} .'"' : '';
 my $as=$a{-style} ? ' style="' .$a{-style} .'"' : '';
 my $aw=$a{-size} ||80;
 my $v =!defined($s->{-cgi}->param($n)) ||$a{-override}
	? $a{-default}
	: $s->{-cgi}->param($n);
    $v =&$av()->[0]
		if $a{-strict} && (!defined($v) || !grep /^\Q$v\E$/, @{&$av()});
    $s->{-cgi}->param($n, defined($v) ? $v : '');
 my $ek =$s->{-cgi}->user_agent('MSIE') ? 'window.event.keyCode' : 'event.which';
 my $fs =sub{
	'{var k;'
	."var l=window.document.forms[0].$nl;"
	."if(l.style.display=='none'){"
	.($_[0] eq '4' ? '' : 'return(true)') .'}else{'
	.(!$_[0]	# onkeypess - input
	? "if (String.fromCharCode($ek) ==\"\\r\") {${n}__S_.focus(); ${n}__S_.click(); return(true)}; k=window.document.forms[0].$n.value +String.fromCharCode($ek);"
	: $_[0] eq '1'	# onkeypess - list -> input (first char)
	? "if (String.fromCharCode($ek) ==\&quot;\\r\&quot;) {${n}__S_.focus(); ${n}__S_.click(); return(true)}; window.document.forms[0].$n.focus(); k=window.document.forms[0].$n.value =String.fromCharCode($ek); "
	: $_[0] eq '2'	# onkeypess - list -> prompt (selected char)
	# ? "k=prompt('Enter search string',String.fromCharCode($ek));"
	? "if (String.fromCharCode($ek) ==\&quot;\\r\&quot;) {${n}__S_.focus(); ${n}__S_.click(); return(true)}; k =String.fromCharCode($ek); for (var i=0; i <l.length; ++i) {if (l.options.item(i).value.toLowerCase().indexOf(k)==0 || l.options.item(i).text....
	: $_[0] eq '3'	# button - '..'
	? "k=prompt('Enter search substring',''); $nl.focus();"
	: $_[0] eq '4'	# onload - document
	? "k=window.document.forms[0].$n.value; window.document.forms[0].$nl.focus();"
	: ''
	)
	.'if(k){'
	.'k=k.toLowerCase();'
	.'for (var i=0; i <l.length; ++i) {'
	.($_[0] eq '4'
	? 'if (l.options.item(i).value.toLowerCase() ==k){'
	: $s->{-cgi}->user_agent('MSIE')
	? "if (l.options.item(i).innerText !='' ? l.options.item(i).innerText.toLowerCase().indexOf(k)"
		.($_[0] eq '3' ?'>=' :'==') .'0 : l.options.item(i).value.toLowerCase().indexOf(k)'
		.($_[0] eq '3' ?'>=' :'==') .'0){'
	: "if (l.options.item(i).text !='' ? l.options.item(i).text.toLowerCase().indexOf(k)"
		.($_[0] eq '3' ?'>=' :'==') .'0  : l.options.item(i).value.toLowerCase().indexOf(k)'
		.($_[0] eq '3' ?'>=' :'==') .'0){')
	.'l.selectedIndex =i; break;};}};'
	.($_[0] && ($_[0] ne '4') 
	 ? 'return(false);' 
	 : $_[0] && ($_[0] eq '2')
	 ? 'return(false);'
	 : '')
	.'}}'};

 ($s->{-cgi}->param("${n}__O_")
	? "<div><script for=\"$n\" event=\"onkeypress\">" .&$fs(0) ."</script>\n"
	: '')
 .$s->{-cgi}->textfield((map {defined($_) && defined($a{$_})
				? ($_ => $a{$_})
				: $a{-textfield} && $a{-textfield}->{$_} && !$s->{-cgi}->param("${n}__O_")
				? ($_ => $a{-textfield}->{$_})
				: ()
		} qw(-name -title -class -style -size -maxlength))
		, -default=>$v
		, -override=>1
		, ($a{-strict} && !$s->{-cgi}->param("${n}__O_")
			? (-readonly=>1) # ,-hidefocus=>0, -disabled=>0
			: ())
	)
 .($s->{-cgi}->param("${n}__O_")
	? ("<input type=\"submit\" name=\"${n}__X_\" value=\"X\" title=\"close\"$ac$as />"
	  ."<input type=\"hidden\" name=\"${n}__P_\" value=\"" .(defined($v) ? $s->{-cgi}->escapeHTML($v) : '') ."\"$ac$as />\n"
	  ."<br />\n"
	  ."<select name=\"${n}__L_\" title=\"select value\" size=\"10\""
	  ."$ac$as"
	  ." ondblclick=\"{${n}__S_.focus(); ${n}__S_.click(); return(true)}\"" 
	  ." onkeypress=\"" .($s->{-cgi}->user_agent('MSIE') ? &$fs(1) : &$fs(2)) 
	  ."\">\n"
	  .join('',map {'<option'
			.((defined($v) ? $v : '') eq (defined($_) ? $_ : '') ? ' selected' : '')
			.' value="' .$s->{-cgi}->escapeHTML(defined($_) ? $_ : '') .'">' 
				.$s->{-cgi}->escapeHTML(
					!defined($_)
					? ''
					: !$a{-labels}
					? (length($_) > $aw ? substr($_,0,$aw) .'...' : $_)
					: defined($a{-labels}->{$_})
					? (length($a{-labels}->{$_}) > $aw ? substr($a{-labels}->{$_},0,$aw) .'...' : $a{-labels}->{$_})
					: '') ."</option>\n"
			} @{&$av()})
	  ."</select>\n"
	  ."<input type=\"submit\" name=\"${n}__S_\" value=\"&lt;\" title=\"set\"$ac$as />"
	  .$s->{-cgi}->button(-value=>'...', -title=>'find', -onClick=>&$fs(3))
	  ."<input type=\"submit\" name=\"${n}__X_\" value=\"X\" title=\"close\"$ac$as />"
	  ."</div>\n"
	  ."<script for=\"window\" event=\"onload\">{window.document.forms[0].${n}__L_.focus()}</script>"
		)
	: ("<input type=\"submit\" name=\"${n}__O_\" value=\"...\" title=\"open\"$ac$as />"
	 .($s->{-cgi}->param("${n}__C_") ||$s->{-cgi}->param("${n}__X_")
		? "<script for=\"window\" event=\"onload\">{window.document.forms[0].${n}__O_.focus()}</script>"
		: ''
		))
	)
}


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'}, $_)

lib/ARSObject.pm  view on Meta::CPAN

	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))}
			: [];
		if ($s->{-fpbv}) {
			$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);

lib/ARSObject.pm  view on Meta::CPAN

				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

lib/ARSObject.pm  view on Meta::CPAN

		)
	. (!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
}