ARSObject

 view release on metacpan or  search on metacpan

lib/ARSObject.pm  view on Meta::CPAN

 return(1) if (ref($ds1) ||'') ne (ref($ds2) ||'');
 return($ds1 cmp $ds2) if !ref($ds1);
 return(dsquot($s,$ds1) cmp dsquot($s,$ds2)) if ref($ds1) eq 'ARRAY';
 return(dsquot($s,$ds1) cmp dsquot($s,$ds2)) if ref($ds1) eq 'HASH';
 $ds1 cmp $ds2
}


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



sub dsmerge {	# Merge arrays or hashes
 my $r;
 if (ref($_[1]) eq 'ARRAY') {
	$r =[];
	for (my $i=1; $i <=$#_; $i++) {

lib/ARSObject.pm  view on Meta::CPAN

 foreach my $a (@_[2..$#_]) {$t[$i] += ($a||0); $i--}
#eval('use POSIX');
 POSIX::mktime(@t[0..5],0,0,$t[8])
}


sub charset {
 $_[0]->{-charset} && ($_[0]->{-charset} =~/^\d/)
	? 'windows-' .$_[0]->{-charset}
	: ($_[0]->{-charset} || ($_[0]->{-cgi} && $_[0]->{-cgi}->charset())
		|| eval('!${^ENCODING}') && eval('use POSIX; POSIX::setlocale(POSIX::LC_CTYPE)=~/\\.([^.]+)$/ ? "cp$1" : "cp1252"'))
}


sub cptran {	# Translate strings between codepages
 my ($s,$f,$t,@s) =@_;	# (from, to, string,...) -> string,...
 if (($] >=5.008) && eval("use Encode; 1")) {
	map {$_=  /oem|866/i	? 'cp866'
		: /ansi|1251/i	? 'cp1251'
		: /koi/i	? 'koi8-r'
		: /8859-5/i	? 'iso-8859-5'

lib/ARSObject.pm  view on Meta::CPAN

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

lib/ARSObject.pm  view on Meta::CPAN

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

lib/ARSObject.pm  view on Meta::CPAN

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}

lib/ARSObject.pm  view on Meta::CPAN

	: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
 !$f
 ? []
 : !$f->{-values}
 ? (!$f->{-labels}
	? []
	: (do{  local $_ =cfpv(@_);
		my $ll =ref($f->{-labels}) eq 'CODE'
			? &{$f->{-labels}}($_[0], $f, $_)
			: $f->{-labels};
		use locale;
		[sort {lc($ll->{$a}) cmp lc($ll->{$b})
			} keys %$ll]}))
 : ref($f->{-values}) eq 'CODE'
 ? (do{	local $_ =cfpv(@_);
	&{$f->{-values}}($_[0], $f, $_)})
 : $f->{-values}
}


sub cfpvv {	# Field Player: field value or default

lib/ARSObject.pm  view on Meta::CPAN

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