Result:
found more than 680 distributions - search limited to the first 2001 files matching your query
( run in 0.734 )
API-GitForge
view release on metacpan or search on metacpan
lib/API/GitForge/Role/GitForge.pm view on Meta::CPAN
my $temp = tempdir CLEANUP => 1;
my $git = Git::Wrapper->new($temp);
$git->init;
my @fork_branches
= map { m#refs/heads/#; $' } $git->ls_remote("--heads", $fork_uri);
return $fork_uri if grep /\Agitforge\z/, @fork_branches;
open my $fh, ">", catfile $temp, "README.md";
say $fh "This repository exists only in order to submit pull request(s).";
close $fh;
API-Google
view release on metacpan or search on metacpan
lib/API/Google/GCal.pm view on Meta::CPAN
});
if ($fields) {
my @a;
for my $item (@{$res->{items}}) {
push @a, { map { $_ => $item->{$_} } grep { exists $item->{$_} } @$fields };
}
return \@a;
} else {
return $res;
}
API-Handle
view release on metacpan or search on metacpan
lib/API/Handle.pm view on Meta::CPAN
sub _join_uri {
my ( $self, @path ) = @_;
my ( $base ) = ( $self->uri );
@path = map { $_ =~ s/^\///; $_ =~ s/\/$//; $_ } @path;
$base =~ s/\/$//;
return join '/', $base, @path;
}
API-INSEE-Sirene
view release on metacpan or search on metacpan
lib/API/INSEE/Sirene.pm view on Meta::CPAN
sub _buildFields {
my ($self, $usefull_fields, $desired_fields) = @_;
if (defined $desired_fields) {
return $self->_mapAliases($desired_fields);
}
else {
return join ',', @{ $usefull_fields };
}
}
sub _mapAliases {
my ($self, $desired_fields) = @_;
my @desired_fields = ref $desired_fields eq 'ARRAY' ? @{ $desired_fields } : $desired_fields;
foreach my $desired_field (@desired_fields) {
API-ISPManager
view release on metacpan or search on metacpan
lib/API/ISPManager.pm view on Meta::CPAN
my $params = shift;
return '' unless $params &&
ref $params eq 'HASH' && %$params ;
my $result = join '&', map { "$_=$params->{$_}" } sort keys %$params;
warn $result if $DEBUG;
return $result;
}
API-Instagram
view release on metacpan or search on metacpan
lib/API/Instagram.pm view on Meta::CPAN
for ( @auth_fields ) {
carp "ERROR: $_ required for generating authorization URL" and return unless defined $self->$_;
}
my $uri = URI->new( $self->_authorize_url );
$uri->query_form( map { $_ => $self->$_ } @auth_fields );
$uri->as_string();
}
sub get_access_token {
lib/API/Instagram.pm view on Meta::CPAN
my @access_token_fields = qw(client_id redirect_uri grant_type client_secret code);
for ( @access_token_fields ) {
carp "ERROR: $_ required for generating access token." and return unless defined $self->$_;
}
my $data = { map { $_ => $self->$_ } @access_token_fields };
my $json = $self->_request( 'post', $self->_access_token_url, $data, { token_not_required => 1 } );
wantarray ? ( $json->{access_token}, $self->user( $json->{user} ) ) : $json->{access_token};
}
lib/API/Instagram.pm view on Meta::CPAN
###################################
sub _medias {
my ($self, $url, $params, $opts) = @_;
$params->{count} //= 33;
$params->{url} = $url;
[ map { $self->media($_) } $self->_get_list( { %$params, url => $url }, $opts ) ]
}
####################################################################
# Returns a list of the requested items. Does pagination if needed #
####################################################################
API-MailboxOrg
view release on metacpan or search on metacpan
lib/API/MailboxOrg/Types.pm view on Meta::CPAN
my @keys = @_;
croak "Need a list of valid keys" if !@keys;
my %valid_keys = map { $_ => 1 } @keys;
return sub {
return if ref $_ ne 'HASH';
return 1 if !$_->%*;
lib/API/MailboxOrg/Types.pm view on Meta::CPAN
use Moo;
use API::MailboxOrg::Types qw(Boolean HashRefRestricted);
has true_or_false => ( is => 'ro', isa => Boolean, coerce => 1 );
has map => ( is => 'ro', isa => HashRefRestricted[qw(a b)] ); # allow only keys a and b
1;
}
my $obj = TestClass->new(
true_or_false => 1, # 0|1|""|undef|JSON::PP::Boolean object
map => {
a => 1,
b => 1,
# a key 'c' would cause a 'die'
},
);
API-Medium
view release on metacpan or search on metacpan
t/00-compile.t view on Meta::CPAN
for my $lib (@module_files)
{
# see L<perlfaq8/How can I capture STDERR from an external command?>
my $stderr = IO::Handle->new;
diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} }
$^X, @switches, '-e', "require q[$lib]"))
if $ENV{PERL_COMPILE_TEST_DEBUG};
my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]");
binmode $stderr, ':crlf' if $^O eq 'MSWin32';
API-MikroTik
view release on metacpan or search on metacpan
lib/API/MikroTik/Query.pm view on Meta::CPAN
}
sub _block {
my ($logic, $items) = @_;
@{($items = [])} = map { $_ => $items->{$_} } sort keys %$items
if ref $items eq 'HASH';
my ($count, @words) = (0, ());
while (my $el = shift @$items) {
API-Octopart
view release on metacpan or search on metacpan
lib/API/Octopart.pm view on Meta::CPAN
=back
=cut
our %valid_opts = map { $_ => 1 } qw/token include_specs cache cache_age ua_debug query_limit json_debug/;
sub new
{
my ($class, %args) = @_;
foreach my $arg (keys %args)
lib/API/Octopart.pm view on Meta::CPAN
}
}
));
}
our %_valid_filter_opts = ( map { $_ => 1 } (qw/currency max_moq min_qty max_price mfg seller/) );
sub _parse_part_stock
{
my ($self, $resp, %opts) = @_;
foreach my $o (keys %opts)
lib/API/Octopart.pm view on Meta::CPAN
$part{mfg} = $r->{manufacturer}{name};
if (defined $r->{specs})
{
$part{specs} = {
# Try to map first by shortname, then by unit, then by value if
# the former are undefined:
map {
defined($_->{attribute}{shortname})
? ($_->{attribute}{shortname} => $_->{value} . "$_->{units}")
: (
$_->{units}
? ($_->{units} => $_->{value})
API-ParallelsWPB
view release on metacpan or search on metacpan
lib/API/ParallelsWPB.pm view on Meta::CPAN
debug => 0,
timeout => 30,
(@_)
};
map { confess "Field '" . $_ . "' required!" unless $self->{ $_ } } qw/username password server/;
return bless $self, $class;
}
# "free" request. Basic method for requests
API-Plesk
view release on metacpan or search on metacpan
lib/API/Plesk.pm view on Meta::CPAN
API::Plesk::User
=head1 COMPATIBILITY WITH VERSION 1.*
This is develover release. Comapatibility with Plesk::API 1.* is not implemented yet.
=head1 METHODS
=over 3
API-Vultr
view release on metacpan or search on metacpan
t/01-test.t view on Meta::CPAN
"prev": ""
}
}
}';
$vultr_api->ua->map_response(
qr{api.vultr.com/v2/applications},
HTTP::Response->new(
'200', 'OK',
[ 'Content-Type' => 'application/json' ], $application_json
)
t/01-test.t view on Meta::CPAN
'https://api.vultr.com/v2/applications';
ok $vultr_api->ua->last_http_response_received->is_success;
is $vultr_api->ua->last_http_response_received->decoded_content,
$application_json;
$vultr_api->ua->map_response(
qr{api.vultr.com/v2/instances},
HTTP::Response->new(
'200', 'OK',
[ 'Content-Type' => 'application/json' ], $application_json
)
APISchema
view release on metacpan or search on metacpan
lib/APISchema/DSL.pm view on Meta::CPAN
# cpan
use Exporter 'import';
use Path::Class qw(file);
my %schema_meta = (
( map { $_ => "${_}_resource" } qw(request response) ),
( map { $_ => $_ } qw(title description destination option) ),
);
our %METHODS = (
( map { $_ => $_ } qw(HEAD GET POST PUT DELETE PATCH) ),
FETCH => [qw(GET HEAD)],
);
our @DIRECTIVES = (qw(include filter resource title description), keys %METHODS);
our @EXPORT = @DIRECTIVES;
lib/APISchema/DSL.pm view on Meta::CPAN
};
local $_directive->{resource} = sub {
$schema->register_resource(@_);
};
local @$_directive{keys %METHODS} = map {
my $m = $_;
sub {
my ($path, @args) = @_;
for my $filter (reverse @filters) {
local $Carp::CarpLevel += 1;
@args = $filter->(@args);
}
my ($definition, $option) = @args;
$schema->register_route(
( map {
defined $definition->{$_} ?
( $schema_meta{$_} => $definition->{$_} ) : ();
} keys %schema_meta ),
defined $option ? (option => $option) : (),
route => $path,
APNS-Agent
view release on metacpan or search on metacpan
lib/APNS/Agent.pm view on Meta::CPAN
alert => decode_utf8($alert),
};
}
return [400, [], ['BAD REQUEST']] unless $payload;
my @payloads = map {[$_, $payload]} split /,/, $token;
push @{$self->_queue}, @payloads;
infof "event:payload queued\ttoken:%s", $token;
if ($self->__apns->connected) {
$self->_sending;
APR-Emulate-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
APR-HTTP-Headers-Compat
view release on metacpan or search on metacpan
inc/MyBuilder.pm view on Meta::CPAN
sub ACTION_tidy {
my $self = shift;
my @extra = qw( Build.PL );
my %found_files = map { %$_ } $self->find_pm_files,
$self->_find_file_by_type( 'pm', 't' ),
$self->_find_file_by_type( 'pm', 'inc' ),
$self->_find_file_by_type( 't', 't' );
my @files = ( keys %found_files,
map { $self->localize_file_path( $_ ) } @extra );
for my $file ( @files ) {
system 'perltidy', '-b', $file;
unlink "$file.bak" if $? == 0;
}
ARCv2
view release on metacpan or search on metacpan
lib/Arc/Connection.pm view on Meta::CPAN
substr($buf,0,0) = $partial;
my @buf1 = split (/\015?\012/,$buf,-1);
$partial = pop @buf1;
push(@{$this->{__linequeue}}, map { "$_\n" } @buf1);
} else {
$this->{_connected} = 0;
$this->{_connection}->close();
# if timed out,
return $this->_SetError("Connection timed out.");
ARGV-Abs
view release on metacpan or search on metacpan
lib/ARGV/Abs.pm view on Meta::CPAN
my $base = $_[1];
unless (defined $base) {
require Cwd;
$base = Cwd::getcwd();
}
@ARGV = map { File::Spec->rel2abs($_, $base) } @ARGV;
}
1;
=head1 NAME
ARGV-URL
view release on metacpan or search on metacpan
lib/ARGV/URL.pm view on Meta::CPAN
}
sub import
{
# Inspired from L<perlopentut>
@ARGV = map { m#^[a-z]{2,}://# ? qq#lwp-request -m GET "$_" |# : $_ } @ARGV;
}
1;
=head1 NAME
ARS-Simple
view release on metacpan or search on metacpan
lib/ARS/Simple.pm view on Meta::CPAN
=head2 update_record
Update a record on a form based on the Entry-Id (eid). The
data to update is defined in the lvp (label value pair) hash reference.
The other required argument is the lfid (label FID) hash reference which
is used to map the labels to field Ids (FID).
The method returns true on success and carps on error.
update_record({
eid => $eID, # The Entry-Id/Request-Id to update
lib/ARS/Simple.pm view on Meta::CPAN
B<NOT DONE YET>
The lfid array used by the get_data_by_label() method
required that a hash is defined which describes the
field lables (names) you want to use mapped to the
field ID (FID). The encluded script will construct
such a hash for all relavent fields. You might like
to edit this down to only those fields you really need
thereby reducing the amount of data returned.
ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
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')))
)
}
lib/ARSObject.pm view on Meta::CPAN
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 : ())
)
)
}
lib/ARSObject.pm view on Meta::CPAN
$#_ <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])
}
lib/ARSObject.pm view on Meta::CPAN
$#_ <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])
}
lib/ARSObject.pm view on Meta::CPAN
$ds1 cmp $ds2
}
sub dsunique { # Unique list
my %h =(map {defined($_) ? ($_ => 1) : ()} @_[1..$#_]);
use locale;
sort keys %h
}
lib/ARSObject.pm view on Meta::CPAN
$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
}
lib/ARSObject.pm view on Meta::CPAN
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;
}
lib/ARSObject.pm view on Meta::CPAN
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];
}
lib/ARSObject.pm view on Meta::CPAN
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
}
lib/ARSObject.pm view on Meta::CPAN
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)));
lib/ARSObject.pm view on Meta::CPAN
$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) {
lib/ARSObject.pm view on Meta::CPAN
: 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}
}
lib/ARSObject.pm view on Meta::CPAN
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}
}
lib/ARSObject.pm view on Meta::CPAN
: 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
}
lib/ARSObject.pm view on Meta::CPAN
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' : '')
lib/ARSObject.pm view on Meta::CPAN
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}})
lib/ARSObject.pm view on Meta::CPAN
}
$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;
lib/ARSObject.pm view on Meta::CPAN
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);
lib/ARSObject.pm view on Meta::CPAN
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)
lib/ARSObject.pm view on Meta::CPAN
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)
lib/ARSObject.pm view on Meta::CPAN
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)
lib/ARSObject.pm view on Meta::CPAN
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
}
lib/ARSObject.pm view on Meta::CPAN
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()};
lib/ARSObject.pm view on Meta::CPAN
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"
lib/ARSObject.pm view on Meta::CPAN
: ()
} sort keys %{$s->{'-meta-sql'}->{$tbl}->{-cols}})
.')'
}
else {
my $dbc ={map {
!$_ ||!$_->{COLUMN_NAME}
? ()
: (lc($_->{COLUMN_NAME}) => $_)
} $s->dbicols('',$tbl)};
if (scalar(%$dbc)) {
lib/ARSObject.pm view on Meta::CPAN
}
}
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) {
lib/ARSObject.pm view on Meta::CPAN
# $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};
lib/ARSObject.pm view on Meta::CPAN
}
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} .')' : ()
lib/ARSObject.pm view on Meta::CPAN
}
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->{$_})
lib/ARSObject.pm view on Meta::CPAN
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};
lib/ARSObject.pm view on Meta::CPAN
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};
lib/ARSObject.pm view on Meta::CPAN
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 =();
lib/ARSObject.pm view on Meta::CPAN
}
}
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()
lib/ARSObject.pm view on Meta::CPAN
$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)
lib/ARSObject.pm view on Meta::CPAN
,-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
lib/ARSObject.pm view on Meta::CPAN
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)
.')';
lib/ARSObject.pm view on Meta::CPAN
.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}})
lib/ARSObject.pm view on Meta::CPAN
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
lib/ARSObject.pm view on Meta::CPAN
# -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)
: '')
lib/ARSObject.pm view on Meta::CPAN
|| ($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->{$_})
lib/ARSObject.pm view on Meta::CPAN
.'}}'};
($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))
lib/ARSObject.pm view on Meta::CPAN
."<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($_)
? ''
lib/ARSObject.pm view on Meta::CPAN
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"
lib/ARSObject.pm view on Meta::CPAN
}
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;
lib/ARSObject.pm view on Meta::CPAN
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
}
lib/ARSObject.pm view on Meta::CPAN
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
lib/ARSObject.pm view on Meta::CPAN
}
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}}}
)}
}
lib/ARSObject.pm view on Meta::CPAN
}
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);
lib/ARSObject.pm view on Meta::CPAN
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);
lib/ARSObject.pm view on Meta::CPAN
}
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) {
lib/ARSObject.pm view on Meta::CPAN
}
}
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
lib/ARSObject.pm view on Meta::CPAN
: 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);
lib/ARSObject.pm view on Meta::CPAN
? ''
: 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 ='';
lib/ARSObject.pm view on Meta::CPAN
? ''
: 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}
lib/ARSObject.pm view on Meta::CPAN
)
: ( $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}
? ''
ARSperl
view release on metacpan or search on metacpan
# where Open is enum 0 and Closed is enum 1, this routine will return:
#
# $retval[0]->{USER} = the user to last selected this enum
# $retval[1]->{TIME} = the time that this enum was last selected
#
# You can map from enum values to selection words by using
# arsGetField().
sub ars_decodeStatusHistory {
my ($sval) = shift;
my ($enum) = 0;
ASNMTAP
view release on metacpan or search on metacpan
applications/htmlroot/cgi-bin/moderator/generateCollectorDaemonSchedulingReport.pl view on Meta::CPAN
# Set the horizontal ticks and grid lines to be between the bars
$c->xAxis()->setTickOffset(0.5);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Use a red hash pattern as the color for the actual dates. The pattern is created as a 4 x 4 bitmap defined in memory as an array of colors.
my $actualColor = $c->patternColor([0xFF000000, 0xFF000000, 0xFF000000, 0xff0000, 0xFF000000, 0xFF000000, 0xff0000, 0xFF000000, 0xFF000000, 0xff0000, 0xFF000000, 0xFF000000, 0xff0000, 0xFF000000, 0xFF000000, 0xFF000000], 4);
# Add a box whisker layer to represent the actual dates. We add the actual dates layer first, so it will be the top layer.
my $actualLayer = $c->addBoxLayer(\@actualStartDate, \@actualEndDate, $actualColor, "Actual");
$actualLayer->setXData(\@dataPoints);
ASP
view release on metacpan or search on metacpan
The same as C<Print> except the output is HTML-encoded so that
any HTML tags appear as sent, i.e. E<lt> becomes <, E<gt> becomes > etc.
=cut
sub HTMLPrint { map { ASP::Print($main::Server->HTMLEncode($_)) } @_ ; }
=head2 die LIST
Prints the contents of LIST to the browser and then exits. die
automatically calls $Response->End for you, it also executes any
Escapes (URL-encodes) a list. Uses ASP object method
$Server->URLEncode().
=cut
sub escape { map { $main::Server->URLEncode($_) } @_; }
=head2 unescape LIST
Unescapes a URL-encoded list. Algorithms ripped from CGI.pm
method of the same name.
=cut
sub unescape {
map {
tr/+/ /;
s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
} @_;
}
=cut
sub unescapeHTML {
my ($flag, @args) = (0, @_);
@args = @{$args[0]} and $flag++ if ref $args[0] eq "ARRAY";
map {
s/&/&/gi;
s/"/"/gi;
s/ / /gi;
s/>/>/gi;
s/</</gi;
ASP4-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
ASP4
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
ASP4x-Captcha-Imager
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
ASP4x-Linker
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
ASP4x-Router
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
( run in 0.734 second using v1.01-cache-2.11-cpan-49f99fa48dc )