ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
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}})
lib/ARSObject.pm view on Meta::CPAN
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 '*'));
my $ys=defined($arg{-strFields}) ? $arg{-strFields} : $s->{-strFields};
local $s->{-strFields} =defined($arg{-strFields}) ? $arg{-strFields} : $s->{-strFields};
my ($r, $r1, @r);
while ($r =$h->fetchrow_hashref()) {
$r1 ={map { $xu && !defined($r->{$_})
? ()
: $m->{-cols}->{$_} && $m->{-cols}->{$_}->{fieldName} && $m->{-cols}->{$_}->{fieldId}
? ($m->{-cols}->{$_}->{fieldName}
=>
(!defined($r->{$_})
? $r->{$_}
: $ys && ($m->{-cols}->{$_}->{dataType} eq 'enum')
? $s->strOut($arg{-form}, $m->{-cols}->{$_}->{fieldId}, $r->{$_})
: ($m->{-cols}->{$_}->{TYPE_NAME} =~/^(?:datetime|float)$/) && ($r->{$_} =~/^(.+)\.0+$/)
? $1
: $r->{$_}))
: $yc
? ($_ => $r->{$_})
: ()
} keys %$r};
next if $arg{-filter} && !&{$arg{-filter}}($s,$r1);
push @r, $r1;
}
@r
}
sub dbidsqq { # DBI datastore - quote/parse condition to SQL names
my ($s,$sf,$mh) =@_; # (self, query string, default sql metadata)
if (0) {
my $q =substr($s->{-dbi}->quote_identifier(' '),0,1);
$sf =~s/$q([^$q]+)$q\.$q([^$q]+)$q/!$s->{'-meta-sql'}->{-forms}->{$1} ? "?1$q$1${q}.$q$2$q" : $s->{'-meta-sql'}->{$s->{'-meta-sql'}->{-forms}->{$1}}->{-fields}->{$2} ? $s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) .'.' .$s->{-dbi}-...
$sf =~s/$q([^$q]+)$q/$s->{'-meta-sql'}->{-forms}->{$1} ? ($s->{-sqlschema} ? $s->{-dbi}->quote_identifier($s->{-sqlschema}) .'.' : '') .$s->{-dbi}->quote_identifier($s->{'-meta-sql'}->{-forms}->{$1}) : $mh->{-fields}->{$1} ? $s->{-dbi}->quote_identi...
return($sf);
}
my $qs =$s->{-dbi}->quote('w') =~/^([^w]+)w/ ? $1 : "'";
my $qi =$s->{-dbi}->quote_identifier('w') =~/^([^w]+)w/ ? $1 : '"';
my $qsq=$s->{-dbi}->quote("'w") =~/^([^w]+)w/ ? $1 : "''";
my $qiq=$s->{-dbi}->quote_identifier('"w') =~/^([^w]+)w/ ? $1 : '""';
my $qit=$qi .'.' .$qi;
my $sr ='';
my $m =undef;
while ($sf =~/^(.*?)(\Q$qs\E|\Q$qi\E)(.*)/) {
if ($2 eq $qi) {
$sr .=$1 .$2;
$sf =$3;
my ($st,$sn) =('','');
while (1) {
if (!($sf =~/^(.*?)(\Q$qiq\E|\Q$qit\E|\Q$qi\E)(.*)/)) {
return($sr .($st ? $st .$qit : '') .$sn .$sf)
}
elsif ($2 eq $qiq) {
$sn .=$1 .$2;
$sf =$3;
next
}
elsif ($2 eq $qit) {
$st =$sn .$1;
$sn ='';
lib/ARSObject.pm view on Meta::CPAN
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();"
: $_[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=\"<\" 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'}, $_)
: $s->{-cgi}->th($a{-th} || $a{-td} || {-align=>'left', -valign=>'top'}, $_)
) ."\n"
} @$r)
) ."\n"
} @_[$i..$#_])) ."\n"
.$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
: '')
: 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 0.794 second using v1.01-cache-2.11-cpan-39bf76dae61 )