Result:
found more than 457 distributions - search limited to the first 2001 files matching your query
( run in 1.906 )
API-Docker
view release on metacpan or search on metacpan
lib/API/Docker.pm view on Meta::CPAN
);
has api_version => (
is => 'rwp',
default => undef,
);
has tls => (
is => 'lazy',
lib/API/Docker.pm view on Meta::CPAN
B<Read only when L</tls> is set.> The default comes from the environment, and
C<DOCKER_CERT_PATH> is exported on plenty of machines that run the C<docker>
CLI, so a client that never asked for TLS is unaffected by having it set. A
TLS client that wants the system trust store rather than the CLI's private one
on such a machine passes C<< cert_path => undef >> explicitly.
=head2 tls_insecure
Turn certificate verification off. Default C<0>. Only read when L</tls> is
set, and named for what it does.
API-Drip-Request
view release on metacpan or search on metacpan
lib/API/Drip/Request.pm view on Meta::CPAN
use JSON;
use URI;
use Data::Printer;
Readonly our %DEFAULTS => (
DRIP_TOKEN => undef,
DRIP_ID => undef,
DRIP_URI => 'https://api.getdrip.com/v2',
DRIP_AGENT => 'API::Drip',
DRIP_DEBUG => 0,
);
lib/API/Drip/Request.pm view on Meta::CPAN
=back
On success, returns a Perl data structure corresponding to the data returned
from the server. Some operations (DELETE), do not return any data and may
return undef on success. On error, this method will die() with the
HTTP::Response object.
=cut
my $request_validator = validation_for( params => [ {type => Str()}, {type => Str()}, {type => HashRef(), optional => 1} ] );
lib/API/Drip/Request.pm view on Meta::CPAN
die $result;
}
if ( $result->code == 204 ) {
$self->{debugger}->("Success, no content");
return undef;
}
my $decoded = eval {decode_json( $result->content )};
if ( $@ ) {
$self->{debugger}->('Failed to decode JSON:', $@, $result->content);
die $result;
API-Eulerian
view release on metacpan or search on metacpan
lib/API/Eulerian/EDW/Bench.pm view on Meta::CPAN
#
sub new
{
return bless( {
_SUITE => {},
_LAST => undef,
_FIRST => undef,
}, shift );
}
#
# @brief Start chronograph.
#
API-GitForge
view release on metacpan or search on metacpan
lib/API/GitForge/GitHub.pm view on Meta::CPAN
return "https://github.com/$user/$repo";
}
sub _assert_fork_has_parent {
my ($self, $upstream) = @_;
my (undef, $repo) = _extract_repo($upstream);
my $user = $self->{_api}->user->show->{login};
my $fork = $self->{_api}->repos->get($user, $repo);
$fork->{parent}{full_name} eq $upstream
or croak
lib/API/GitForge/GitHub.pm view on Meta::CPAN
});
}
sub _clean_config_fork {
my ($self, $upstream) = @_;
my (undef, $repo) = _extract_repo($upstream);
my $user = $self->{_api}->user->show->{login};
my $repos = $self->{_api}->repos;
$repos->set_default_user_repo($user, $repo);
$repos->update({
lib/API/GitForge/GitHub.pm view on Meta::CPAN
}
sub _nuke_fork {
my ($self, $upstream) = @_;
$self->_assert_fork_has_parent($upstream);
my (undef, $repo) = _extract_repo($upstream);
my $user = $self->{_api}->user->show->{login};
$self->{_api}->repos->delete($user, $repo);
}
sub _extract_repo {
API-Google
view release on metacpan or search on metacpan
lib/API/Google/Server.pm view on Meta::CPAN
# }
# }
# }
# warn 'JWK key with particular kid not found';
# return undef;
# };
API-INSEE-Sirene
view release on metacpan or search on metacpan
lib/API/INSEE/Sirene.pm view on Meta::CPAN
my $class = shift;
my ($credentials, $timeout, $max_results, $proxy) = @_;
my $self = bless {
credentials => $credentials,
user_agent => undef,
token_expiration => undef,
max_results => undef,
debug_mode => 0,
current_endpoint => undef,
}, $class;
$self->_initUserAgent();
$self->setProxy($proxy);
$self->setMaxResults($max_results);
lib/API/INSEE/Sirene.pm view on Meta::CPAN
my $criteria1 = $sirene->getCustomCriteria('numeroVoieEtablissement', 42);
You can choose between three search modes: 'exact', 'begin' or 'approximate' match. Default is 'approximate'.
my $criteria2 = $sirene->getCustomCriteria('libelleVoieEtablissement', 'avenue', undef, 'exact');
B<< Important: >> You must specify the endpoint to be reached B<< before >> calling the C<< getCustomCriteria >> method using C<< setCurrentEndpoint >>
$sirene->setCurrentEndpoint('siret');
API-ISPManager
view release on metacpan or search on metacpan
lib/API/ISPManager.pm view on Meta::CPAN
} else {
return '';
}
}
# Wrapper for "ref" on undef value, without warnings :)
# Possible very stupid sub :)
# STATIC(REF: our_ref)
sub refs {
my $ref = shift;
API-Instagram
view release on metacpan or search on metacpan
Change: 3d4f7c2554f544dfbf1607279d96ad908ec7a483
Author: Gabriel Vieira <gabriel.vieira@gmail.com>
Date : 2014-08-17 11:26:38 +0000
Fixed profile_picture method on API::Instagram::User. Objects
creation returns undef when Instagram returns an error during
request. API::Instagram::User keeps user previous data when attempt
to reload fails. Starting version 0.007.
Change: ee143d09d124ba0f37b4710008b43d79d786ff73
Author: Gabriel Vieira <gabriel.vieira@gmail.com>
API-MailboxOrg
view release on metacpan or search on metacpan
lib/API/MailboxOrg/Types.pm view on Meta::CPAN
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'
},
lib/API/MailboxOrg/Types.pm view on Meta::CPAN
=over 4
=item * String/Integer to boolean
The values "" (empty string), I<undef>, 0, and 1 are coerced to C<JSON::PP::Boolean> objects.
=back
=head1 AUTHOR
API-MikroTik
view release on metacpan or search on metacpan
lib/API/MikroTik.pm view on Meta::CPAN
sub DESTROY { Mojo::Util::_global_destruction() or shift->_cleanup() }
sub cancel {
my $cb = ref $_[-1] eq 'CODE' ? pop : sub { };
return shift->_command(Mojo::IOLoop->singleton, '/cancel', {'tag' => shift},
undef, $cb);
}
sub command {
my $cb = ref $_[-1] eq 'CODE' ? pop : undef;
my ($self, $cmd, $attr, $query) = @_;
# non-blocking
return $self->_command(Mojo::IOLoop->singleton, $cmd, $attr, $query, $cb)
if $cb;
lib/API/MikroTik.pm view on Meta::CPAN
my ($self, $loop, $cb) = @_;
warn "-- trying to log in\n" if DEBUG;
$loop->delay(
sub {
$self->_command($loop, '/login', {}, undef, $_[0]->begin());
},
sub {
my ($delay, $err, $res) = @_;
return $self->$cb($err) if $err;
my $secret
= md5_sum("\x00", $self->password, pack 'H*', $res->[0]{ret});
$self->_command($loop, '/login',
{name => $self->user, response => "00$secret"},
undef, $delay->begin());
},
sub {
$self->$cb($_[1]);
},
);
lib/API/MikroTik.pm view on Meta::CPAN
for (@$list) {...}
});
# Omit attributes
$api->command('/user/print', undef, {name => 'admin'} => sub {...});
# Errors handling
$list = $api->command('/random/command');
if (my $err = $api->error) {
die "Error: $err, category: " . $list->[0]{category};
API-Octopart
view release on metacpan or search on metacpan
lib/API/Octopart.pm view on Meta::CPAN
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}
API-Plesk
view release on metacpan or search on metacpan
}), '<?xml version="1.0" encoding="UTF-8"?><packet version="1.6.3.0"><webspace><add><gen_setup><qq>ddd</qq><name>sample.com</name><ddd><lll>1234567</lll></ddd></gen_setup><hosting><value>erty</value><name>123</name></hosting></add></webspace></packet...
is ( $api->render_xml({ prop => [
{value1 => '0'},
{value2 => ''},
{value3 => undef},
]}), '<?xml version="1.0" encoding="UTF-8"?><packet version="1.6.3.0"><prop><value1>0</value1><value2/><value3/></prop></packet>', 'render_xml');
# compoments
$api = API::Plesk->new(
api_version => '1.6.3.1',
API-PleskExpand
view release on metacpan or search on metacpan
lib/API/PleskExpand.pm view on Meta::CPAN
=cut
sub new {
(undef) = shift @_;
my $self = __PACKAGE__->SUPER::new(@_);
$self->{package_name} = __PACKAGE__;
unless ($self->{api_version}) {
$self->{api_version} = '2.2.4.1';
API-PureStorage
view release on metacpan or search on metacpan
lib/API/PureStorage.pm view on Meta::CPAN
my $api_version = $api_versions{'1.4'} ? '1.4' :
$api_versions{'1.3'} ? '1.3' :
$api_versions{'1.1'} ? '1.1' :
$api_versions{'1.0'} ? '1.0' :
undef;
unless ( $api_version ) {
die "API version 1.3 or 1.4 is not supported by host: $self->{host}\n";
}
API-Twitter
view release on metacpan or search on metacpan
lib/API/Twitter.pm view on Meta::CPAN
my $oauth_timestamp = time,
my $oauth_token = $access_token,
my $oauth_version = '1.0';
# oauth object
my $base = $url->clone; $base->query(undef);
my $oauth = Net::OAuth->request($self->oauth_type)->new(%$params,
version => '1.0',
consumer_key => $consumer_key,
consumer_secret => $consumer_secret,
request_method => uc($req->method),
API-Vultr
view release on metacpan or search on metacpan
lib/API/Vultr.pm view on Meta::CPAN
}
sub get_instance_by_id {
my ( $self, $id ) = @_;
croak qq{ID cannot be undefined when calling get_instance_by_id.}
unless defined $id;
return $self->_request( 'get', $self->_make_uri( '/instances/' . $id ) );
}
sub delete_instance_by_id {
my ( $self, $id ) = @_;
croak qq{ID cannot be undefined when calling get_instance_by_id.}
unless defined $id;
return $self->_request( 'delete', $self->_make_uri( '/instances/' . $id ) );
}
sub halt_instances {
my ( $self, @ids ) = @_;
croak qq{Expected list of ids, instead got undef.}
unless @ids;
return $self->_request(
'post',
$self->_make_uri('/instances/halt'),
lib/API/Vultr.pm view on Meta::CPAN
}
sub reboot_instances {
my ( $self, @ids ) = @_;
croak qq{Expected list of ids, instead got undef.}
unless @ids;
return $self->_request(
'post',
$self->_make_uri('/instances/reboot'),
lib/API/Vultr.pm view on Meta::CPAN
}
sub start_instances {
my ( $self, @ids ) = @_;
croak qq{Expected list of ids, instead got undef.}
unless @ids;
return $self->_request(
'post',
$self->_make_uri('/instances/start'),
APISchema
view release on metacpan or search on metacpan
lib/APISchema/Generator/Markdown.pm view on Meta::CPAN
sub new {
my ($class) = @_;
my $renderer = Text::MicroTemplate::DataSection->new(
escape_func => undef
);
bless {
renderer => $renderer,
map {
( $_ => $renderer->build_file($_) );
APNS-Agent
view release on metacpan or search on metacpan
lib/APNS/Agent.pm view on Meta::CPAN
my $t; $t = AnyEvent->timer(
after => 0,
interval => 10,
cb => sub {
undef $t;
infof "event:reconnect";
$self->_connect_to_apns;
},
);
warnf "event:error\tfatal:$fatal\tmessage:$message";
lib/APNS/Agent.pm view on Meta::CPAN
infof "event:close apns";
}
},
);
}
else { undef }
}
sub _sending {
my $self = shift;
lib/APNS/Agent.pm view on Meta::CPAN
aps => $payload,
});
};
if (my $err = $@) {
if ($err =~ m!Can't call method "push_write" on an undefined value!) {
# AnyEvent::APNS->handle is missing
delete $self->{_send_timer};
unshift @{ $self->_queue }, [$token, $payload];
$self->_connect_to_apns;
}
APP-REST-RestTestSuite
view release on metacpan or search on metacpan
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
my ( $self, %args ) = @_;
if ( $self->{test_cases} ) {
return %{ $self->{test_cases} };
} else {
return undef;
}
}
=head2 get_log_file_handle
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
=cut
sub validate_test_cases {
my ($self) = shift;
my $err = undef;
unless (@_) {
$err = "There is no test cases defined to execute.\n";
} elsif ( ( (@_) % 2 ) == 1 ) {
$err =
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
$ua->timeout(90); # in seconds
$ua->default_header('Accept' => '*/*'); # to get cross platform support
my ( $config, $total, $total_response_time, $skip, $pass, $fail ) = (0) x 6;
my ( $uri, $method, $req_content_type, $req_body, $status ) = (undef) x 5;
my ( $request, $response ) = (undef) x 2;
my ( $username, $password ) = (undef) x 2;
$username = $self->{username};
$password = $self->{password};
my $fh = $self->get_log_file_handle();
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
$pua->timeout(60); # in seconds
$pua->redirect(1); # follow redirects
$pua->default_header('Accept' => '*/*'); # to get cross platform support
my ( $config, $total, $total_response_time, $skip, $pass, $fail ) = (0) x 6;
my ( $uri, $method, $req_content_type, $req_body, $status ) = (undef) x 5;
my ( $request, $response ) = (undef) x 2;
my ( $username, $password ) = (undef) x 2;
$username = $self->{username};
$password = $self->{password};
my $fh = $self->get_log_file_handle();
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
my $fh = $self->get_config_file_handle();
my @buffer = ();
my @start_end_buffer = ();
my ( $start_case, $end_case, $test_no ) = (undef) x 3;
my ( $start_common, $end_common ) = (undef) x 2;
my ( $start_http_code, $end_http_code ) = (undef) x 2;
my ( $start_tag, $lines_between, $end_tag ) = (undef) x 3;
my $separator = ":"; # separator used in config file for key/value pair
my %start_end_hash;
my $file = $self->{file};
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
}
sub _open_fh {
my ( $self, %args ) = @_;
my ( $fh, $err ) = (undef) x 2;
my $file = $args{FILE};
my $mode = $args{MODE};
if ( $mode =~ m/READ/i ) {
lib/APP/REST/RestTestSuite.pm view on Meta::CPAN
}
sub _compare_arrays {
my ( $first, $second ) = @_;
no warnings; # silence spurious -w undef complaints
return 0 unless @$first == @$second;
for ( my $i = 0 ; $i < @$first ; $i++ ) {
return 0 if $first->[$i] ne $second->[$i];
}
return 1;
APR-Emulate-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '1.06';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
inc/Module/Install.pm view on Meta::CPAN
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2012 Adam Kennedy.
APR-HTTP-Headers-Compat
view release on metacpan or search on metacpan
t/compat/base/headers.t view on Meta::CPAN
is( $h->header( "Foo" ), 1 );
is( $h->header( "FOO" ), 1 );
is( j( $h->header( "foo" ) ), 1 );
is( $h->header( "foo-bar" ), 3 );
is( $h->header( "foo_bar" ), 3 );
is( $h->header( "Not-There" ), undef );
is( j( $h->header( "Not-There" ) ), "" );
is( eval { $h->header }, undef );
ok( $@ );
is( $h->header( "Foo", 11 ), 1 );
is( $h->header( "Foo", [ 1, 1 ] ), 11 );
is( $h->header( "Foo" ), "1, 1" );
is( j( $h->header( "Foo" ) ), "1|1" );
is( $h->header( foo => 11, Foo => 12, bar => 22 ), 2 );
is( $h->header( "Foo" ), "11, 12" );
is( $h->header( "Bar" ), 22 );
is( $h->header( "Bar", undef ), 22 );
is( j( $h->header( "bar", 22 ) ), "" );
$h->push_header( Bar => 22 );
is( $h->header( "Bar" ), "22, 22" );
$h->push_header( Bar => [ 23 .. 25 ] );
t/compat/base/headers.t view on Meta::CPAN
$h2->remove_content_headers;
is( $h->as_string, $h2->as_string );
$h->clear;
is( $h->as_string, "" );
undef( $h2 );
$h = mk;
is( $h->header_field_names, 0 );
is( j( $h->header_field_names ), "" );
t/compat/base/headers.t view on Meta::CPAN
}
# CONVENIENCE METHODS
$h = mk;
is( $h->date, undef );
is( $h->date( time ), undef );
is( j( $h->header_field_names ), "Date" );
ok( $h->header( "Date" ) =~ /^[A-Z][a-z][a-z], \d\d .* GMT$/ );
{
my $off = time - $h->date;
ok( $off == 0 || $off == 1 );
t/compat/base/headers.t view on Meta::CPAN
for my $field (
qw(expires if_modified_since if_unmodified_since
last_modified)
) {
eval <<'EOT'; die $@ if $@;
is($h->$field, undef);
is($h->$field(time), undef);
ok((time - $h->$field) =~ /^[01]$/);
EOT
}
is( j( $h->header_field_names ),
"Date|If-Modified-Since|If-Unmodified-Since|Expires|Last-Modified"
t/compat/base/headers.t view on Meta::CPAN
ok( $h->content_is_xhtml );
ok( $h->content_is_xml );
is( $h->content_type( "text/html;\n charSet = \"ISO-8859-1\"; Foo=1 " ),
"application/xhtml+xml" );
is( $h->content_encoding, undef );
is( $h->content_encoding( "gzip" ), undef );
is( $h->content_encoding, "gzip" );
is( j( $h->header_field_names ), "Content-Encoding|Content-Type" );
is( $h->content_language, undef );
is( $h->content_language( "no" ), undef );
is( $h->content_language, "no" );
is( $h->title, undef );
is( $h->title( "This is a test" ), undef );
is( $h->title, "This is a test" );
is( $h->user_agent, undef );
is( $h->user_agent( "Mozilla/1.2" ), undef );
is( $h->user_agent, "Mozilla/1.2" );
is( $h->server, undef );
is( $h->server( "Apache/2.1" ), undef );
is( $h->server, "Apache/2.1" );
is( $h->from( "Gisle\@ActiveState.com" ), undef );
ok( $h->header( "from", "Gisle\@ActiveState.com" ) );
is( $h->referer( "http://www.example.com" ), undef );
is( $h->referer, "http://www.example.com" );
is( $h->referrer, "http://www.example.com" );
is( $h->referer( "http://www.example.com/#bar" ),
"http://www.example.com" );
is( $h->referer, "http://www.example.com/" );
t/compat/base/headers.t view on Meta::CPAN
skip "Can't store references" => 4;
require URI;
my $u = URI->new( "http://www.example.com#bar" );
$h->referer( $u );
is( $u->as_string, "http://www.example.com#bar" );
is( $h->referer->fragment, undef );
is( $h->referrer->as_string, "http://www.example.com" );
is( $h->as_string, <<EOT);
From: Gisle\@ActiveState.com
Referer: http://www.example.com
User-Agent: Mozilla/1.2
t/compat/base/headers.t view on Meta::CPAN
Title: This is a test
EOT
}
$h->clear;
is( $h->www_authenticate( "foo" ), undef );
is( $h->www_authenticate( "bar" ), "foo" );
is( $h->www_authenticate, "bar" );
is( $h->proxy_authenticate( "foo" ), undef );
is( $h->proxy_authenticate( "bar" ), "foo" );
is( $h->proxy_authenticate, "bar" );
is( $h->authorization_basic, undef );
is( $h->authorization_basic( "u" ), undef );
is( $h->authorization_basic( "u", "p" ), "u:" );
is( $h->authorization_basic, "u:p" );
is( j( $h->authorization_basic ), "u|p" );
is( $h->authorization, "Basic dTpw" );
is( eval { $h->authorization_basic( "u2:p" ) }, undef );
ok( $@ );
is( j( $h->authorization_basic ), "u|p" );
is( $h->proxy_authorization_basic( "u2", "p2" ), undef );
is( j( $h->proxy_authorization_basic ), "u2|p2" );
is( $h->proxy_authorization, "Basic dTI6cDI=" );
is( $h->as_string, <<EOT);
Authorization: Basic dTpw
t/compat/base/headers.t view on Meta::CPAN
EOT
# Check with FALSE $HTML::Headers::TRANSLATE_UNDERSCORE
{
local ( $HTTP::Headers::TRANSLATE_UNDERSCORE );
$HTTP::Headers::TRANSLATE_UNDERSCORE = undef; # avoid -w warning
$h = mk;
$h->header( abc_abc => "foo" );
$h->header( "abc-abc" => "bar" );
t/compat/base/headers.t view on Meta::CPAN
is( j( $h->header_field_names ),
"Content-Type|:content_type|:foo_bar" );
is( $h->header( 'Content-Type' ), "text/plain" );
SKIP: {
skip "Namespace collision; can't be helped" => 1;
is( $h->header( ':Content_Type' ), undef );
}
is( $h->header( ':content_type' ), "text/html" );
is( $h->as_string, <<EOT);
Content-Type: text/plain
content_type: text/html
ARCv2
view release on metacpan or search on metacpan
sub members
{
return {
# private:
# protected:
_error => undef, # contains the error message
_syslog => 1, # log to syslog or to STDERR
# public:
loglevel => 7, # loglevel is combination of bits (1=AUTH,2=USER,4=ERR,8=CMDDEBUG,16=VERBSIDE,32=DEBUG) see _Log method
logfileprefix => "", # Prepended to every log entry
logdestination => 'syslog', # Where should all the log output go to ('stderr','syslog')
$this->{_error} = $errstr;
return;
}
## User function to get the error msg.
##out> the error message if any otherwise undef
##eg> unless (my $err = $arc->IsError()) { .. } else { print STDERR $err; }
sub IsError
{
my $this = shift;
my $ret = $this->{_error};
$this->{_error} = undef;
return $ret;
}
## Destructor
ARGV-JSON
view release on metacpan or search on metacpan
t/01_argv.t view on Meta::CPAN
use ARGV::JSON;
is_deeply [ @ARGV::JSON::Data ], [
{
'bar' => {
'baz' => undef
},
'foo' => [
1,
2,
3
t/01_argv.t view on Meta::CPAN
{}
];
is_deeply scalar <>, {
foo => [1,2,3],
bar => { baz => undef },
};
is_deeply [ <> ], [
[ 'x', 'y', 'z' ],
{},
];
is scalar <>, undef;
done_testing;
ARGV-OrDATA
view release on metacpan or search on metacpan
lib/ARGV/OrDATA.pm view on Meta::CPAN
my $package = shift;
*ARGV = *ORIG;
{ no strict 'refs';
delete ${$package . '::'}{ORIG};
}
undef *ORIG;
}
sub is_using_argv {
! is_using_data()
ARS-Simple
view release on metacpan or search on metacpan
examples/generate_fid_hash.pl view on Meta::CPAN
### Sample data for 'User' form
# my $m = {
# numMatches => 30,
# rows => [
# [ 'CreateDate' , 3, 'System RO', 'AR_DATA_TYPE_TIME', undef ],
# [ 'LastModifiedBy' , 5, 'System RO', 'AR_DATA_TYPE_CHAR', 254 ],
# [ 'ModifiedDate' , 6, 'System RO', 'AR_DATA_TYPE_TIME', undef ],
# [ 'RequestID' , 1, 'System RO', 'AR_DATA_TYPE_CHAR', 15 ],
# [ 'Creator' , 2, 'Required', 'AR_DATA_TYPE_CHAR', 254 ],
# [ 'FullName' , 8, 'Required', 'AR_DATA_TYPE_CHAR', 254 ],
# [ 'FullTextLicenseType' , 110, 'Required', 'AR_DATA_TYPE_ENUM', undef ],
# [ 'LicenseType' , 109, 'Required', 'AR_DATA_TYPE_ENUM', undef ],
# [ 'LoginName' , 101, 'Required', 'AR_DATA_TYPE_CHAR', 254 ],
# [ 'Status' , 7, 'Required', 'AR_DATA_TYPE_ENUM', undef ],
# [ 'ApplicationLicense' , 122, 'Optional', 'AR_DATA_TYPE_CHAR', 0 ],
# [ 'ApplicationLicenseType' , 115, 'Optional', 'AR_DATA_TYPE_CHAR', 254 ],
# [ 'AssignedTo' , 4, 'Optional', 'AR_DATA_TYPE_CHAR', 254 ],
# [ 'ComputedGrpList' , 119, 'Optional', 'AR_DATA_TYPE_CHAR', 255 ],
# [ 'DefaultNotifyMechanism' , 108, 'Optional', 'AR_DATA_TYPE_ENUM', undef ],
# [ 'EmailAddress' , 103, 'Optional', 'AR_DATA_TYPE_CHAR', 255 ],
# [ 'FlashboardsLicenseType' , 111, 'Optional', 'AR_DATA_TYPE_ENUM', undef ],
# [ 'FromConfig' , 250000003, 'Optional', 'AR_DATA_TYPE_CHAR', 3 ],
# [ 'GroupList' , 104, 'Optional', 'AR_DATA_TYPE_CHAR', 255 ],
# [ 'GrouplistIT' , 536870913, 'Optional', 'AR_DATA_TYPE_CHAR', 200 ],
# [ 'InstanceID' , 490000000, 'Optional', 'AR_DATA_TYPE_CHAR', 38 ],
# [ 'ModifyAll' , 536870914, 'Optional', 'AR_DATA_TYPE_ENUM', undef ],
# [ 'ObjectID' , 490000100, 'Optional', 'AR_DATA_TYPE_CHAR', 38 ],
# [ 'Password' , 102, 'Optional', 'AR_DATA_TYPE_CHAR', 30 ],
# [ 'UniqueIdentifier' , 179, 'Optional', 'AR_DATA_TYPE_CHAR', 38 ],
# [ 'AssetLicenseUsed' , 220000002, '*Unknown*', 'AR_DATA_TYPE_INTEGER', undef ],
# [ 'ChangeLicenseUsed' , 220000003, '*Unknown*', 'AR_DATA_TYPE_INTEGER', undef ],
# [ 'HelpDeskLicenseUsed' , 220000004, '*Unknown*', 'AR_DATA_TYPE_INTEGER', undef ],
# [ 'NumberofLicenseAvailable' , 220000000, '*Unknown*', 'AR_DATA_TYPE_INTEGER', undef ],
# [ 'SLALicenseUsed' , 220000001, '*Unknown*', 'AR_DATA_TYPE_INTEGER', undef ],
# ],
# };
unless ($m && $m->{numMatches})
ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
sub new { # New ARS object
# (-param=>value,...) -> ARS object
my $c=shift;
my $s ={'' => ''
,-ctrl => undef # ARS control struct from ars_Login()
,-srv => undef # Server name
,-usr => undef # User name
,-pswd => undef # Password string
,-lang => '' # Language
,-schema => undef # Schemas to use: [form,...]
,-vfbase => # Var files base
(do{ my $v =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0;
$v =~/^(.+?)\.[^\\\/]*$/ ? "$1-" : "$v-"
})
#,-storable =>undef # Use Storable module for cache files?
,-schgen => 1 # 1 - use vfname('meta') for '-meta', generate it from ARS if not exists.
# 2 - renewable 'meta' smartly
# 3 - renew meta always
# [schema,...] - list to renew
,-schfdo => 0 # Include display only fields into schema (AR_FIELD_OPTION_DISPLAY)
lib/ARSObject.pm view on Meta::CPAN
# {fieldName=>'name',FieldId=>id
# ,strIn=>sub(self,form,{field},$_=val){}
# ,strOut=>sub(self,form,{field},$_=val){}
# },...}
,-maxRetrieve => 0 # ARS::ars_GetListEntry(maxRetrieve)
,-entryNo => undef # Logical number of entry inserted
,-strFields => 1 # Translate fields data using 'strIn'/'strOut'/'-meta'?
# 1 - 'enumLimits', 2 - 'fieldLbvl' before 'enumLimits'
,-cmd =>'' # Command running, for err messages, script local $s->{-cmd}
,-die =>undef # Error die/warn, 'Carp' or 'CGI::Carp...'
# ,-diemsg => undef #
,-warn=>undef # , see set() and connect() below
# ,-warnmsg => undef #
,-cpcon=>undef # Translation to console codepage sub{}(self, args) -> translated
,-echo=>0 # Echo printout switch
,-dbi=>undef # DBI object, by dbiconnect()
,-dbiconnect =>undef #
,-cgi=>undef # CGI object, by cgi()
,-smtp=>undef
,-smtphost=>undef
#,-fpl=>[] # CGI Form Presenter fields list
#,-fphc=>{} # CGI fields cache
#,-fphd=>{} # DB fields cache
#,-fpbv=>[] # buffer values
#,-fpbn=>'' # buffer name == record common name
lib/ARSObject.pm view on Meta::CPAN
}
sub AUTOLOAD { # Use self->arsXXX() syntax for ars_XXX(ctrl,...) calls
my $m =substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return(&{$_[0]->{-die}}($_[0]->efmt("Called name without 'ars'", $_[0]->{-cmd}, undef, 'AUTOLOAD',$m)))
if $m !~/^ars/;
$m =~s/^ars/ars_/
if $m !~/^ars_/;
$m =~s/^ars/ARS::ars/
if $m !~/^ARS::/;
lib/ARSObject.pm view on Meta::CPAN
}
sub DESTROY {
my $s =shift;
$s->{-die} =undef;
$s->{-warn}=undef;
$s->{-ctrl} && eval{ars_Logoff($s->{-ctrl})};
$s->{-ctrl}=undef;
$s->{-dbi} && eval{$s->{-dbi}->disconnect()};
$s->{-dbi} =undef;
$s->{-cgi} =undef;
$s->{-diemsg} =undef;
$s->{-warnmsg} =undef;
}
sub set { # Set/Get parameters
# () -> (parameters)
lib/ARSObject.pm view on Meta::CPAN
, $s->{-cgi}->escapeHTML($_[0])
, "<br />\n"
if $s && $s->{-cgi}
}
$s->DESTROY() if $s;
$s =undef;
# $SIG{__DIE__} =$sigdie;
# &$sigdie(@_) if ref($sigdie) eq 'CODE';
# CORE::die($_[0]);
};
$SIG{__WARN__} =sub{
lib/ARSObject.pm view on Meta::CPAN
}
sub strquot { # Quote and Escape string enclosing in ''
my $v =$_[1]; # (string) -> escaped
return('undef') if !defined($v);
$v =~s/([\\'])/\\$1/g;
$v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
$v =~/^\d+$/ ? $v : ('\'' .$v .'\'');
}
sub strquot2 { # Quote and Escape string enclosing in ""
my $v =$_[1]; # (string) -> escaped
return('undef') if !defined($v);
$v =~s/([\\"])/\\$1/g;
$v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg;
$v =~/^\d+$/ ? $v : ('"' .$v .'"');
}
lib/ARSObject.pm view on Meta::CPAN
sub strtime { # Stringify Time
my $s =shift;
if (scalar(@_) && !defined($_[0])) {
&{$s->{-warn}}('Not defined time in strtime()') if $^W;
return(undef)
}
my $msk =(scalar(@_) ==0) || ($_[0] =~/^\d+$/i) ? 'yyyy-mm-dd hh:mm:ss' : shift;
my @tme =(scalar(@_) ==0) ? localtime(time) : scalar(@_) ==1 ? localtime($_[0]) : @_;
$msk =~s/yyyy/%Y/;
$msk =~s/yy/%y/;
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
}
sub timestr { # Time from String
my $s =shift;
if (scalar(@_) && !defined($_[0])) {
&{$s->{-warn}}('Not defined time in timestr()') if $^W;
return(undef)
}
my $msk =(scalar(@_) <2) || !$_[1] ? 'yyyy-mm-dd hh:mm:ss' : shift;
my $ts =$_[0];
my %th;
while ($msk =~/(yyyy|yy|mm|dd|hh|MM|ss)/) {
lib/ARSObject.pm view on Meta::CPAN
sub timeadd { # Adjust time to years, months, days,...
my $s =$_[0];
if (!defined($_[1])) {
&{$s->{-warn}}('Not defined time in timeadd()') if $^W;
return(undef)
}
my @t =localtime($_[1]);
my $i =5;
foreach my $a (@_[2..$#_]) {$t[$i] += ($a||0); $i--}
#eval('use POSIX');
lib/ARSObject.pm view on Meta::CPAN
sub fopen { # Open file
my $s =shift; # ('-b',filename) -> success
my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
my $f =$_[0]; $f ='<' .$f if $f !~/^[<>]/;
eval('use IO::File');
my $h =IO::File->new($f) || return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open file','fopen',$f)));
$h->binmode() if $h && ($o =~/b/);
$h
}
sub fdirls { # Directory listing
my $s =shift; # ('-',pathname, ?filter sub{}(self, path, $_=entry), ? []) -> (list) || [list]
my $o =$_[0] =~/^-(?:\w[\w\d+-]*)*$/ ? shift : '-';
my ($f, $cf, $cs) =@_;
local *FILE; opendir(FILE, $f) || return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open dir','fdirls',$f)));
local $_;
my ($r, @r);
if ($cs) {
while (defined($r =readdir(FILE))) {
push @$cs, $r if !$cf ||&$cf($s,$f,$_ =$r)
lib/ARSObject.pm view on Meta::CPAN
local *FILE;
for (my $i =0; $i <$fretry; $i++) {
$r =open(FILE, $f);
last if $r;
}
return(&{$s->{-die}}($s->efmt('$!',undef,'cannot open file','fstore',$f)))
if !$r;
if ($o =~/b/) {
binmode(FILE);
$r =defined(syswrite(FILE,$_[1]))
}
else {
$r =print FILE join("\n",@_[1..$#_])
}
close(FILE);
$r || &{$s->{-die}}($s->efmt('$!',undef,'Cannot write file','fstore',$f))
}
sub fload { # Load file
my $s =shift; # ('-b',filename) -> content
lib/ARSObject.pm view on Meta::CPAN
my $r;
for (my $i =0; $i <$fretry; $i++) {
$r =open(FILE, $f);
last if $r;
}
return(&{$s->{-die}}($s->efmt('$!',undef,'Cannot open file','fload',$f)))
if !$r;
my $b =undef;
binmode(FILE) if $o =~/b/;
$r =read(FILE,$b,-s $f0);
close(FILE);
defined($r) ? $b : &{$s->{-die}}($s->efmt('$!',undef,'Cannot read file','fload',$f))
}
sub vfname { # Name of variables file
# (varname|-slot) -> pathname
lib/ARSObject.pm view on Meta::CPAN
if (($n =~/^-/) && exists($s->{"${n}-storable"}) ? $s->{"${n}-storable"} : $s->{-storable}) {
for (my $i =0; ($i <$fretry) && eval("use Storable; 1"); $i++) {
$r =Storable::store($d, $f);
last if $r;
}
return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::store',$f)))
if !$r;
}
else {
$r =$s->fstore('-', $f, $s->dsdump($d));
}
lib/ARSObject.pm view on Meta::CPAN
my $rr =0;
for (my $i =0; $i <$fretry; $i++) {
$rr =rename($f, $s->vfname($n));
last if $rr
}
return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'rename',$f,'*.var')))
if !$rr
}
$r
}
sub vfload { # Load variables file
# (varname|-slot, ?{use default} | load default, ?renew | renew seconds) -> {data}
my($s,$f,$d,$nn) =@_; # -slot-calc, -slot-store
my $k =($f =~/^-/ ? $f : undef);
$f =$s->vfname($f);
if ($nn && $nn >1) {
my @st =stat($f);
$nn =0 if $st[9] && (time() -$st[9] <$nn);
}
lib/ARSObject.pm view on Meta::CPAN
}
elsif (!$k) {
}
elsif (ref($s->{"$k-calc"}) eq 'CODE') {
my $cc =$s->{"$k-calc"};
local $s->{"$k-calc"} =undef;
$s->{$k} =$d =&$cc($s,$k);
}
elsif (ref($s->{"$k-store"}) eq 'CODE') {
$s->vfstore($k, $s->{$k} =$d =&{$s->{"$k-store"}}($s,$k))
}
lib/ARSObject.pm view on Meta::CPAN
}
return($d)
}
elsif (ref($s->{"$k-calc"}) eq 'CODE') {
my $cc =$s->{"$k-calc"};
local $s->{"$k-calc"} =undef;
$s->{$k} =$d =&$cc($s,$k);
return($d);
}
my $r;
if (0) {
$r =($k && exists($s->{"${k}-storable"}) ? $s->{"${k}-storable"} : $s->{-storable})
? eval("use Storable; 1")
&& Storable::retrieve($f)
|| return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::retrieve',$f)))
: ((eval{do($f)}) || return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},undef,'do',$f))));
}
else {
local *FILE;
for (my $i =0; $i <$fretry; $i++) {
$r =open(FILE, "<$f");
last if $r;
}
return(&{$s->{-die}}($s->efmt('$!',undef,'Cannot open file','vfload',$f)))
if !$r;
binmode(FILE);
my $v;
sysread(FILE,$v,64,0)
||return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'sysread',$f)));
$r =($v
? $v !~/^\$VAR1\s*=/
: ($k && exists($s->{"${k}-storable"}) ? $s->{"${k}-storable"} : $s->{-storable}))
? ((seek(FILE,0,0) ||1)
&& eval("use Storable; 1")
&& Storable::fd_retrieve(\*FILE)
|| return(&{$s->{-die}}($s->efmt('$!',$s->{-cmd},undef,'Storable::retrieve',$f))))
: ((eval{close(FILE); 1}) &&
do($f) || return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},undef,'do',$f)))
);
eval{close(FILE)};
}
$s->{$k} =$r if $k;
$r
lib/ARSObject.pm view on Meta::CPAN
# (-slot, key name) -> {hash from vfdata()}
# (-slot, key name => key value) -> {key=>value,...}
# (-slot, key name => key value => elem name ) -> elem value
# (-slot, key name => filter sub{}(self, -slot, key, $_ = value)) -> {key=>value,...}
my($s, $f, $k, $v, $e) =@_;
return(&{$s->{-die}}($s->efmt('Key name needed',undef,undef,'vfhash',$f))) if !$k;
$s->vfload($f, 1) if !$s->{$f} ||(ref($s->{$f}) eq 'CODE');
my $kk ="$f/$k";
if (!$s->{$kk}) {
$s->{$kk} ={};
if (ref($s->{$f}) eq 'ARRAY') {
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
}
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
lib/ARSObject.pm view on Meta::CPAN
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))
lib/ARSObject.pm view on Meta::CPAN
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;
lib/ARSObject.pm view on Meta::CPAN
sub sqlname { # SQL name from ARS name
# (formName, ?fieldName, ?force update meta) -> SQL name
# -sqlname, -sqlntbl, -sqlncol, -sqlninc
my($s,$f,$ff,$fu) =@_;
return(undef)
if !$f;
return($s->{'-meta-sql'}->{-forms}->{$f})
if !$ff && !$fu
&& $s->{'-meta-sql'}
&& $s->{'-meta-sql'}->{-forms}
lib/ARSObject.pm view on Meta::CPAN
sub schid { # Schema info by field id
# (schema, fieldId) -> {fieldName=>'name', FieldId=>id}
# () -> rearranged self
$_[0]->{-metaid}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}
|| &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schid',$_[1],$_[2]))
}
sub schdn { # Schema info by field distiguished name
# (schema, fieldName) -> {fieldName=>'name', FieldId=>id}
(($_[2] =~/^\d+$/)
&& ($_[0]->{-metaid}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}))
|| $_[0]->{-metadn}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fields}->{$_[2]}
|| &{$_[0]->{-die}}($_[0]->efmt('Field not found',$_[0]->{-cmd},undef,'schdn',$_[1],$_[2]))
}
sub schdi { # Schema info by field Id
# (schema, fieldId) -> {fieldName=>'name', FieldId=>id} || undef
$_[0]->{-metaid}->{$_[2]}
|| $_[0]->{-meta}->{$_[1]}->{-fldids}->{$_[2]}
}
sub schlbls { # Enum field {values => labels}
# (schema, fieldId) -> {value=>label,...}
my($s,$f,$ff) =@_;
$ff =ref($ff) ? $ff
: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
: $s->{-meta}->{$f}->{-fields}->{$ff};
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})) {
lib/ARSObject.pm view on Meta::CPAN
sub schlblsl { # Enum field {values => labels localised}
# (schema, fieldId) -> {value=>localised label,...}
my($s,$f,$ff) =@_;
$ff =ref($ff) ? $ff
: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
: $s->{-meta}->{$f}->{-fields}->{$ff};
$ff->{fieldLbvl} ? {split /\\+/, substr($ff->{fieldLbvl},1)} : schlbls($s,$f,$ff)
}
lib/ARSObject.pm view on Meta::CPAN
sub schvals { # Enum field [values]
# (schema, fieldId) -> [value,...]
my($s,$f,$ff) =@_;
$ff =ref($ff) ? $ff
: !$s->{-meta} || !$s->{-meta}->{$f} ? return(undef)
: $ff =~/^\d+$/ ? $s->{-meta}->{$f}->{-fldids}->{$ff}
: $s->{-meta}->{$f}->{-fields}->{$ff};
if ($ff && !$ff->{-listVals} && ($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->{-listVals} =[0..$#$et]
}
elsif ((ref($et->[0]) eq 'HASH') && defined($et->[0]->{itemNumber})) {
lib/ARSObject.pm view on Meta::CPAN
elsif ($ff->{-hashOut}) {
if (exists($ff->{-hashOut}->{$v})) {
$v =$ff->{-hashOut}->{$v}
}
else {
# return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strOut',$f,$ff->{fieldName},$v)))
}
}
elsif ($ff->{dataType} eq 'enum') {
schlbls(@_);
$v =strOut(@_) if $ff->{-hashOut};
lib/ARSObject.pm view on Meta::CPAN
elsif ($ff->{-hashIn}) {
if (exists($ff->{-hashIn}->{$v})) {
$v =$ff->{-hashIn}->{$v};
}
else {
return(&{$s->{-die}}($s->efmt('Could not transate value',$s->{-cmd},undef,'strIn',$f,$ff->{fieldName},$v)))
}
}
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);
}
lib/ARSObject.pm view on Meta::CPAN
: [];
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);
lib/ARSObject.pm view on Meta::CPAN
last if $@ =~/^last[\r\n]*$/;
next if $@ =~/^next[\r\n]*$/;
return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},'eval(-for)')));
}
}
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},'undef','ars_GetListEntryWithFields')))
if !defined($id) && $ARS::ars_errstr;
return($s);
}
elsif ($c) {
my $i =undef;
local $_ ='';
foreach my $e (ARS::ars_GetListEntry($s->{-ctrl}, $f, $q
, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
, $a{-first} ||$a{-start} ||0
, $fl
lib/ARSObject.pm view on Meta::CPAN
last if $@ =~/^last[\r\n]*$/;
next if $@ =~/^next[\r\n]*$/;
return(&{$s->{-die}}($s->efmt($@,$s->{-cmd},'eval(-for)')));
}
}
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntry')))
if !defined($i) && $ARS::ars_errstr;
return($s)
}
elsif ($a{-fields} && !ref($a{-fields}->[0])) {
my @r =ARS::ars_GetListEntryWithFields($s->{-ctrl}, $f, $q
lib/ARSObject.pm view on Meta::CPAN
for (my $i =0; $i <$#r; $i +=2) {
push @rr, entryOut($s, $f, $r[$i+1])
}
return(@rr)
}
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntryWithFields')))
if $ARS::ars_errstr;
return(())
}
else {
my @r =ARS::ars_GetListEntry($s->{-ctrl}, $f, $q
lib/ARSObject.pm view on Meta::CPAN
else {
for (my $i =0; $i <$#r; $i +=2) { push @rr, $r[$i] }
}
return(@rr)
}
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'ars_GetListEntry')))
if $ARS::ars_errstr;
return(())
}
}
lib/ARSObject.pm view on Meta::CPAN
? (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) {
lib/ARSObject.pm view on Meta::CPAN
}
}
return($rr)
}
return($ARS::ars_errstr
? &{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd},undef,'entry',-form=>$f,-id=>$a{-id}))
: {})
}
sub entryOut { # Format entry hash ref for output
# (schema, entry, ?sample) -> entry
my ($s, $f, $r, $rr) =@_;
if ($rr) {
undef(@{$rr}{keys %$rr}) if %$rr;
}
else {
$rr ={}
}
local $_;
lib/ARSObject.pm view on Meta::CPAN
sub entryDif { # Diff hash refs
# ({old}, {new}, exclude empty) -> {to update}
my($s, $ds1, $ds2, $ee) =@_;
return(undef) if (ref($ds1) ||'') ne (ref($ds2) ||'');
return(undef) if (ref($ds1) ||'') ne 'HASH';
my ($r, $rr) =({});
foreach my $k (keys %$ds2) {
next if !defined($ds1->{$k}) && !defined($ds2->{$k});
next if (ref($ds1->{$k}) && ref($ds2->{$k}))
&& !dscmp($s,$ds1,$ds2);
lib/ARSObject.pm view on Meta::CPAN
&& ($ds1->{$k} eq $ds2->{$k});
next if $ee && (!defined($ds2->{$k}) ||($ds2->{$k} eq ''))
&& (!defined($ds1->{$k}) ||($ds1->{$k} eq ''));
$r->{$k} =$ds2->{$k}; $rr =1;
}
$rr ? $r : undef
}
sub entryNew { # New {field => value}
# (-form=>form, field=>value,...) -> {field=>value,...}
lib/ARSObject.pm view on Meta::CPAN
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
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)
.')';
lib/ARSObject.pm view on Meta::CPAN
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)
.')';
lib/ARSObject.pm view on Meta::CPAN
set($_[0],-die=>'Carp') if !$_[0]->{-die};
print $_[0]->cpcon("dbiconnect()\n")
if $_[0]->{-echo};
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
lib/ARSObject.pm view on Meta::CPAN
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
lib/ARSObject.pm view on Meta::CPAN
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
lib/ARSObject.pm view on Meta::CPAN
}
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)
lib/ARSObject.pm view on Meta::CPAN
}
}
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});
lib/ARSObject.pm view on Meta::CPAN
$fid =$flds->{$fn} if !$fid && $flds->{$fn}->{IS_PK}
&& ($flds->{$fn}->{IS_PK} eq '1');
$fts =$flds->{$fn} if !$fts && $flds->{$fn}->{IS_TIMESTAMP};
push @flds, $flds->{$fn};
}
!$fpk && &{$s->{-die}}($s->efmt('PK not found','',undef,'dbidsrpl',$arg{-form}));
$fts =undef if defined($arg{-timestamp}) && !$arg{-timestamp};
# !$fts && &{$s->{-die}}($s->efmt('Timestamp not found','',undef,'dbidsrpl',$arg{-form}));
}
$s->dbi() if !$s->{-dbi};
local $s->{-dbi}->{LongReadLen} =$s->{-dbi}->{LongReadLen} <= 1024 ? 4*64*1024 : $s->{-dbi}->{LongReadLen};
my $vts =$fts && $s->dbiquery('SELECT max(' .$fts->{COLUMN_NAME} .') FROM ' .$tbc)->fetchrow_arrayref();
$vts =$vts && $vts->[0];
lib/ARSObject.pm view on Meta::CPAN
: $f->{TYPE_NAME} eq 'datetime'
? timestr($s, $rd->{$f->{COLUMN_NAME}})
: $rd->{$f->{COLUMN_NAME}};
}
if ($rd->{_arsobject_delete}) {
$rd->{_arsobject_insert} =$rd->{_arsobject_update} =undef;
next if $arg{-filter}
&& !&{$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->{$_})
lib/ARSObject.pm view on Meta::CPAN
,-id=>$rd->{$fid->{COLUMN_NAME}}
, %$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}
lib/ARSObject.pm view on Meta::CPAN
: ($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}) {
lib/ARSObject.pm view on Meta::CPAN
, '(' .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];
lib/ARSObject.pm view on Meta::CPAN
}
foreach $sql (@rms) {
print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
$@ ='Unknown error';
$s->{-dbi}->do($sql)
|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));
}
}
}
if (!exists($arg{-ckupd}) || $arg{-ckupd}) {
my $sqlm=0;
lib/ARSObject.pm view on Meta::CPAN
.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]
lib/ARSObject.pm view on Meta::CPAN
: '')
.' ORDER BY ' .$s->{-dbi}->quote_identifier($mts) .' ASC '
.', ' .$s->{-dbi}->quote_identifier($mpk) .' ASC ';
print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
$lm =$s->{-dbi}->selectcol_arrayref($sql,{'MaxRows'=>$arg{-lim_rf}});
return(&{$s->{-die}}($s->efmt($s->{-dbi}->errstr, undef, undef, 'selectcol_arrayref',$sql)))
if !$lm && $s->{-dbi}->errstr;
# print $s->dsquot($lm),"\n";
# die('TEST')
# -form=>'HPD:HelpDesk_AuditLogSystem'
# ,-master=>'HPD:Help Desk', -master_pk=>'Entry ID',-master_fk=>'Original Request ID', -master_ts=>'Last Modified Date'
lib/ARSObject.pm view on Meta::CPAN
}
if ($sql) {
# local $s->{-dbi}->{LongTruncOk} =1;
print "$sql;\n" if exists($arg{-echo}) ? $arg{-echo} : $s->{-echo};
$s->{-dbi}->do($sql)
|| &{$s->{-die}}($s->efmt($s->{-dbi}->errstr,$sql,undef,'dbidsrpl',$arg{-form}));
}
}
if (!$fts && ($cs == $cw *$arg{-lim_rf})) {
sleep($arg{-sleep} ||0);
next;
lib/ARSObject.pm view on Meta::CPAN
.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'
lib/ARSObject.pm view on Meta::CPAN
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}->{$_} || $_)
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);
lib/ARSObject.pm view on Meta::CPAN
my $qi =$s->{-dbi}->quote_identifier('w') =~/^([^w]+)w/ ? $1 : '"';
my $qsq=$s->{-dbi}->quote("'w") =~/^([^w]+)w/ ? $1 : "''";
my $qiq=$s->{-dbi}->quote_identifier('"w') =~/^([^w]+)w/ ? $1 : '""';
my $qit=$qi .'.' .$qi;
my $sr ='';
my $m =undef;
while ($sf =~/^(.*?)(\Q$qs\E|\Q$qi\E)(.*)/) {
if ($2 eq $qi) {
$sr .=$1 .$2;
$sf =$3;
my ($st,$sn) =('','');
lib/ARSObject.pm view on Meta::CPAN
$ENV{PERLXS} ='PerlIS' if !$ENV{PERLXS} && ($^O eq 'MSWin32') && $0 =~/[\\\/]perlis\.dll$/i;
eval('use CGI; 1')
||return(&{$s->{-die}}($s->efmt('No CGI')));
$s->{-cgi} =$CGI::Q =$CGI::Q =eval{CGI->new(@_)}
||return($s->{-die}
? &{$s->{-die}}($s->efmt($@, undef, undef, 'cgi'))
: CORE::die($s->efmt($@, undef, undef, 'cgi')));
$s->set(-die=>'CGI::Carp fatalsToBrowser') if !$s->{-die};
return(&{$s->{-die}}($s->efmt($s->{-cgi}->{'.cgi_error'}, undef, undef, 'cgi')))
if $s->{-cgi}->{'.cgi_error'};
if (1) { # parse parameters
# __C_ change(d),
# __O_ open, __L_ listbox choise, __S_ set, __X_ close
# __P_ previous value
lib/ARSObject.pm view on Meta::CPAN
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'))
};
lib/ARSObject.pm view on Meta::CPAN
."\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}
lib/ARSObject.pm view on Meta::CPAN
}
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
lib/ARSObject.pm view on Meta::CPAN
sub cfpinit { # Field Player: init data structures
my ($s) =@_; # (self) -> self
$s->{-fphc} ={};
$s->{-fphd} ={};
my $dh ={};
my $dp =undef;
my $ah ={};
my $ak;
my $bf =undef;
foreach my $f (@{$s->{-fpl}}) {
if (ref($f) && $f->{-key} && $f->{-namecgi}) {
$ak =$f->{-namecgi};
last
}
lib/ARSObject.pm view on Meta::CPAN
$dp =$f ||'-unknown';
}
elsif (!defined($f)) {
delete $dh->{$dp};
delete $dh->{-record} if $dp eq '-formdb';
$dp =undef;
}
else {
$dh->{$dp} =$f;
delete $dh->{-record} if $dp eq '-formdb';
$dp =undef;
}
}
else {
@$f{keys %$dh} =values %$dh;
if ($f->{-metadb} && $f->{-formdb} && $s->{-meta} && $s->{-meta}->{$f->{-formdb}}) {
my $fm =$f->{-metadb};
$fm = ($fm =~/^\d+$/
? $s->{-meta}->{$f->{-formdb}}->{-fldids}->{$fm}
: $s->{-meta}->{$f->{-formdb}}->{-fields}->{$fm})
|| &{$s->{-die}}($s->efmt('Field not found',$s->{-cmd},undef,'cfpinit',$f->{-formdb},$f->{-metadb}));
$f->{-name} =$fm->{fieldName} if !$f->{-name};
$f->{-namelbl}=$fm->{fieldLbll} if !exists($f->{-namelbl});
$f->{-values} =schvals($s, $f->{-formdb}, $fm)
if !($f->{-values} ||$f->{-labels})
&& schvals($s, $f->{-formdb}, $fm);
lib/ARSObject.pm view on Meta::CPAN
if !exists($f->{-used})
&& exists($ah->{$f->{-namecgi}}->{-used});
$f->{-unused} =$ah->{$f->{-namecgi}}->{-unused}
if !exists($f->{-unused})
&& exists($ah->{$f->{-namecgi}}->{-unused});
$ah->{$f->{-namecgi}}->{-widget} =undef
if !exists($ah->{$f->{-namecgi}}->{-widget});
}
if (exists($f->{-used}) ||exists($f->{-unused})) {
}
elsif ($ak && ($f->{-action}||$f->{-preact})
lib/ARSObject.pm view on Meta::CPAN
$f->{-used} =sub{$_[0]->cgipar($ak)}
}
else {
$f->{-used} =1
}
$f->{-widget} =undef
if $f->{-preact} && !exists($f->{-widget});
$bf =1
if $f->{-action} && ($f->{-action} =~/^\d$/);
}
}
if (!$bf) {
my @bl;
foreach my $f (@{$s->{-fpl}}) {
next if ref($f) ne 'HASH';
next if !$f->{-namecgi} || !$f->{-action};
$f->{-widget} =undef;
next if exists($f->{-computed}) || exists($f->{-value})
|| !$ah->{$f->{-namecgi}};
push @bl, {%$f, -action=>1};
delete $bl[$#bl]->{-widget};
delete $ah->{$f->{-namecgi}};
lib/ARSObject.pm view on Meta::CPAN
? (ref($f->{-computed}) eq 'CODE'
? &{$f->{-computed}}($_[0], $f)
: ref($f->{-computed}) eq 'ARRAY'
? cfpv($_[0], @{$f->{-computed}})
: $f->{-computed})
: undef)
: $_[0]->{-cgi}->param($f->{-namecgi})
}
sub cfpvl { # Field Player: field values list
lib/ARSObject.pm view on Meta::CPAN
# (self, field || fieldname) -> value
my $f =ref($_[1])
? $_[1]
: ($_[0]->{-fphc}->{$_[1]} ||$_[0]->{-fphd}->{$_[1]});
!$f
? undef
: exists($f->{-computed})
? ( ref($f->{-computed}) eq 'CODE'
? &{$f->{-computed}}($_[0], $f)
: ref($f->{-computed}) eq 'ARRAY'
? cfpvv($_[0], @{$f->{-computed}})
: $f->{-computed})
: !exists($f->{-value})
? ($f->{-values} ||$f->{-labels} ? cfpvl($_[0], $f)->[0] : undef)
: ref($f->{-value}) eq 'CODE'
? &{$f->{-value}}($_[0], $f)
: ref($f->{-value}) eq 'ARRAY'
? cfpvv($_[0], @{$f->{-value}})
: $f->{-value}
lib/ARSObject.pm view on Meta::CPAN
my $r =1;
my $af=ref($act) eq 'HASH' ? $act : {};
my $ae=ref($act) eq 'HASH' ? $act->{$ord} : $act;
my $frm =$f->{-formdb}|| $af->{-formdb} ||'';
my $frn =$f->{-record}|| $af->{-record} ||'';
my $frk =undef;
my $ffc =sub{ my $f =$_[1];
!ref($f)
|| !$f->{-namedb} || $f->{-key}
|| !$f->{-formdb} || ($f->{-formdb} ne $frm)
|| (($f->{-record}||'') ne $frn)
};
my $vy =0;
my $fvu =sub{ return(undef)
if (ref($_[1]->{-values}) eq 'ARRAY')
&& !scalar(@{$_[1]->{-values}});
my $v =cfpvv(@_);
$v =undef if defined($_[1]->{-undef}) && defined($v) && ($_[1]->{-undef} eq $v);
$vy=1 if defined($v) && ($v ne '') && (!$_[1]->{-master} ||$_[1]->{-key});
$v =cfpvv($_[0], $_[1]->{-master}) if $_[1]->{-master} && !$_[1]->{-key};
return($v) if !$_[2] || (defined($_[1]->{-vftran}) && !$_[1]->{-vftran});
!defined($v)
? $v
lib/ARSObject.pm view on Meta::CPAN
local $_;
if ($frn || $s->{-fpbn}) {
my $n =$frn =~/^(.+?)\d+$/ ? $1 : $frn;
if ($n ne ($s->{-fpbn}||'')) {
$s->{-fpbn} =$n; # buffer values
$s->{-fpbv} =undef; # buffer name == record common name
if ($ae =~/^(?:vfentry|entry)$/) {
foreach my $ff (@{$s->{-fpl}}) {
next if &$ffc($s, $ff) || !$ff->{-master};
$frk =$ff;
last;
lib/ARSObject.pm view on Meta::CPAN
$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});
$r ={} if !$r;
}
elsif ($ae eq 'vfentry') { # -preact
my $fs =$f->{-vfname} ||$af->{-vfname};
my $fn =undef;
my $fv =undef;
if ($frk && $fs && ($fn =$frk->{-namedb}) && defined($fv=cfpv($s, $frk->{-master}))) {
$s->{-fpbv} =$f->{-namedb}
? $s->vfdata($fs, sub{defined($_->{$fn}) && ($_->{$fn} eq $fv)})
: [];
$r =shift @{$s->{-fpbv}} if $s->{-fpbv} && scalar(@{$s->{-fpbv}});
$r ={} if !$r;
}
elsif ($fs) {
$r =undef;
if (defined($fv=cfpv($s, $f))) {
$fn =$f->{-namedb}
}
elsif ($af->{-namedb} && ($fv =cfpv($s, $af))) {
$fn =$af->{-namedb};
}
elsif ($fn =cfpnd($s, cfpv($s, $af))) {
$fv =cfpv($s, $fn)
}
if ($fn && defined($fv)) {
$r =undef;
my $fa =$s->vfdata($fs);
foreach my $e (@$fa) {
next if !defined($e->{$fn}) || ($e->{$fn} ne $fv);
$r =$e;
last
lib/ARSObject.pm view on Meta::CPAN
$@ ="Nothing to do at 'vfentry', '-vfname' not defined"
}
}
elsif ($ae eq 'vfhash') { # -preact
my $fs =$f->{-vfname} ||$af->{-vfname};
my $fn =undef;
my $fv =undef;
if (defined($fv=cfpv($s, $f))) {
$fn =$f->{-namedb}
}
elsif ($af->{-namedb} && ($fv =cfpv($s, $af))) {
$fn =$af->{-namedb};
}
elsif ($fn =cfpnd($s, cfpv($s, $af))) {
$fv =cfpv($s, $fn)
}
$r =undef;
if (!$fs) {
$@ ="Nothing to do at 'vfhash', '-vfname' not defined"
}
elsif (!$fn) {
$@ ="Key not defined at 'vfhash'"
lib/ARSObject.pm view on Meta::CPAN
$@="Not found '$fn'=\"$fv\""
if !$r;
}
}
elsif ($ae eq 'entry') { # -preact
my $fn =undef;
my $fv =undef;
if (!$frm) {
$r =undef;
$@ ="Form not defined"
}
elsif ($frk && ($fn=$frk->{-namedb}) && ($fv =cfpv($s, $frk->{master}))) {
$s->{-fpbv} =$f->{-namedb}
? eval{$s->connect()
lib/ARSObject.pm view on Meta::CPAN
if ($s->{-fpbv}) {
$r =shift @{$s->{-fpbv}} if scalar(@{$s->{-fpbv}});
$r ={} if !$r;
}
else {
$r =undef
}
}
elsif ($f && ($fv =cfpv($s, $f))) {
$r =eval{$s->connect()
&& $s->entry(-form=>$frm
lib/ARSObject.pm view on Meta::CPAN
$@ ="Not found '$fn'=\"$fv\""
if !$r
}
}
else {
$r =undef;
$@ ="Key not defined"
}
}
elsif ($ae eq 'entryNew') { # -preact
$r =eval{$s->connect()
lib/ARSObject.pm view on Meta::CPAN
}
elsif ($af->{-vfedit} || $f->{-vfedit}) {
my $fn =$f->{-namedb} ||$af->{-namedb};
my $fv =cfpv($s, $f);
my $fa =$s->vfdata($fs);
my ($i,$j) =(0, undef);
foreach my $e (@$fa) {
if (defined($e->{$fn}) && ($e->{$fn} eq $fv)) {
$j =$i;
last;
}
lib/ARSObject.pm view on Meta::CPAN
,'Executing'=>'Âûïîëíåíèå', 'Done'=>'Âûïîëíåíî'}
: {};
$cmsg =sub{"\n<br /><font style=\"font-weight: bolder\""
.($_[1] =~/^(?:Error|Warning)/ ? ' color="red"' : '')
.'>'
.(defined($_[1]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[1]} ||$_[1]) : 'undef')
.": "
.(defined($_[2]) ? $_[0]->{-cgi}->escapeHTML($hmsg->{$_[2]} ||$_[2]) : 'undef')
."</font>"
# 'Error', 'Warning',
# 'Executing', 'Done'('Success', 'Error')
}
if !$cmsg || (ref($cmsg) ne 'CODE');
lib/ARSObject.pm view on Meta::CPAN
$arv =cfpaction($s, $a, '-preact', $arv, $f);
next if $arv;
$err =$@;
last
}
$act =undef;
if (!$arv) {
&$emsg($s, $err ||"Unknown 'cfpaction' error");
$err =1;
last;
}
}
if ($f->{-key}) {
$act =undef;
}
next if !cfpused($s, $f);
my $fn =cfpn($s, $f);
if (!$f->{-reset}
? undef
: ref($f->{-reset}) eq 'CODE'
? &{$f->{-reset}}($s, $f)
: ref($f->{-reset}) eq 'ARRAY'
? grep {cfpvcc($s, $_)} @{$f->{-reset}}
# ??? read from URL interpreted as changed listbox
: $f->{-reset}
? cfpvcc($s, $f->{-reset})
: undef
) {
$s->{-cgi}->delete($fn);
}
my $fv =exists($f->{-computed})
? (ref($f->{-computed}) eq 'CODE'
lib/ARSObject.pm view on Meta::CPAN
}
foreach my $q ('-change', '-changelb') {
next if !$f->{$q};
last if !cfpvcc($s, $f);
my $c =ref($f->{$q}) eq 'CODE' ? &{$f->{$q}}($s, $f, $_ =$fv) : $f->{$q};
$c =ref($c) ne 'HASH' ? undef : ref($c->{$fv}) eq 'HASH' ? $c->{$fv} : $c;
if (ref($c) eq 'HASH') {
foreach my $k (keys %$c) {
next if $k =~/^-/;
defined($c->{$k})
? $s->{-cgi}->param(cfpn($s, $k)
lib/ARSObject.pm view on Meta::CPAN
: $s->{-cgi}->delete(cfpn($s, $k))
}
}
}
if (my $ev =!$aec || !$f->{-error}
? undef
: ref($f->{-error}) eq 'CODE'
? &{$f->{-error}}($s, $f, $_ =$fv, cfpvp($s, $f), $aec)
: !ref($f->{-error}) && (!defined($fv) || ($fv eq ''))
? $f->{-error}
: undef
) {
print &$cmsg($s, 'Error', "'" .$f->{-namelbl} ."' - $ev");
$err =1;
}
if (my $ev =!$f->{-warn}
? undef
: ref($f->{-warn}) eq 'CODE'
? &{$f->{-warn}}($s, $f, $_ =$fv, cfpvp($s, $f), $aec)
: !ref($f->{-warn}) && (!defined($fv) || ($fv eq ''))
? $f->{-warn}
: undef
) {
print &$cmsg($s, 'Warning', "'" .$f->{-namelbl} ."' - $ev");
}
}
return(undef)
if $err;
$act = $acf =$arv =undef;
foreach my $f (@{$s->{-fpl}}) {
next if (ref($f) ne 'HASH')
|| (exists($f->{-used}) && !$f->{-used});
next if !cfpused($s, $f);
if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {
lib/ARSObject.pm view on Meta::CPAN
$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')
lib/ARSObject.pm view on Meta::CPAN
if ($bb) {
print &$cfld($s, {}, $bb);
$bb ='';
}
print ref($cfld1) ? &{$cfld1}($s) : $cfld1;
$err ? undef : 1
}
ARSperl
view release on metacpan or search on metacpan
package ARS::ERRORSTR;
sub TIESCALAR {
bless {};
}
sub FETCH {
my($s, $i) = (undef, undef);
my(%mTypes) = ( 0 => "OK", 1 => "WARNING", 2 => "ERROR", 3 => "FATAL",
4 => "INTERNAL ERROR",
-1 => "TRACEBACK");
for($i = 0; $i < $ARS::ars_errhash{numItems}; $i++) {
# depending upon if your prefix your entry-id's with
# anything
#
# RETURNS
# a new scalar on success
# undef on error
sub ars_padEntryid {
my($c) = shift;
my($schema) = shift;
my($entry_id) = shift;
my($field);
# entry id field is field id #1
($field = ars_GetField($c, $schema, 1)) ||
return undef;
if( $field->{defaultVal} ){
return $field->{defaultVal}.("0"x($field->{limit}{maxLength}-length($field->{defaultVal})-length($entry_id))).$entry_id;
}else{
return ("0"x($field->{limit}{maxLength}-length($entry_id))).$entry_id;
}
($ts, $un) = split(/\004/, $pair);
$retval[$enum]->{USER} = $un;
$retval[$enum]->{TIME} = $ts;
} else {
# no value for this enumeration
$retval[$enum]->{USER} = undef;
$retval[$enum]->{TIME} = undef;
}
$enum++;
}
return @retval;
# then be fed into ars_MergeEntry() in order to alter the contents
# of an existing diary entry.
#
# RETURNS
# an encoded diary string (scalar) on success
# undef on failure
sub ars_EncodeDiary {
my ($diary_string) = undef;
my ($entry);
foreach $entry (@_) {
$diary_string .= $entry->{timestamp}.pack("c",4).$entry->{user}.pack("c",4).$entry->{value};
$diary_string .= pack("c",3) if ($diary_string);
}
ASNMTAP
view release on metacpan or search on metacpan
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
my $logger = LOG_init_log4perl ( 'archive', undef, $debug );
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
my @archivelisttable;
applications/archive.pl view on Meta::CPAN
$sth = $dbh->prepare($sql) or $rv = errorTrapDBI("dbh->prepare: $sql", $debug);
$rv = $sth->execute() or $rv = errorTrapDBI("sth->execute: $sql", $debug) if $rv;
if ( $rv ) {
while (my $ref = $sth->fetchrow_hashref()) {
($yearMOVE, $monthMOVE, undef) = split (/-/, $ref->{endDate});
print "\n", $ref->{catalogID}, " ", $ref->{id}, " ", $ref->{uKey}, " ", $ref->{startDate}, " ", $ref->{endDate}, " ",$ref->{timeslot}, " \n" if ($debug);
$sqlMOVE = 'REPLACE INTO `' .$SERVERTABLEVENTS. '_' .$yearMOVE. '_' .$monthMOVE. '` SELECT * FROM `' .$SERVERTABLEVENTS. '` WHERE catalogID = "' .$ref->{catalogID}. '" and id = "' .$ref->{id}. '"';
applications/archive.pl view on Meta::CPAN
$sth = $dbh->prepare($sql) or $rv = errorTrapDBI("dbh->prepare: $sql", $debug);
$rv = $sth->execute() or $rv = errorTrapDBI("sth->execute: $sql", $debug) if $rv;
if ( $rv ) {
while (my $ref = $sth->fetchrow_hashref()) {
($yearMOVE, undef, undef) = split (/-/, $ref->{solvedDate});
print "\n", $ref->{catalogID}, " ", $ref->{id}, " ", $ref->{uKey}, " ", $ref->{solvedDate}, " ", $ref->{solvedTimeslot}, "\n" if ($debug);
$sqlMOVE = 'REPLACE INTO `' .$SERVERTABLCOMMENTS. '_' .$yearMOVE. '` SELECT * FROM `' .$SERVERTABLCOMMENTS. '` WHERE catalogID = "' .$ref->{catalogID}. '" and id = "' .$ref->{id}. '"';
if ( $yearMOVE ne '0000' ) {
applications/archive.pl view on Meta::CPAN
}
}
foreach $dtest (@stest) {
my ($catalogID_uKey, $test) = split(/\#/, $dtest);
($command, undef) = split(/\.pl/, $test);
my ($catalogID, $uKey) = split(/_/, $catalogID_uKey);
unless ( defined $uKey ) {
$uKey = $catalogID;
$catalogID = $CATALOGID;
applications/archive.pl view on Meta::CPAN
if ( $debug ) { print "$emailreport"; } else { print EMAILREPORT "$emailreport"; }
my @cgisessPathFilenames = glob("$CGISESSPATH/cgisess_*");
foreach my $cgisessPathFilename (@cgisessPathFilenames) {
my (undef, $cgisessFilename) = split (/^$CGISESSPATH\//, $cgisessPathFilename);
my (undef, $sessionID) = split (/^cgisess_/, $cgisessFilename);
print "Filename : <$cgisessFilename><$sessionID>\n" if ($debug >= 2);
my ($sessionExists, %session) = get_session_param ($sessionID, $CGISESSPATH, $cgisessFilename, $debug);
if ( $sessionExists ) {
if (defined $session{ASNMTAP}) {
applications/archive.pl view on Meta::CPAN
sub print_help () {
print_revision($PROGNAME, $version);
print "ASNMTAP Archiver for the '$APPLICATION'
-A, --archivelist=<filename>
FILENAME : filename from the archivelist for the html output loop (default undef)
-c, --cgisess=F|T
F(alse) : don't remove the cgisess files
T(true) : remove the cgisess files (default)
-r, --reports=F|T
F(alse) : don't backup Csv, Sql, Error, Week, Debug reports
ASP-NextLink
view release on metacpan or search on metacpan
NextLink.pm view on Meta::CPAN
sub GetPreviousURL {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex - 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[0] : undef;
}
=head2 GetPreviousDescription()
Description of the previous page in the link file.
NextLink.pm view on Meta::CPAN
sub GetPreviousDescription {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex - 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[1] : undef;
}
=head2 GetNextURL()
URL of the next page in the link file.
NextLink.pm view on Meta::CPAN
sub GetNextURL {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex + 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[1] : undef;
}
=head2 GetNextDescription()
Description of the next page in the link file.
NextLink.pm view on Meta::CPAN
sub GetNextDescription {
my $self = shift;
die "Cannot call object method on class" unless ref $self;
my $idx = $self->GetListIndex + 1;
exists( $self->{_idx}{$idx} )
? $self->{_idx}{$idx}[1] : undef;
}
=head2 GetNthURL( n )
URL of the nth page in the link file.
ASP4
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2009 Adam Kennedy.
( run in 1.906 second using v1.01-cache-2.11-cpan-d80b1682f3f )