ARSObject

 view release on metacpan or  search on metacpan

lib/ARSObject.pm  view on Meta::CPAN

	,-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_/;

lib/ARSObject.pm  view on Meta::CPAN

	if $m !~/^ARS::/;
 no strict;
 &$m($_[0]->{-ctrl}, @_[1..$#_])
}


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


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

lib/ARSObject.pm  view on Meta::CPAN

 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(@_)
}

lib/ARSObject.pm  view on Meta::CPAN

			} @{$_[2]}) .']'
 : ref($_[2]) eq 'HASH'
 ? '{' .join(', ', map {defined($_[2]->{$_}) ? $_ .$_[1] .dsquot1(@_[0..1],$_[2]->{$_}) : ()
			} sort keys %{$_[2]}) .'}'
 : strquot($_[0],$_[2])
}


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


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


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

lib/ARSObject.pm  view on Meta::CPAN

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


sub timestr {	# Time from String
 my $s   =shift;
 if (scalar(@_) && !defined($_[0])) {

lib/ARSObject.pm  view on Meta::CPAN

 while ($msk =~/(yyyy|yy|mm|dd|hh|MM|ss)/) {
    my $m=$1; $msk =$';
    last if !($ts =~/(\d+)/);
    my $d =$1; $ts   =$';
    $d   -=1900   if $m eq 'yyyy' ||$m eq '%Y';
    $m    =chop($m);
    $m    ='M'    if $m eq 'm' && $th{$m};
    $m    =lc($m) if $m ne 'M';
    $th{$m}=$d;
 }
#eval('use POSIX');
 my $r =POSIX::mktime($th{'s'}||0,$th{'M'}||0,$th{'h'}||0,$th{'d'}||0,($th{'m'}||1)-1,$th{'y'}||0,0,0,(localtime(time))[8]);
# &{$s->{-warn}}("Not defined timestr('$_[0]')")
#	if !defined($r);
 $r
}


sub timeadd {	# Adjust time to years, months, days,...
 my $s =$_[0];
 if (!defined($_[1])) {
	&{$s->{-warn}}('Not defined time in timeadd()') if $^W;
	return(undef)
 }
 my @t =localtime($_[1]);
 my $i =5;
 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'
		: $_
		} $f, $t;
	map {Encode::is_utf8($_)
		? ($_ =Encode::encode($t, $_, 0))
		: Encode::from_to($_, $f, $t, 0)
		if defined($_) && ($_ ne '')
		} @s;
 }
 else {
	foreach my $v ($f, $t) {	# See also utf8enc, utf8dec
		if    ($v =~/oem|866/i)   {$v ='€‚ƒ„…ð†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™œ›šžŸ ¡¢£¤¥ñ¦§¨©ª«¬­®¯àáâãäåæçèéìëêíîï'}
		elsif ($v =~/ansi|1251/i) {$v ='ÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÜÛÚÝÞßàáâãäå¸æçèéêëìíîïðñòóôõö÷øùüûúýþÿ'}
		elsif ($v =~/koi/i)       {$v ='áâ÷çäå³öúéêëìíîïðòóôõæèãþûýøùÿüàñÁÂ×ÇÄÅ£ÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝØÙßÜÀÑ'}
		elsif ($v =~/8859-5/i)    {$v ='°±²³´µ¡¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÌËÊÍÎÏÐÑÒÓÔÕñÖ×ØÙÚÛÜÝÞßàáâãäåæçèéìëêíîï'}
	}
	map {eval("~tr/$f/$t/") if defined($_)} @s;
 }
 @s >1 ? @s : $s[0];
}


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

lib/ARSObject.pm  view on Meta::CPAN

 ? (($p =~/^(.+?[\\\/])[^\\\/]+$/ ? $1 : '') .$_[1])
 : ($p =~/^(.+?)[\\\/][^\\\/]+$/ ? $1 : '')
}



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


