ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
|| $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) ==\"\\r\") {${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) ==\"\\r\") {${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();"
lib/ARSObject.pm view on Meta::CPAN
$dp =$f ||'-unknown';
}
elsif (!defined($f)) {
delete $dh->{$dp};
delete $dh->{-record} if $dp eq '-formdb';
$dp =undef;
}
else {
$dh->{$dp} =$f;
delete $dh->{-record} if $dp eq '-formdb';
$dp =undef;
}
}
else {
@$f{keys %$dh} =values %$dh;
if ($f->{-metadb} && $f->{-formdb} && $s->{-meta} && $s->{-meta}->{$f->{-formdb}}) {
my $fm =$f->{-metadb};
$fm = ($fm =~/^\d+$/
? $s->{-meta}->{$f->{-formdb}}->{-fldids}->{$fm}
: $s->{-meta}->{$f->{-formdb}}->{-fields}->{$fm})
|| &{$s->{-die}}($s->efmt('Field not found',$s->{-cmd},undef,'cfpinit',$f->{-formdb},$f->{-metadb}));
$f->{-name} =$fm->{fieldName} if !$f->{-name};
$f->{-namelbl}=$fm->{fieldLbll} if !exists($f->{-namelbl});
$f->{-values} =schvals($s, $f->{-formdb}, $fm)
if !($f->{-values} ||$f->{-labels})
&& schvals($s, $f->{-formdb}, $fm);
$f->{-labels} =schlblsl($s, $f->{-formdb}, $fm)
if !$f->{-labels}
&& schlbls($s, $f->{-formdb}, $fm);
$f->{-value} =$fm->{defaultVal}
if !exists($f->{-value})
&& exists($fm->{defaultVal});
}
if (!$f->{-namecgi}) {
$f->{-namecgi} =$f->{-name};
$f->{-namecgi} =~s/[\s-]/_/g
if $f->{-namecgi};
}
if (!$f->{-namedb}) {
$f->{-namedb} =$f->{-name};
}
$s->{-fphc}->{$f->{-namecgi}} =$f if $f->{-namecgi};
$s->{-fphd}->{$f->{-namedb}} =$f if $f->{-namedb};
$f->{-namecmt} =$f->{-namelbl} ||$f->{-namecgi} ||$f->{-namedb} ||$f->{-name} if !$f->{-namecmt};
$f->{-values} =schvals($s, $f->{-formdb}, $f->{-namedb})
if $f->{-namedb} && $f->{-formdb}
&& !($f->{-values} ||$f->{-labels})
&& schvals($s, $f->{-formdb}, $f->{-namedb});
$f->{-labels} =$s->{-strFields} && ($s->{-strFields} ==2)
? schlblsl($s, $f->{-formdb}, $f->{-namedb})
: schlbls($s, $f->{-formdb}, $f->{-namedb})
if $f->{-namedb} && $f->{-formdb}
&& !$f->{-labels}
&& schlbls($s, $f->{-formdb}, $f->{-namedb});
if ((ref($f->{-labels}) eq 'HASH')) {
foreach my $k (keys %{$f->{-labels}}) {
last if !ref($f->{-labels}->{$k});
$f->{-changelb} ={} if !$f->{-changelb};
my $n =defined($f->{-labels}->{$k}->{-label})
? $f->{-labels}->{$k}->{-label}
: defined($f->{-labels}->{$k}->{-name})
? $f->{-labels}->{$k}->{-name}
: '';
$f->{-changelb}->{$k} =$f->{-labels}->{$k};
$f->{-labels}->{$k} =$n;
}
}
if ((ref($f->{-values}) eq 'ARRAY')) {
for (my $i =0; $i <=$#{$f->{-values}}; $i++) {
last if !ref($f->{-values}->[$i]);
$f->{-changelb} ={} if !$f->{-changelb};
my $n =defined($f->{-values}->[$i]->{-name})
? $f->{-values}->[$i]->{-name}
: defined($f->{-values}->[$i]->{-label})
? $f->{-values}->[$i]->{-label}
: '';
$f->{-changelb}->{$n} =$f->{-values}->[$i];
$f->{-values}->[$i] =$n;
}
}
if ($f->{-change} ||$f->{-changelb}) {
$f->{-onchange} =1
}
if (exists($f->{-computed}) && !($f->{-readonly} ||$f->{-disabled})) {
$f->{-disabled} =1
}
if (!$f->{-namecgi} || !$f->{-action}) {
}
elsif (!$ah->{$f->{-namecgi}}) {
$ah->{$f->{-namecgi}} =$f
}
elsif (ref($f->{-action}) ||($f->{-action} =~/^../)) {
}
else {
$f->{-used} =$ah->{$f->{-namecgi}}->{-used}
if !exists($f->{-used})
&& exists($ah->{$f->{-namecgi}}->{-used});
$f->{-unused} =$ah->{$f->{-namecgi}}->{-unused}
if !exists($f->{-unused})
&& exists($ah->{$f->{-namecgi}}->{-unused});
$ah->{$f->{-namecgi}}->{-widget} =undef
if !exists($ah->{$f->{-namecgi}}->{-widget});
}
if (exists($f->{-used}) ||exists($f->{-unused})) {
}
elsif ($ak && ($f->{-action}||$f->{-preact})
&& (($f->{-action}||$f->{-preact}) =~/^(?:entryUpd|entryDel|entry|vfentry|vfhash)$/)) {
$f->{-used} =sub{$_[0]->cgipar($ak)}
}
else {
$f->{-used} =1
}
$f->{-widget} =undef
if $f->{-preact} && !exists($f->{-widget});
$bf =1
if $f->{-action} && ($f->{-action} =~/^\d$/);
}
}
if (!$bf) {
my @bl;
foreach my $f (@{$s->{-fpl}}) {
next if ref($f) ne 'HASH';
next if !$f->{-namecgi} || !$f->{-action};
$f->{-widget} =undef;
next if exists($f->{-computed}) || exists($f->{-value})
|| !$ah->{$f->{-namecgi}};
push @bl, {%$f, -action=>1};
delete $bl[$#bl]->{-widget};
delete $ah->{$f->{-namecgi}};
}
push @{$s->{-fpl}}, @bl;
}
$s
}
sub cfpused { # Field Player: field should be used?
# (self, field) -> yes?
my ($s, $f) =@_;
return(map {ref($_) && cfpused($s, $_) ? $_ : ()} @{$s->{-fpl}})
lib/ARSObject.pm view on Meta::CPAN
? $_[1]
: ($_[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
# (self, field || fieldname) -> value
my $v =cfpv(@_);
defined($v) ? $v : cfpvd(@_)
}
sub cfpvd { # Field Player: field default value
# (self, field || fieldname) -> value
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
!$f
? undef
: exists($f->{-computed})
? ( ref($f->{-computed}) eq 'CODE'
? &{$f->{-computed}}($_[0], $f)
: ref($f->{-computed}) eq 'ARRAY'
? cfpvv($_[0], @{$f->{-computed}})
: $f->{-computed})
: !exists($f->{-value})
? ($f->{-values} ||$f->{-labels} ? cfpvl($_[0], $f)->[0] : undef)
: ref($f->{-value}) eq 'CODE'
? &{$f->{-value}}($_[0], $f)
: ref($f->{-value}) eq 'ARRAY'
? cfpvv($_[0], @{$f->{-value}})
: $f->{-value}
}
sub cfpvp { # Field Player: field previous value
# (self, field || fieldname) -> value
$_[0]->{-cgi}->param((ref($_[1])
? $_[1]->{-namecgi} ||''
: (($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]} ||{})->{-namecgi} ||$_[1])
) .'__PV_')
}
sub cfpvc { # Field Player: field value changed since form open?
# (self, field || fieldname) -> changed?
my ($v1, $v0) =(cfpv(@_), cfpvp(@_));
defined($v1) && defined($v0)
? $v1 ne $v0
: !defined($v1) && !defined($v0)
? 0
: 1
}
sub cfpvcc { # Field Player: field value changed in the last form submit?
# (self, field || fieldname) -> changed?
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
my $fn =ref($f) ? $f->{-namecgi} ||'' : '';
$f->{-onchange} ||$f->{-values}
? $_[0]->{-cgi}->param("${fn}__C_") ||!defined($_[0]->{-cgi}->param("${fn}__C_"))
: cfpvc(@_)
}
sub cfpaction { # Field Player: execute action
# (self, {action}||'action'
# , '-preact'||'-action', {key field}) -> success
my ($s, $act, $ord, $rp, $f) =@_;
my $r =1;
my $af=ref($act) eq 'HASH' ? $act : {};
my $ae=ref($act) eq 'HASH' ? $act->{$ord} : $act;
my $frm =$f->{-formdb}|| $af->{-formdb} ||'';
my $frn =$f->{-record}|| $af->{-record} ||'';
my $frk =undef;
my $ffc =sub{ my $f =$_[1];
!ref($f)
|| !$f->{-namedb} || $f->{-key}
|| !$f->{-formdb} || ($f->{-formdb} ne $frm)
|| (($f->{-record}||'') ne $frn)
};
my $vy =0;
my $fvu =sub{ return(undef)
if (ref($_[1]->{-values}) eq 'ARRAY')
&& !scalar(@{$_[1]->{-values}});
my $v =cfpvv(@_);
$v =undef if defined($_[1]->{-undef}) && defined($v) && ($_[1]->{-undef} eq $v);
$vy=1 if defined($v) && ($v ne '') && (!$_[1]->{-master} ||$_[1]->{-key});
$v =cfpvv($_[0], $_[1]->{-master}) if $_[1]->{-master} && !$_[1]->{-key};
return($v) if !$_[2] || (defined($_[1]->{-vftran}) && !$_[1]->{-vftran});
!defined($v)
? $v
: (ref($_[1]->{-labels}) eq 'HASH') && exists($_[1]->{-labels}->{$v})
? $_[1]->{-labels}->{$v}
: $v;
};
local $_;
if ($frn || $s->{-fpbn}) {
my $n =$frn =~/^(.+?)\d+$/ ? $1 : $frn;
if ($n ne ($s->{-fpbn}||'')) {
$s->{-fpbn} =$n; # buffer values
$s->{-fpbv} =undef; # buffer name == record common name
if ($ae =~/^(?:vfentry|entry)$/) {
foreach my $ff (@{$s->{-fpl}}) {
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)}
)}
lib/ARSObject.pm view on Meta::CPAN
$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;
lib/ARSObject.pm view on Meta::CPAN
: defined(cfpvv($s, $f))
? '<input type="hidden" name="' .$f->{-namecgi} .'" value="'
.$s->{-cgi}->escapeHTML(cfpvv($s, $f))
.'" />' ."\n"
: '';
}
print ref($cfld0) ? &{$cfld0}($s) : $cfld0;
my $bb ='';
foreach my $f (@{$s->{-fpl}}) {
next if (ref($f) ne 'HASH')
|| (exists($f->{-used}) && !$f->{-used});
next if !cfpused($s, $f);
next if exists($f->{-widget}) && !defined($f->{-widget});
next if $f->{-hidden} ||((ref($f->{-values}) eq 'ARRAY') && !scalar(@{$f->{-values}}));
my $bf =$f->{-action} ||$f->{-preact};
if ($f->{-action} ||$f->{-preact}) {
$bb .=' ' if $bb;
$bb .= exists($f->{-widget}) && !$f->{-widget}
? ''
: !ref($f->{-widget}) && $f->{-widget}
? $f->{-widget}
: ref($f->{-widget}) eq 'CODE'
? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
: !$f->{-namecgi}
? ''
: ref($f->{-widget}) eq 'HASH'
? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, %{$f->{-widget}})
: $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-class -style));
next
}
elsif ($bb) {
print &$cfld($s, {}, $bb);
$bb ='';
}
print &$cfld($s
, $f->{-action} ||$f->{-preact}
? {}
: $f
, (!$f->{-widget0}
? ''
: ref($f->{-widget0}) eq 'CODE'
? &{$f->{-widget0}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
: $f->{-widget0})
. (!($f->{-action} || $f->{-preact}) && $f->{-namecgi} && defined(cfpvp($s, $f))
? '<input type="hidden" name="' .$f->{-namecgi} .'__PV_" value="'
.$s->{-cgi}->escapeHTML(cfpvp($s, $f))
.'" />'
: ''
)
. (!ref($f->{-widget}) && exists($f->{-widget})
? $f->{-widget}
: ref($f->{-widget}) eq 'CODE'
? &{$f->{-widget}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
: !$f->{-namecgi}
? ''
: ref($f->{-widget}) eq 'HASH'
? ( $f->{-values}
? $s->cgiselect(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -onchange=>1
, map {defined($f->{$_}) ? ($_=>$f->{$_}) : ()} qw(-values -labels)
, -id => $f->{-namecgi}
, %{$f->{-widget}})
: $f->{-rows}
? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, %{$f->{-widget}})
: $f->{-action} ||$f->{-preact}
? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, -id => $f->{-namecgi}
, %{$f->{-widget}})
: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, %{$f->{-widget}})
)
: ( $f->{-values}
? $s->cgiselect(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, -onchange=>1
, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
defined($v) ? ($_=>$v) : ()} qw(-values -labels -onchange -readonly -disabled -class -style))
: $f->{-rows}
? $s->cgitext(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
defined($v) ? ($_=>$v) : ()} qw(-rows -columns -maxlength -readonly -class -style))
: $f->{-action} ||$f->{-preact}
? $s->{-cgi}->submit(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}, -value=>$f->{-namelbl}
, -id => $f->{-namecgi}
, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
defined($v) ? ($_=>$v) : ()} qw(-class -style))
: $s->cgistring(-name=>$f->{-namecgi}, -title=>$f->{-namecmt}
, -id => $f->{-namecgi}
, map { my $v =ref($f->{$_}) eq 'CODE' ? &{$f->{$_}}($s, $f, cfpvv($s, $f), cfpvp($s, $f)) : $f->{$_};
defined($v) ? ($_=>$v) : ()} qw(-size -maxlength -readonly -disabled -class -style))
)
)
. (!$f->{-widget1}
? ''
: ref($f->{-widget1}) eq 'CODE'
? &{$f->{-widget1}}($s, $f, cfpvv($s, $f), cfpvp($s, $f))
: $f->{-widget1})
);
}
if ($bb) {
print &$cfld($s, {}, $bb);
$bb ='';
}
print ref($cfld1) ? &{$cfld1}($s) : $cfld1;
$err ? undef : 1
}
( run in 1.737 second using v1.01-cache-2.11-cpan-e1769b4cff6 )