error results from the CPAN

error

ARSObject

view release on metacpan or search on metacpan

		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

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

lib/ARSObject.pm view on Meta::CPAN

			: ('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"

lib/ARSObject.pm view on Meta::CPAN

			$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 '

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

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

	: ($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}

( run in 0.338 second using v1.01-cache-2.11-cpan-f6376fbd888 )