sub fdirls {		# Directory listing
 my $s =shift;		# ('-',pathname, ?filter sub{}(self, path, $_=entry), ? []) -> (list) || [list]
 my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
 my ($f, $cf, $cs) =@_;

lib/ARSObject.pm  view on Meta::CPAN

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

lib/ARSObject.pm  view on Meta::CPAN

 }
 elsif (ref($s->{"$k-calc"}) eq 'CODE') {
	my $cc =$s->{"$k-calc"};
	local $s->{"$k-calc"} =undef;
	$s->{$k} =$d =&$cc($s,$k);
	return($d);
 }
 my $r;
 if (0) {
	$r =($k && exists($s->{"${k}-storable"}) ? $s->{"${k}-storable"} : $s->{-storable})
	? eval("use Storable; 1")
		&& Storable::retrieve($f)
		|| return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::retrieve',$f)))
	: ((eval{do($f)}) || return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},undef,'do',$f))));
 }
 else {
	local *FILE;
	for (my $i =0; $i <$fretry; $i++) {
		$r =open(FILE, "<$f");
		last if $r;
	}
	return(&{$s->{-die}}($s->efmt('$!',undef,'Cannot open file','vfload',$f)))
		if !$r;
	binmode(FILE);
	my $v;
	sysread(FILE,$v,64,0)
		||return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'sysread',$f)));
	$r =($v 
		? $v !~/^\$VAR1\s*=/
		: ($k && exists($s->{"${k}-storable"}) ? $s->{"${k}-storable"} : $s->{-storable}))
	? ((seek(FILE,0,0) ||1)
		&& eval("use Storable; 1")
		&& Storable::fd_retrieve(\*FILE)
		|| return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::retrieve',$f))))
	: ((eval{close(FILE); 1}) &&
		do($f) || return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},undef,'do',$f)))
		);
	eval{close(FILE)};
 }
 $s->{$k} =$r if $k;
 $r
}



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

lib/ARSObject.pm  view on Meta::CPAN

 vfload($_[0], $_[1], 1) if !$_[0]->{$_[1]} || (ref($_[0]->{$_[1]}) eq 'CODE');
 if ($_[2]) {
	if (ref($_[2]) eq 'CODE') {
		local $_;
		local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
			."vfdata('$_[1]', sub{})";
		my ($rr, $v);
		if (ref($_[0]->{$_[1]}) eq 'ARRAY') {
			$rr =[];
			for(my $i=0; $i<=$#{$_[0]->{$_[1]}}; $i++) {
				if (!defined(eval{$v =&{$_[2]}($_[0], $_[1], $i, $_ =$_[0]->{$_[1]}->[$i])}) && $@) {
					last if $@ =~/^last[\r\n]*$/;
					next if $@ =~/^next[\r\n]*$/;
					return(&{$_[0]->{-die}}($_[0]->efmt($@,$_[0]->{-cmd})));
				}
				elsif ($v) {
					push @$rr, $_[0]->{$_[1]}->[$i]
				}
			}
		}
		elsif (ref($_[0]->{$_[1]}) eq 'HASH') {
			$rr ={};
			foreach my $i (keys %{$_[0]->{$_[1]}}) {
				if (!defined(eval{$v =&{$_[2]}($_[0], $_[1], $i, $_ =$_[0]->{$_[1]}->{$i})}) && $@) {
					last if $@ =~/^last[\r\n]*$/;
					next if $@ =~/^next[\r\n]*$/;
					return(&{$_[0]->{-die}}($_[0]->efmt($@,$_[0]->{-cmd})));
				}
				elsif ($v) {
					$rr->{$i} =$_[0]->{$_[1]}->{$i}
				}
			}
		}
		return($rr)

lib/ARSObject.pm  view on Meta::CPAN

				if defined($s->{$f}->{$kh}->{$k})
		}
	}
 }
 if (ref($v) eq 'CODE') {
	my ($rh, $t) =({});
	local $_;
	local $_[0]->{-cmd} =($_[0]->{-cmd} ? $_[0]->{-cmd} .': ' : '')
		."vfhash('$f', '$k', sub{})";
	foreach my $ke (keys %{$s->{$kk}}) {
		if (!defined(eval{$t =&$v($s, $f, $k, $_ =$s->{$kk}->{$ke})}) && $@) {
			last if $@ =~/^last[\r\n]*$/;
			next if $@ =~/^next[\r\n]*$/;
			return(&{$s->{-die}}($s->efmt($@,$s->{-cmd})));
		}
		elsif ($t) {
			$rh->{$ke} =$s->{$kk}->{$ke};
		}
	}
	return($rh)
 }

lib/ARSObject.pm  view on Meta::CPAN

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

lib/ARSObject.pm  view on Meta::CPAN

 }
 else {
	foreach my $f (keys %{$s->{'-meta-min'}}) {
		next if $s->{-meta}->{$f};
		my $fs =$s->{'-meta-min'}->{$f};
		$s->{-meta}->{$f} ={}
			if !$s->{-meta}->{$f};
		foreach my $ff (keys %{$fs->{-fields}}) {
			$s->{-meta}->{$f}->{-fields}->{$ff} ={}
				if !$s->{-meta}->{$f}->{-fields}->{$ff};
			eval {@{$s->{-meta}->{$f}->{-fields}->{$ff}}{keys %{$fs->{-fields}->{$ff}}}
				=values %{$fs->{-fields}->{$ff}}};
		}
	}
	$s->arsmetaix()
 }
 delete $s->{'-meta-min'};
 $s;
}

