ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
}
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})
|| ($s->{-schgen} && ($s->{-schgen} >1))
|| (!-e $s->vfname('-meta'))
) {
#
# Data types:
# 'integer','real','char','enum','time','decimal'
# 'diary','attach','currency'
# 'trim','control','table','column','page','page_holder'
#
my ($vfs, $vfu);
local $s->{-schgen} =$s->{-schgen};
if (ref($s->{-schgen}) && (-e $s->vfname('-meta'))) {
$s->vfload('-meta');
}
elsif (($s->{-schgen} >1) && (-e $s->vfname('-meta'))) {
$s->vfload('-meta');
$vfs =$s->{-schgen} >2
? 0
: ([stat $s->vfname('-meta')]->[9] ||0);
}
else {
$s->{-meta} ={};
}
foreach my $f (ref($s->{-schgen}) ? @{$s->{-schgen}} : @{$s->{-schema}}){
my $fa =ARS::ars_GetSchema($s->{-ctrl}, $f);
!$fa && return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetSchema',$f)));
if ($vfs && $s->{-meta}->{$f}) {
#print $s->strtime($fa->{timestamp}),'/',$s->strtime($vfs), "\n", $s->cpcon($s->dsdump($fa)), "\n"; exit(0);
next if $s->{-meta}->{$f} && $s->{-meta}->{$f}->{timestamp}
? (($s->{-meta}->{$f}->{timestamp}||0) >=($fa->{timestamp}||0))
&& ($vfs >=($fa->{timestamp}||0))
: $vfs >=($fa->{timestamp}||0 +60*60);
}
$vfu =1;
$s->{-meta}->{$f} ={}; # {} || $fa
$s->{-meta}->{$f}->{-fields} ={};
$s->{-meta}->{$f}->{timestamp} =$fa->{timestamp};
# $s->{-meta}->{$f}->{indexList} =$fa->{indexList};
# $s->{-meta}->{$f}->{getListFields} =$fa->{getListFields};
# $s->{-meta}->{$f}->{sortList} =$fa->{sortList};
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);
!%ff && return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetFieldTable',$f)));
foreach my $ff (sort keys %ff) {
lib/ARSObject.pm view on Meta::CPAN
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"
: '')
: ()
} sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}})
.')'
}
else {
my $dbc ={map {
!$_ ||!$_->{COLUMN_NAME}
? ()
: (lc($_->{COLUMN_NAME}) => $_)
} $s->dbicols('',$tbl)};
if (scalar(%$dbc)) {
my (@altc, @addc);
foreach my $col (sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}}) {
my $cl =lc($col);
my $cm =$s->{'-meta-sql'}->{$tbl}->{-cols}->{$col};
next if !$cm->{'TYPE_NAME'};
if (!$dbc->{$cl}) {
push @addc, '"' .$col .'" ' .$s->dbitypespc($cm)
}
elsif (($dbc->{$cl}->{'TYPE_NAME'} ne $cm->{'TYPE_NAME'})
|| ($cm->{'TYPE_NAME'} ne 'datetime'
? (($dbc->{$cl}->{'COLUMN_SIZE'}||0) < ($cm->{'COLUMN_SIZE'}||0))
|| (($dbc->{$cl}->{'DECIMAL_DIGITS'}||0) ne ($cm->{'DECIMAL_DIGITS'}||0))
: 0 )
) {
push @altc, '"' .$col .'" ' .$s->dbitypespc($cm)
}
else {
$cm->{COLUMN_SIZE_DB} =$dbc->{$cl}->{'COLUMN_SIZE'}
if ($cm->{COLUMN_SIZE_DB}||0) ne ($dbc->{$cl}->{'COLUMN_SIZE'}||0);
$cm->{DECIMAL_DIGITS_DB} =$dbc->{$cl}->{'DECIMAL_DIGITS'}
if ($cm->{DECIMAL_DIGITS_DB}||0) ne ($dbc->{$cl}->{'DECIMAL_DIGITS'}||0);
}
}
foreach my $r (@addc) {
push @sql
,'ALTER TABLE '
.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)
.' ADD ' .$r;
}
foreach my $r (@altc) {
push @sql
,'ALTER TABLE '
.join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl)
.' ALTER COLUMN ' .$r;
}
}
}
foreach my $r (@sql) {
print "$r;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
$s->dbi()->do($r)
|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$r,undef,'dbidsmetasync'));
}
}
$s;
}
sub dbidsrpl { # DBI datastore - load data from ARS
my ($s, %arg) =@_;
$arg{-form} =$arg{-from} ||$arg{-schema} if !$arg{-form};
$arg{-query} =$arg{-where} ||$arg{-qual} if !$arg{-query};
$arg{-filter}=undef if !$arg{-filter};
$arg{-lim_rf}=300 if !$arg{-lim_rf};
$arg{-lim_or}=40 if !$arg{-lim_or};
$arg{-fields}='*' if !$arg{-fields};
# $arg{-echo}=0;
# $arg{-ckpush}=1; # check db pushes into ARS (_arsobject_insert, _arsobject_update, _arsobject_delete)
# $arg{-ckdel}=0; # check ARS deletes into db
# $arg{-ckupd}=1; # check ARS updates into db
# $arg{-sleep}=0;
# $arg{-pk}=undef;
# $arg{-timestamp}=undef; # field name || 0
# $arg{-unused}=undef;
# $arg{-master}
# $arg{-master_pk}
# $arg{-master_fk}
# $arg{-master_ts}
my $tbl =$s->sqlname($arg{-form});
my $tbc =join('.', map {defined($_) ? $_ : ()} $s->{-sqlschema}, $tbl);
my ($fpk, $fid, $fts, @flds);
my ($ci, $cu, $cd) =(0, 0, 0);
{ my $flds =$s->{'-meta-sql'}->{$tbl}->{-cols};
$fpk = $flds->{$arg{-pk}} if $arg{-pk};
$fts = $flds->{$arg{-timestamp}} if $arg{-timestamp};
foreach my $fn (sort keys %$flds) {
lib/ARSObject.pm view on Meta::CPAN
}
}
}
$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}
}
sub smtp { # SMTP connection object
return($_[0]->{-smtp}) if $_[0]->{-smtp};
smtpconnect(@_)
}
sub smtpsend { # SMTP mail msg send
# -from||-sender, -to||-recipient,
# -data|| -subject + (-text || -html)
my ($s, %a) =@_;
return(&{$s->{-die}}("SMTP host not defined"))
if !$s->{-smtphost};
local $s->{-smtpdomain} =$s->{-smtpdomain}
|| ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()}))
|| 'nothing.net';
$a{-from} =$a{-from} ||$a{-sender} ||$ENV{REMOTE_USER} ||$ENV{USERNAME};
$a{-from} =&{$a{-from}}($s,\%a) if ref($a{-from}) eq 'CODE';
$a{-to} =&{$a{-to}}($s,\%a) if ref($a{-to}) eq 'CODE';
$a{-to} =[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})]
if $a{-to} && !ref($a{-to}) && ($a{-to} =~/[,;]/);
$a{-sender} =$a{-sender} ||$a{-from};
$a{-recipient} =$a{-recipient} ||$a{-to};
$a{-recipient} =&{$a{-recipient}}($s,\%a) if ref($a{-recipient}) eq 'CODE';
$a{-recipient} =[grep {$_} split /\s*[,;]\s*/, ($a{-recipient} =~/^\s*(.*)\s*$/ ? $1 : $a{-recipient})]
if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/);
return(&{$s->{-die}}("SMTP e-mail recipients not defined"))
if !$a{-recipient};
if (!defined($a{-data})) {
my $koi =(($a{-charset}||$s->charset()||'') =~/1251/);
$a{-subject} = ref($a{-subject}) eq 'CODE'
? &{$a{-subject}}($s,\%a)
: 'ARSObject'
if ref($a{-subject}) ||!defined($a{-subject});
$a{-data} ='';
$a{-data} .='From: ' .($koi ? $s->cptran('ansi','koi',$a{-from})
: $a{-from})
."\cM\cJ";
$a{-data} .='Subject: '
.($koi
? $s->cptran('ansi','koi',$a{-subject})
: $a{-subject}) ."\cM\cJ";
$a{-data} .='To: '
.($koi
? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to})
: (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}))
."\cM\cJ"
if $a{-to};
foreach my $k (keys %a) {
next if $k =~/^-(data|subject|html|text|from|to|sender|recipient)$/;
next if !defined($a{$k});
my $n =$k =~/^-(.+)/ ? ucfirst($1) .':' : $k;
$a{-data} .=$n .' ' .$a{$k} ."\cM\cJ";
}
$a{-data} .="MIME-Version: 1.0\cM\cJ";
$a{-data} .='Content-type: ' .($a{-html} ? 'text/html' : 'text/plain')
.'; charset=' .($a{-charset}||$s->charset())
."\cM\cJ";
$a{-data} .='Content-Transfer-Encoding: ' .($a{-encoding} ||'8bit') ."\cM\cJ";
$a{-data} .="\cM\cJ";
$a{-data} .=$a{-html} ||$a{-text} ||'';
}
local $^W=undef;
$s->smtp->mail($a{-sender} =~/<\s*([^<>]+)\s*>/ ? $1 : $a{-sender})
||return(&{$s->{-die}}("SMTP sender \'" .$a{-sender} ."' -> " .($s->smtp->message()||'?')));
$s->smtp->to(ref($a{-recipient})
? (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})
: $a{-recipient}, {'SkipBad'=>1}) # , {'SkipBad'=>1}
|| return(&{$s->{-die}}("SMTP recipient \'"
.(ref($a{-recipient}) ? join(', ', (map { !$_ ? () : /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}})) : $a{-recipient}) ."' -> " .($s->smtp->message()||'?')));
$s->smtp->data($a{-data})
||return(&{$s->{-die}}("SMTP data '" .$a{-data} ."' -> " .($s->smtp->message()||'?')));
my $r =$s->smtp->dataend()
||return(&{$s->{-die}}("SMTP dataend -> " .($s->smtp->message()||'?')));
$r ||1;
}
sub soon { # Periodical execution of this script
# (minutes ||sub{}, ?log file, ?run command, ?soon command)
# minutes: undef - clear sched, run once || sub{} -> number
# log file: empty || full file name || var file name
# run command: empty || 'command line' || [command line] || sub{}
# soon command: empty || 'command line' || [command line] || []
# empty run command - only soon command will be scheduled
# empty soon command - sleep(minutes*60) will be used
# !defined(minutes) - soon command will be deleted from schedule
# 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)) {
print "Already '$q', done.\n";
$s->fstore(">>$lf", "\n" .$s->strtime() ."\t$$\tAlready '$q', done.\n")
if $lf;
return(0);
}
}
_sooncln($s, $mm, $lf, $wl ? '' : $cr, $cs, 1);
}
lib/ARSObject.pm view on Meta::CPAN
}
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}
, %{$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);
( run in 0.526 second using v1.01-cache-2.11-cpan-e1769b4cff6 )