ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
# (err/var, command, operation, function, args)
sub efmt {
efmt1(@_)
}
sub efmt0 {
my ($s, $e, $c, $o, $f, @a) =@_;
cpcon($s
,join(': '
,($c ? $c : ())
,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
,($o ? $o : ())
)
.($e && ($e eq '$!') && $^E ? (' -> ' .$! .' / ' .$^E) : ( ' -> ' .($e || 'unknown error')))
)
}
sub efmt1 {
my ($s, $e, $c, $o, $f, @a) =@_;
cpcon($s
,join(' # '
,($e && ($e eq '$!') && $^E ? ($! .' / ' .$^E) : ($e || 'unknown error'))
,($o ? $o : ())
,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
,($c ? $c : ())
)
)
}
sub strquot { # Quote and Escape string enclosing in ''
my $v =$_[1]; # (string) -> escaped
return('undef') if !defined($v);
$v =~s/([\\'])/\\$1/g;
lib/ARSObject.pm view on Meta::CPAN
$v =~/^\d+$/ ? $v : ('"' .$v .'"');
}
sub dsquot { # Quote data structure
$#_ <2 # (self, ?'=>', data struct)
? dsquot($_[0],'=> ',$_[1])
: !ref($_[2]) # (, hash delim, value) -> stringified
? strquot($_[0],$_[2])
: ref($_[2]) eq 'ARRAY'
? '[' .join(', ', map {dsquot(@_[0..1],$_)
} @{$_[2]}) .']'
: ref($_[2]) eq 'HASH'
? '{' .join(', ', map {$_ .$_[1] .dsquot(@_[0..1],$_[2]->{$_})
} sort keys %{$_[2]}) .'}'
: strquot($_[0],$_[2])
}
sub dsquot1 { # Quote data structure, defined elements only
$#_ <2 # (self, ?'=>', data struct)
? dsquot1($_[0],'=> ',$_[1])
: !ref($_[2]) # (, hash delim, value) -> stringified
? strquot($_[0],$_[2])
: ref($_[2]) eq 'ARRAY'
? '[' .join(', ', map {defined($_) ? dsquot1(@_[0..1],$_) : ()
} @{$_[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);
lib/ARSObject.pm view on Meta::CPAN
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';
return(dsquot($s,$ds1) cmp dsquot($s,$ds2)) if ref($ds1) eq 'HASH';
$ds1 cmp $ds2
}
sub dsunique { # Unique list
my %h =(map {defined($_) ? ($_ => 1) : ()} @_[1..$#_]);
use locale;
sort keys %h
}
sub dsmerge { # Merge arrays or hashes
my $r;
if (ref($_[1]) eq 'ARRAY') {
$r =[];
lib/ARSObject.pm view on Meta::CPAN
$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])) {
&{$s->{-warn}}('Not defined time in timestr()') if $^W;
return(undef)
lib/ARSObject.pm view on Meta::CPAN
$_[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
$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;
lib/ARSObject.pm view on Meta::CPAN
# 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) {
my $fm =ARS::ars_GetField($s->{-ctrl},$f,$ff{$ff})
|| return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetField',$f,$ff)));
# 'fieldId', 'fieldName', 'dataType'
next if !$fm->{dataType}
|| ($fm->{dataType} =~/^(trim|control|table|column|page)/);
next if !$s->{-schfdo} && $fm->{option} && ($fm->{option} == 4); # AR_FIELD_OPTION_DISPLAY
$s->{-meta}->{$f}->{-fields}->{$ff} =$fm;
$s->{-meta}->{$f}->{-fields}->{$ff}->{indexUnique} =$fm->{fieldId}
if $ix->{$fm->{fieldId}}
|| ($fm->{fieldId} eq '1'); # || '179'?
if ($fm->{displayInstanceList}->{dInstanceList}
) {
# foreach my $i (defined($vli) || defined($vll) ? (map {defined($_) ? $_ : ()} $vli, $vll) : (0..$#{$fm->{displayInstanceList}->{dInstanceList}})) {
for (my $i =0; $i <=$#{$fm->{displayInstanceList}->{dInstanceList}}; $i++) {
next if !$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props};
for(my $j =0; $j <=$#{$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}}; $j++) {
my $prp =$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}->[$j]->{prop};
if ($prp ==20) {
# $i == vui id
# prop == 20 == AR_DPROP_LABEL
my $v =$fm->{displayInstanceList}->{dInstanceList}->[$i]->{props}->[$j]->{value};
$fm->{fieldLbl} =$v
if 1
lib/ARSObject.pm view on Meta::CPAN
if ($ff && !$ff->{-hashOut} && ($ff->{dataType} eq 'enum')) {
my $et =ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'
? $ff->{'limit'}->{'enumLimits'}
: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}
? $ff->{'limit'}->{'enumLimits'}->{'regularList'}
: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}
? $ff->{'limit'}->{'enumLimits'}->{'customList'}
: undef;
if (!$et) {}
elsif (!ref($et->[0])) {
$ff->{-hashOut} ={map {($_ => $et->[$_])} (0..$#$et)}
}
elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
$ff->{-hashOut} ={map {($et->[$_]->{itemNumber} => $et->[$_]->{itemName})} (0..$#$et)}
}
}
$ff && $ff->{-hashOut}
}
sub schlblsl { # Enum field {values => labels localised}
# (schema, fieldId) -> {value=>localised label,...}
my($s,$f,$ff) =@_;
lib/ARSObject.pm view on Meta::CPAN
: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}
? $ff->{'limit'}->{'enumLimits'}->{'regularList'}
: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}
? $ff->{'limit'}->{'enumLimits'}->{'customList'}
: undef;
if (!$et) {}
elsif (!ref($et->[0])) {
$ff->{-listVals} =[0..$#$et]
}
elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
$ff->{-listVals} =[map {$et->[$_]->{itemNumber}} (0..$#$et)]
}
}
$ff && $ff->{-listVals}
}
sub strOut { # Convert field value for output, using '-meta'
# (schema, fieldId, fieldValue) -> fieldValue
my($s,$f,$ff,$v) =@_;
lib/ARSObject.pm view on Meta::CPAN
elsif ($ff->{dataType} eq 'enum') {
my $et = ref($ff->{'limit'}->{'enumLimits'}) eq 'ARRAY'
? $ff->{'limit'}->{'enumLimits'}
: exists $ff->{'limit'}->{'enumLimits'}->{'regularList'}
? $ff->{'limit'}->{'enumLimits'}->{'regularList'}
: exists $ff->{'limit'}->{'enumLimits'}->{'customList'}
? $ff->{'limit'}->{'enumLimits'}->{'customList'}
: undef;
if (!$et) {}
elsif (!ref($et->[0])) {
$ff->{-hashIn} ={map {($et->[$_] => $_)} (0..$#$et)};
$v =strIn(@_);
}
elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
$ff->{-hashIn} ={map {($et->[$_]->{itemName} => $et->[$_]->{itemNumber})} (0..$#$et)};
$v =strIn(@_);
}
else {
$et =undef
}
return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strIn',$f,$ff->{fieldName},$v)))
if $et && ($v !~/^\d+$/);
}
elsif ($ff->{dataType} eq 'time') {
$v =timestr($s,$v);
}
$v
}
sub lsflds { # List fields from '-meta'
# (additional field options)
my ($s, @a) =@_;
@a =('fieldLblc') if !@a;
unshift @a, 'fieldName', 'fieldId', 'dataType', 'option', 'createMode';
map { my $f =$_;
$f =~/^-/
? ()
: map { my $ff =$s->{-meta}->{$f}->{-fields}->{$_};
join("\t", $f
#, $ff->{option} && ($ff->{option} == 4) ? 'ro' : ()
, (map { $_ eq 'fieldLblc'
? join('; '
, map {$ff->{$_} ? $ff->{$_} : ()
} $ff->{$_} ? ('fieldLblc') : ('fieldLbl', 'fieldLbll'), 'fieldLbv', 'fieldLbvl', 'helpText')
: !defined($ff->{$_})
? ''
: $_ eq 'option'
? (!$ff->{$_} ? '' : $ff->{$_} == 4 ? 'r' : $ff->{$_} == 2 ? 'o' : $ff->{$_} == 1 ? 'm' : '')
: $ff->{$_}
} @a[0..$#a]))
} sort keys %{$s->{-meta}->{$f}->{-fields}}
} sort keys %{$s->{-meta}}
}
lib/ARSObject.pm view on Meta::CPAN
my $s =shift;
my %a =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-from};
my $c =$a{-for} ||$a{-foreach};
if ($a{-fields} && !ref($a{-fields})) {
my $q ='trim|control|table|column|page';
$q .= '|currency|attach' if $a{-fields} =~/^-\$/;
$q .= '|attach' if $a{-fields} =~/^-f/;
$a{-fields} =
[map { my $ff =$s->{-meta}->{$f}->{-fields}->{$_};
!$ff->{dataType} || !$ff->{fieldId}
|| ($ff->{dataType} =~/^($q)/)
|| ($ff->{fieldId} eq '15') # 'Status-History'
# ars_GetListEntryWithFields() -> [ERROR] (ORA-00904: "C15": invalid identifier) (ARERR #552)
|| (!$a{-xfields} ? 0 : ref($a{-xfields}) eq 'CODE' ? &{$a{-xfields}}($s, $ff) : grep {($_ eq $ff->{fieldId}) || ($_ eq $ff->{fieldName})} @{$a{-xfields}})
? ()
: ($ff->{fieldId})
} sort keys %{$s->{-meta}->{$f}->{-fields}}]
}
$a{-fetch} =1 if $a{-fields} && !ref($a{-fields});
delete $a{-fields} if $a{-fetch};
local $s->{-cmd} ="query(" .join(', ',map {!defined($a{$_}) ? () : ref($a{$_}) ? "$_=>" .dsquot($s,$a{$_}) : ("$_=>" .strquot($s,$a{$_}))
} qw(-schema -form -from -fields -fetch -qual -query -where -sort -order -limit -max -maxRetrieve -first -start))
.")";
my $fl = ref($a{-fetch})
? [map {/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}} @{$a{-fetch}}]
: $a{-fields} && ref($a{-fields}->[0])
? [map {ref($_)
? {fieldId=>$_->{fieldId} ||schdn($s,$f, $_->{fieldName} ||$_->{field})->{fieldId}
, separator=>$_->{separator} ||"\t"
, columnWidth=>$_->{columnWidth} ||$_->{width} ||10
}
: {fieldId=>/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}
, separator=>"\t"
, columnWidth=>10
}
} @{$a{-fields}}]
: $a{-fields}
? [map {/^\d+$/ ? $_ : schdn($s,$f,$_)->{fieldId}} @{$a{-fields}}]
: [];
my @fs;
{my ($v, $x, @r) =($a{-sort} ||$a{-order});
@fs = $v
? (map {if (!$x) {$x =$_; @r=()}
elsif(/^(desc|2)$/) {@r =($x=~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 2); $x =undef}
else {@r=($x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId},1); $x=undef if /^(asc|1)$/}
@r} @$v)
: ();
push @fs, $x =~/^\d+$/ ? $x : schdn($s,$f,$x)->{fieldId}, 1
if $x}
my $q =$s->_qsubst('',$a{-qual} ||$a{-query} ||$a{-where}, $f);
$s->{-cmd} .=": subst(-from=>'$f'"
.(@$fl ? ',-fields=>' .join(', ', map {ref($_) ? "'" .$_->{fieldId} ."'(" .$_->{columnWidth} .")" : "'$_'"
} @$fl) : '')
.($q ? ",-where=>$q" : '')
.(@fs ? ',-order=>' .join(', ', map {"'$_'"} @fs) : '')
.")"
if 0;
$q =ARS::ars_LoadQualifier($s->{-ctrl}, $f, $q);
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd})))
if !$q;
$s->{-cmd} .=": qual". $s->dsquot(ARS::ars_perl_qualifier($s->{-ctrl}, $q))
if 0;
print $s->cpcon(join(";\n", split /\):\s/, $s->{-cmd})), "\n"
if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
lib/ARSObject.pm view on Meta::CPAN
# no ars_EncodeDiary(diaryEntryHash1, ... diaryEntryHashN)
# encoded 'Status-History'
# decoded 'diary'
#
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-from};
print $s->cpcon("entry(-form=>'$f',-id=>'$a{-id}')\n")
if $s->{-echo} || $a{-echo};
my %r =ARS::ars_GetEntry($s->{-ctrl},$f,$a{-id}
,$a{-fields}
? (map {/^\d+$/ ? $_ : schdn($s, $f, $_)->{fieldId}} @{$a{-fields}})
: ()
);
if (%r) {
my $rr =$a{-for} ||{};
undef(@{$rr}{keys %$rr}) if %$rr;
# @{$rr}{map {schid($s,$f,$_)->{fieldName}} keys %r} =values %r;
# return($rr);
local $_;
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entry(-form=>'$f',-id=>'$a{-id}')";
foreach my $id (keys %r) {
my $ff =schdi($s,$f,$id);
if ($ff) {
$rr->{$ff->{fieldName}}
= !$s->{-strFields}
? $r{$id}
: $ff->{strOut}
lib/ARSObject.pm view on Meta::CPAN
sub entryNew { # New {field => value}
# (-form=>form, field=>value,...) -> {field=>value,...}
# ?'Incident Number'=>1 for 'HPD:Help Desk'
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-into} ||$a{-for};
delete @a{qw(-schema -form -from -into -for)};
local $_;
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entryNew(-form=>'$f',"
.join(',', map {!defined($a{$_})
? "$_=>undef"
: ref($a{$_})
? ("$_=>" .dsquot($s, $a{$_}))
: ("$_=>" .strquot($s, $a{$_}))
} sort keys %a)
.')';
foreach my $k (%{$s->{-meta}->{$f}->{-fields}}) {
my $ff =$s->{-meta}->{$f}->{-fields}->{$k};
next if !$ff
|| exists($a{$k})
lib/ARSObject.pm view on Meta::CPAN
# ?-echo=>1
# ?'Incident Number'=>1 for 'HPD:Help Desk'
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-into};
my $r;
print $s->cpcon("entryIns(-form=>'$f')\n")
if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
delete @a{qw(-schema -form -from -into -echo)};
local $_;
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '') ."entryIns(-form=>'$f',"
.join(',', map {!defined($a{$_})
? "$_=>undef"
: ref($a{$_})
? ("$_=>" .dsquot($s, $a{$_}))
: ("$_=>" .strquot($s, $a{$_}))
} sort keys %a)
.')';
%a = map { my ($k, $v) =($_, $a{$_});
if ($k !~/^\d+$/) {
my $ff =schdn($s,$f,$k);
$k =$ff->{fieldId};
$v =$ff->{strIn}
? &{$ff->{strIn}}($s,$f,$ff,$_=$v)
: strIn($s,$f,$k,$v)
if $s->{-strFields};
}
($k => $v)
} keys %a;
lib/ARSObject.pm view on Meta::CPAN
#
my ($s, %a) =@_;
my $f =$a{-schema} ||$a{-form} ||$a{-into};
my $id=$a{-id};
print $s->cpcon("entryUpd(-form=>'$f',-id=>'$id')\n")
if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
delete @a{qw(-schema -form -from -into -id -echo)};
local $_;
local $s->{-cmd} =($s->{-cmd} ? $s->{-cmd} .': ' : '')
."entryUpd(-form=>'$f',-id=>'$id',"
.join(',', map {!defined($a{$_})
? "$_=>undef"
: ref($a{$_})
? ("$_=>" .dsquot($s, $a{$_}))
: ("$_=>" .strquot($s, $a{$_}))
} sort keys %a)
.')';
%a = map { my ($k, $v) =($_, $a{$_});
if ($k !~/^\d+$/) {
my $ff =schdn($s,$f,$k);
$k =$ff->{fieldId};
$v =$ff->{strIn}
? &{$ff->{strIn}}($s,$f,$ff,$_=$v)
: strIn($s,$f,$k,$v)
if $s->{-strFields}
}
($k => $v)
} keys %a;
lib/ARSObject.pm view on Meta::CPAN
}
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'};
lib/ARSObject.pm view on Meta::CPAN
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'));
}
}
lib/ARSObject.pm view on Meta::CPAN
# $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) {
next if !$flds->{$fn}->{fieldName} || !$flds->{$fn}->{COLUMN_NAME}
|| !$flds->{$fn}->{TYPE_NAME};
$fpk =$flds->{$fn} if !$fpk && $flds->{$fn}->{IS_PK}
&& ($flds->{$fn}->{IS_PK} eq '1');
lib/ARSObject.pm view on Meta::CPAN
my ($rd, @rq) =({});
while (($rd && ($rd =$dbq->fetchrow_hashref())) ||scalar(@rq)) {
if ($rd) {
push @rq, $rd;
next if scalar(@rq) <$arg{-lim_or};
}
else {
next if !scalar(@rq)
}
my $arq =join(' OR '
, map { $_->{$fpk->{COLUMN_NAME}}
&& ($_->{_arsobject_update} ||$_->{_arsobject_delete})
? "'" .$fpk->{fieldName} ."'=" .$s->arsquot($_->{$fpk->{COLUMN_NAME}})
: () } @rq);
my %ars =$arq
? map { ($_->{$fpk->{fieldName}} => $_)
} $s->query(-form=>$arg{-form}
,-fields=>$arg{-fields}
,-echo=>$arg{-echo}
,-query=>join(' AND '
, $arg{-query} ? '(' .$arg{-query} .')' : ()
, "($arq)"))
: ();
foreach my $rd (@rq) {
my $ra =$ars{$rd->{$fpk->{COLUMN_NAME}}};
my $rw ={};
lib/ARSObject.pm view on Meta::CPAN
&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
sleep($arg{-sleep} ||0);
$cd++;
$s->entryDel(-form=>$arg{-form}, -echo=>$arg{-echo}
,-id=>$rd->{$fid->{COLUMN_NAME}});
}
elsif ($rd->{_arsobject_update}) {
$rd->{_arsobject_insert} =$rd->{_arsobject_delete} =undef;
next if $arg{-filter}
&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
$rw ={map { !defined($rw->{$_}) && !defined($ra->{$_})
? ()
: !defined($rw->{$_}) ||!defined($ra->{$_})
? ($_ => $rw->{$_})
: $rw->{$_} ne $ra->{$_}
? ($_ => $rw->{$_})
: ()
} keys %$rw}
if $ra;
if (scalar(%$rw)) {
sleep($arg{-sleep} ||0);
lib/ARSObject.pm view on Meta::CPAN
, %$rw);
}
}
elsif ($rd->{_arsobject_insert}) {
$rd->{_arsobject_update} =$rd->{_arsobject_delete} =undef;
next if $arg{-filter}
&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
sleep($arg{-sleep} ||0);
$ci++;
$s->entryIns(-form=>$arg{-form}, -echo=>$arg{-echo}
, map {defined($rw->{$_}) ? ($_ => $rw->{$_}) : ()} keys %$rw);
}
my $sql = $rd->{_arsobject_insert} || $rd->{_arsobject_delete}
? ('DELETE FROM ' .$tbc
.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rd->{$fpk->{COLUMN_NAME}}))
: ('UPDATE ' .$tbc .' SET '
.join(', ', map { !exists($rd->{$_})
? ()
: ($s->{-dbi}->quote_identifier($_) .' =NULL')
} '_arsobject_insert','_arsobject_update', '_arsobject_delete')
.' WHERE ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .' =' .$s->{-dbi}->quote($rd->{$fpk->{COLUMN_NAME}}));
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}));
}
@rq =();
}
}
if ($arg{-ckdel}) {
my $cnl ='';
my $dbr =[];
while ($dbr) {
my $sql ='SELECT ' .$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME})
.' FROM ' .$tbc
.($cnl ||$s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert}
? ' WHERE ' .join(' AND ', map {$_ ? "($_)" : ()
} ($s->{'-meta-sql'}->{$tbl}->{-cols}->{_arsobject_insert} ? '_arsobject_insert IS NULL OR _arsobject_insert=0' : '')
, ($cnl ? $s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .'<=' .$s->{-dbi}->quote($cnl) : ''))
: '')
.' ORDER BY 1 desc';
print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
my $dbq =$s->dbiquery($sql);
my @cnd;
my @rms;
while (($dbr && ($dbr =$dbq->fetchrow_arrayref())) ||scalar(@cnd)) {
if ($dbr) {
push @cnd, $dbr->[0] =~/^([^\s]+)/i ? $1 : $dbr->[0];
}
if ($dbr ? scalar(@cnd) >=$arg{-lim_or} : scalar(@cnd)) {
my %ars =map { ($_->{$fpk->{fieldName}} => 1)
} $s->query(-form=>$arg{-form}
,-fields=>[$fpk->{fieldName}]
,-echo=>$arg{-echo}
,-query=>join(' AND '
, $arg{-query} ? '(' .$arg{-query} .')' : ()
, '(' .join(' OR ', map {"'" .$fpk->{fieldName} ."'=" .$s->arsquot($_)
} @cnd) .')')
);
my @del =map { $ars{$_}
? ()
: !$arg{-filter} || &{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},undef,$_)
? $_
: ()
} @cnd;
if (scalar(@del)) {
$cnl =$del[$#del];
$sql ="DELETE FROM $tbc WHERE "
.join(' OR ', map {$s->{-dbi}->quote_identifier($fpk->{COLUMN_NAME}) .'=' .$s->{-dbi}->quote($_)
} @del);
push @rms, $sql;
$cd +=scalar(@del);
}
@cnd =();
sleep($arg{-sleep} ||0);
if (scalar(@del)) {
$dbq->finish();
last;
}
lib/ARSObject.pm view on Meta::CPAN
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 ';
lib/ARSObject.pm view on Meta::CPAN
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}};
lib/ARSObject.pm view on Meta::CPAN
&& (defined($rd->{$f->{COLUMN_NAME}})
? !defined($rw->{$f->{fieldName}})
|| ($rd->{$f->{COLUMN_NAME}} ne $rw->{$f->{fieldName}})
: defined($rw->{$f->{fieldName}}));
}
if (!$rd) {
next if $arg{-filter}
&& !&{$arg{-filter}}($s,\%arg,$s->{'-meta-sql'}->{$tbl},$rw,$rd);
$sql ='INSERT INTO ' .$tbc .' ('
.join(', '
, map { !exists($rw->{$_->{fieldName}})
|| !defined($rw->{$_->{fieldName}})
? ()
: $s->{-dbi}->quote_identifier($_->{COLUMN_NAME})
} @flds)
.') VALUES ('
.join(', '
, map { !exists($rw->{$_->{fieldName}})
|| !defined($rw->{$_->{fieldName}})
? ()
: $s->{-dbi}->quote($rw->{$_->{fieldName}})
} @flds)
.')';
$ci++;
}
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++
}
lib/ARSObject.pm view on Meta::CPAN
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}}) {
lib/ARSObject.pm view on Meta::CPAN
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
lib/ARSObject.pm view on Meta::CPAN
.($_[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"
lib/ARSObject.pm view on Meta::CPAN
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()
}
lib/ARSObject.pm view on Meta::CPAN
.'; 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)
lib/ARSObject.pm view on Meta::CPAN
my ($s, $cs, $q) =@_;
my $nc;
my $qry =$cs;
if (ref($cs)) {
return(&{$s->{-die}}("MSWin32 required for `at` in soon()\n"))
if $^O ne 'MSWin32';
$cs->[0] =Win32::GetFullPathName($cs->[0])
if ($^O eq 'MSWin32') && ($cs->[0] !~/[\\\/]/);
$cs->[0] = $cs->[0]=~/^(.+?)[^\\\/]+$/ ? $1 .'perl.exe' : $cs->[0]
if $cs->[0] =~/\.dll$/i;
$qry =$q ? join(' ', map { $nc
? ()
: !defined($_)
? '""'
: ref($_)
? (do{$nc =$_->[0]})
: $_
} @$cs)
: join(' ', map {!defined($_) ? '""' : ref($_) ? join('', @$_) : $_
} @$cs);
}
$qry
}
sub _sooncln { # soon() cleaner
my ($s, $mm, $lf, $cr, $cs, $strt) =@_;
$lf =$s->vfname($lf) if $lf && ($lf !~/[\\\/]/);
if (ref($cs) ? scalar(@$cs) : $cs) {
lib/ARSObject.pm view on Meta::CPAN
}
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}})
if !$f;
$f =$s->{-fphc}->{$f} ||$s->{-fphd}->{$f}
if !ref($f);
!ref($f) || (ref($f) ne 'HASH')
? 0
: ( !exists($f->{-used})
? 1
: !$f->{-used}
? 0
: (ref($f->{-used}) eq 'CODE')
lib/ARSObject.pm view on Meta::CPAN
$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;
}
elsif ($ae eq 'vfentry') { # -preact
lib/ARSObject.pm view on Meta::CPAN
}
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}) {
}
lib/ARSObject.pm view on Meta::CPAN
}
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"}) {
lib/ARSObject.pm view on Meta::CPAN
$i++
}
splice(@$fa, $i, 1);
$s->vfstore($fs);
$s->vfclear($fs);
}
}
elsif ($ae eq 'entrySave') { # -action
my $a =cfpvv($s,$f) ? 'entryUpd' : cfpvp($s,$f) ? 'entryDel' : 'entryIns';
if ($a eq 'entryIns') { # $vy= 1 if cfpvv($s,$f)
map { &$ffc($s, $_) ||(exists($_->{-entryIns}) && !$_->{-entryIns})
? ()
: ($_->{-namedb} => &$fvu($s, $_))
} cfpused($s);
$a = $vy
? $a
: ($a eq 'entryIns')
? ''
: ($a eq 'entryUpd') && cfpvp($s,$f)
? 'entryDel'
: $a;
}
$s->{-cgi}->param($f->{-namecgi}, cfpvp($s,$f))
if ($a eq 'entryDel') && $f->{-namecgi};
$r =!$a
? 1
: ref($act) eq 'HASH'
? cfpaction($s, {%$act, -action => $a}, @_[2..$#_])
: cfpaction($s, $a, @_[2..$#_])
}
if ((ref($r) eq 'HASH') && ($ord eq '-preact')) {
foreach my $f1 (map { &$ffc($s, $_) || !$_->{-namecgi}
? ()
: ($_)
} @{$s->{-fpl}}) {
next if !exists($r->{$f1->{-namedb}});
my $u =$s->cfpused($f1);
my $v =$r->{$f1->{-namedb}};
if (defined($v)
|| defined($s->{-cgi}->param($f1->{-namecgi}))) {
$s->{-cgi}->param($f1->{-namecgi}, $v);
$s->{-cgi}->param($f1->{-namecgi} .'__C_', '')
lib/ARSObject.pm view on Meta::CPAN
: !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
lib/ARSObject.pm view on Meta::CPAN
. (!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})
);
}
( run in 0.313 second using v1.01-cache-2.11-cpan-49f99fa48dc )