lib/ARSObject.pm  view on Meta::CPAN

	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

lib/ARSObject.pm  view on Meta::CPAN

		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

lib/ARSObject.pm  view on Meta::CPAN

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

lib/ARSObject.pm  view on Meta::CPAN

 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

lib/ARSObject.pm  view on Meta::CPAN

 .$s->cgi->end_form()
}


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

lib/ARSObject.pm  view on Meta::CPAN

		#	and run command will be executed once
		# [soon command,... [arg,...],...] - schedule cleaning hint:
		#	join(' ',@{[soon,...arg]}) used to clean schedule
		#	join('', @{[arg,...]}) used in soon command
 my ($s, $mm, $lf, $cr, $cs) =@_;
 $lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
 my $wl;
 if (ref($cs) ? scalar(@$cs) : $cs) {
	return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
		if $^O ne 'MSWin32';
	if (defined($mm) && ($^O eq 'MSWin32') && eval('use Win32::Event; 1')) {
		# MSDN: 'CreateEvent', 'Kernel Object Namespaces'
		my $q =_sooncl($s, $cs, 1);
		my $n =$q;
		   $n =~s/[\\]/!/g;
		   $n ="Global\\$n";
		# sleep(60);
		$wl =Win32::Event->new(0,0,$n);
		# $s->fstore(">>$lf", $s->strtime() ."\t$$\tWin32::Event->new(0,0,$n) -> " .join(', ', $wl &&1 ||0, $^E ? ($^E +0) .".'$^E'" : ()) ."\n")
		#	if $lf;
		if ($wl && $^E && ($^E ==183)) {

lib/ARSObject.pm  view on Meta::CPAN

	_sooncln($s, $mm, $lf, $wl ? '' : $cr, $cs, 1);
 }
 my $r =1;
 while (1) {
	if (!$cr) {
	}
	elsif (ref($cr) eq 'CODE') {
		local *OLDOUT;
		local *OLDERR;
		if ($lf) {
			eval{fileno(STDOUT) && open(OLDOUT, '>&STDOUT')};
			eval{fileno(STDERR) && open(OLDERR, '>&STDERR')};
			open(STDOUT, ">>$lf");
			open(STDERR, ">>$lf");
		}
		$r =&$cr(@_);
		if ($lf) {
			eval{fileno(OLDOUT) && close(STDOUT) && open(STDOUT, '>&OLDOUT')};
			eval{fileno(OLDERR) && close(STDERR) && open(STDERR, '>&OLDERR')};
		}
	}
	else {
		my $cmd =$cr;
		if (ref($cr) eq 'ARRAY') {
			$cr->[0] =Win32::GetFullPathName($cr->[0])
				if ($^O eq 'MSWin32') && ($cr->[0] !~/[\\\/]/);
			$cr->[0] = $cr->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cr->[0]
				if $cr->[0] =~/\.dll$/i;
			$cmd =join(' ', @$cr);

lib/ARSObject.pm  view on Meta::CPAN

				next if &$ffc($s, $ff) || !$ff->{-master};
				$frk =$ff;
				last;
			}
		}
	}
 }
 if (!$ae) {
 }
 elsif (ref($ae) eq 'CODE' && ($ord eq '-action')) {
	$r =eval{&$ae($s, $act, $ord, $rp, $f, $_ =cfpvv($s,$f), cfpvp($s,$f)
		, {map {&$ffc($s, $_)
			? ()
			: ($_->{-namedb} => &$fvu($s, $_))
			} cfpused($s)}
		)}
 }
 elsif (ref($ae) eq 'CODE') {	# -preact
	$r =eval{&$ae($s, $act, $ord, $rp, $f, $_ =cfpvv($s, $f), cfpvp($s,$f)
		, {map {&$ffc($s, $_) || !defined(cfpv($s, $_))
			? ()
			: ($_->{-namedb} => cfpv($s, $_))
			} @{$s->{-fpl}}}
		)}
 }
 elsif ($ae =~/^(?:vfentry|entry)$/ && ref($s->{-fpbv})) {
	$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});
	$r ={} if !$r;
 }

lib/ARSObject.pm  view on Meta::CPAN

 }
 elsif ($ae eq 'entry') {	# -preact
	my $fn =undef;
	my $fv =undef;
	if (!$frm) {
		$r =undef;
		$@ ="Form not defined"
	}
	elsif ($frk && ($fn=$frk->{-namedb}) && ($fv =cfpv($s, $frk->{master}))) {
		$s->{-fpbv} =$f->{-namedb}
			? eval{$s->connect()
				&& $s->query(-form=>$frm
				,-fields=>'*'
				,-where=>"'$fn'=" .$s->arsquot($fv))}
			: [];
		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;

lib/ARSObject.pod  view on Meta::CPAN

Change field values when this field changed.
This may be defined also as C<-values> or C<-labels>.



=item -computed

	=> not exists || value || [field name] || sub{}({self},{field}) -> value

(C<CGI Form Presenter - Field Definitions>)
Computed field value evaluator.
See also C<-value>.


=item -cpcon

	=> undef || sub{}(self, arg,...) -> translated

(C<Error Processing and Echo>)
Translation sub{} for error messages and C<-echo> printout.
I.e. sub{$_[0]->C<cptran>('ansi'=>'oem',@_[1..$#_])}

lib/ARSObject.pod  view on Meta::CPAN

=item -error

	=> not exists
	|| sub{}({self}, {field}, $_ =field value, previous value) -> 'error text'
	|| 'error text for empty field'

(C<CGI Form Presenter - Field Definitions>)
Field value error evaluator
See also C<-warn>.



=item -fpl

	=> [-formdb=>'...',-record=>'...'
	, {action field},.. {view/edit field},.., {button field},..}]

=item -fphc

	=> {'cgi field name' => {field definition},..}

=item -fphd

	=> {'db field name' => {field definition},..}

(C<CGI Form Presenter>)
Definitions of fields:
list of field in order to be evaluated,
field definitions by cgi names,
field definitions by ARS names.



=item -formdb

	=> 'db form name'

(C<CGI Form Presenter - Field Definitions>)

lib/ARSObject.pod  view on Meta::CPAN

(C<Connection>)
ARS user name to login under



=item -value

	=> not exists || value || [field name] || sub{}({self},{field}) -> value

(C<CGI Form Presenter - Field Definitions>)
Default field value or field value evaluator.
See also C<-computed>.



=item -values

	=> not exists || [value,..] || [{-name=>name, field=>value,..},..]
	|| sub{}({self},{field},$_=value) -> [value,..]

(C<CGI Form Presenter - Field Definitions>)

lib/ARSObject.pod  view on Meta::CPAN

See also C<-cpcon>.


=item -warn

	=> not exists
	|| sub{}({self}, {field}, $_ =field value, previous value) -> 'warning text'
	|| 'warning text for empty field'

(C<CGI Form Presenter - Field Definitions>)
Field value warning evaluator.
See also C<-error>.



=item -warnmsg

	=> undef || sub{}(string)

Message for C<-warn>, alike C<-diemsg>.

lib/ARSObject.pod  view on Meta::CPAN

=item AUTOLOAD ()

(C<ARS methods>)
Use object->arsXXX() syntax for ARS:ars_XXX(ctrl,...) calls.



=item cfpaction ({action} || 'action', '-preact'||'-action', {key field}) -> success

(C<CGI Form Presenter>)
Action evaluator, called from C<cfprun>(),
may be called from C<-action> or C<-preact> sub{}.


=item cfpl ('field name' || {field definition}) -> [possible field values]

(C<CGI Form Presenter>)
List of C<-values> of the field, may be used in sub{}s executed by C<cfprun>.


=item cfpp ('field name' || {field definition}) -> previous field value

test.pl  view on Meta::CPAN

use strict;
use Test;


BEGIN { plan tests => 2 + 5 + 1}

if (1) {
   print "\nRequired modules:\n";
   foreach my $m ('ARS', 'POSIX') {
     print "use $m\t";
     ok(eval("use $m; 'ok'"), 'ok');
   }
}

if (1) {
   print "\nOptional modules:\n";
   foreach my $m ('Data::Dumper', 'Storable', 'DBI', 'CGI', 'SMTP') {
     print "use $m\t";
     skip(!eval("use $m; 1"), 1);
   }
}


if (1) {
   print "\nPackaged modules:\n";
   foreach my $m ('ARSObject') {
     print "use ${m}\t";
     ok(eval("use ${m}; 1"), 1);
   }
}