Result:
found more than 503 distributions - search limited to the first 2001 files matching your query
( run in 0.882 )
API-Plesk
view release on metacpan or search on metacpan
lib/API/Plesk.pm view on Meta::CPAN
$xml = $self->render_xml($xml);
warn "REQUEST $operator => $operation\n$xml" if $self->{debug};
my ($response, $error) = $self->xml_http_req($xml);
warn "RESPONSE $operator => $operation => $error\n$response" if $self->{debug};
unless ( $error ) {
$response = xml2hash $response, array => [$operation, 'result', 'property'];
}
return API::Plesk::Response->new(
operator => $operator,
operation => $operation,
response => $response,
error => $error,
);
}
sub bulk_send { confess "Not implemented!" }
lib/API/Plesk.pm view on Meta::CPAN
for ( @{$res->data} ) {
print "login: $_->{login}\n";
}
}
else {
print $res->error;
}
=head1 DESCRIPTION
At present the module provides interaction with Plesk 10.1 (API 1.6.3.1).
lib/API/Plesk.pm view on Meta::CPAN
=item xml_http_req( $xml )
Internal method. it implements real request sending to Plesk API.
Returns array ( $response_xml, $error ).
=back
=head1 SEE ALSO
API-PleskExpand
view release on metacpan or search on metacpan
lib/API/PleskExpand.pm view on Meta::CPAN
# OVERRIDE, INSTANCE(xml_request)
sub _execute_query {
my ($self, $xml_request) = @_;
# packet version override for
my $packet_version = $self->{'api_version'};
return unless $xml_request;
my $xml_packet_struct = <<" DOC";
<?xml version="1.0" encoding="UTF-8"?>
API-PureStorage
view release on metacpan or search on metacpan
lib/API/PureStorage.pm view on Meta::CPAN
my $url = shift @_;
my $ret = $self->{client}->GET($url);
my $num = $ret->responseCode();
my $con = $ret->responseContent();
if ( $num == 500 ) {
die "API returned error 500 for '$url' - $con\n";
}
if ( $num != 200 ) {
die "API returned code $num for URL '$url'\n";
}
print 'DEBUG: GET ', $url, ' -> ', $num, ":\n", Dumper(from_json($con)), "\n" if $debug;
lib/API/PureStorage.pm view on Meta::CPAN
my $data = shift @_;
my $ret = $self->{client}->POST($url, to_json($data));
my $num = $ret->responseCode();
my $con = $ret->responseContent();
if ( $num == 500 ) {
die "API returned error 500 for '$url' - $con\n";
}
if ( $num != 200 ) {
die "API returned code $num for URL '$url'\n";
}
print 'DEBUG: POST ', $url, ' -> ', $num, ":\n", Dumper(from_json($con)), "\n" if $debug;
API-Stripe
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
API-Trello
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
API-Twitter
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
API-Wunderlist
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
APISchema
view release on metacpan or search on metacpan
lib/APISchema/Validator.pm view on Meta::CPAN
my $class = shift;
return $class->_new(@_, fetch_resource_method => 'canonical_response_resource');
}
sub _valid_result { APISchema::Validator::Result->new_valid(@_) }
sub _error_result { APISchema::Validator::Result->new_error(@_) }
sub _resolve_encoding {
my ($content_type, $encoding_spec) = @_;
# TODO handle charset?
$content_type = $content_type =~ s/\s*;.*$//r;
lib/APISchema/Validator.pm view on Meta::CPAN
my $obj = eval { APISchema::Validator::Decoder->new->$decode($target) };
return { message => "Failed to parse $decode" } if $@;
my $validator = $validator_class->new($spec->definition);
my ($valid, $err) = $validator->validate($obj);
return {
attribute => $err->attribute,
position => $err->position,
expected => $err->expected,
actual => $err->actual,
message => "Contents do not match resource '@{[$spec->title]}'",
} unless $valid;
return; # avoid returning the last conditional value
}
lib/APISchema/Validator.pm view on Meta::CPAN
[ @target_keys ],
);
@target_keys = grep { $resource_spec->{$_} } @target_keys;
my $body_encoding = $resource_spec->{body} && do {
my ($enc, $err) = _resolve_encoding(
$target->{content_type} // '',
$resource_spec->{encoding},
);
if ($err) {
return _error_result(body => $err);
}
$enc;
};
my $encoding = {
lib/APISchema/Validator.pm view on Meta::CPAN
my $validator_class = $self->validator_class;
load_class $validator_class;
my $result = APISchema::Validator::Result->new;
$result->merge($_) for map {
my $field = $_;
my $err = _validate($validator_class, map { $_->{$field} } (
$encoding, $target, $resource_spec,
));
$err ? _error_result($field => {
%$err,
encoding => $encoding->{$_},
}) : _valid_result($field);
} @target_keys;
return $result;
APNS-Agent
view release on metacpan or search on metacpan
lib/APNS/Agent.pm view on Meta::CPAN
private_key
sandbox
debug_port
/],
ro_lazy => {
on_error_response => sub {
sub {
my $self = shift;
my %d = %{$_[0]};
warnf "identifier:%s\tstate:%s\ttoken:%s", $d{identifier}, $d{state}, $d{token} || '';
}
lib/APNS/Agent.pm view on Meta::CPAN
AnyEvent::APNS->new(
certificate => $self->certificate,
private_key => $self->private_key,
sandbox => $self->sandbox,
on_error => sub {
my ($handle, $fatal, $message) = @_;
my $t; $t = AnyEvent->timer(
after => 0,
interval => 10,
lib/APNS/Agent.pm view on Meta::CPAN
undef $t;
infof "event:reconnect";
$self->_connect_to_apns;
},
);
warnf "event:error\tfatal:$fatal\tmessage:$message";
},
on_connect => sub {
infof "event:on_connect";
$self->_disconnect_timer($self->_build_disconnect_timer);
if (@{$self->_queue}) {
$self->_sending;
}
},
on_error_response => sub {
my ($identifier, $state) = @_;
my $data = $self->_sent_cache->get($identifier) || {};
$self->on_error_response->($self, {
identifier => $identifier,
state => $state,
token => $data->{token},
payload => $data->{payload},
});
lib/APNS/Agent.pm view on Meta::CPAN
$identifier = $self->_apns->send(pack("H*", $token) => {
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;
}
else {
die $err;
}
}
else {
$self->_sent_cache->set($identifier => {
token => $token,
APP-REST-RestTestSuite
view release on metacpan or search on metacpan
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
$Data::Dumper::Indent = 1;
=head1 NAME
APP::REST::ParallelMyUA -
provide a subclassed UserAgent to override on_connect, on_failure and
on_return methods
=head1 VERSION
Version 0.03
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
=head2 on_failure
on_failure gets called whenever a connection fails right away
(either we timed out, or failed to connect to this address before,
or it's a duplicate). Please note that non-connection based
errors, for example requests for non-existant pages, will NOT call
on_failure since the response from the server will be a well
formed HTTP response!
=cut
lib/APP/REST/ParallelMyUA.pm view on Meta::CPAN
#print $response->content;
} else {
#print "\n\nBummer! Request to ",$request->url," returned code ", $response->code,
# ": ", $response->message, "\n";
#print $response->error_as_HTML;
}
return;
}
1;
APR-Emulate-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
inc/Module/Install.pm view on Meta::CPAN
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
inc/Module/Install.pm view on Meta::CPAN
# I'm still wondering if we should slurp Makefile.PL to
# get some context or not ...
my ($package, $file, $line) = caller;
die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
APR-HTTP-Headers-Compat
view release on metacpan or search on metacpan
0.01 2009-06-11
- Initial release.
0.02 2009-06-12
- Expanded on documentation
- Removed a couple of errant $DB::single = 1 statements. Mad
debugging skilz.
ARCv2
view release on metacpan or search on metacpan
$DefaultPIDFile = "/var/run/arcxd.pid";
$Copyright = "ARCv2 $VERSION (C) 2003-5 Patrick Boettcher and others. All right reserved.";
$Contact = "Patrick Boettcher <patrick.boettcher\@desy.de>, Wolfgang Friebel <wolfgang.friebel\@desy.de>";
my @syslog_arr = ('emerg','alert','crit','err','warning','notice','info','debug');
# package member vars
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')
};
}
## Constructor.
## Initializes the object and returns it blessed.
## For all sub classes, please override C<_Init> to check the
## parameter which are passed to the C<new> function. This
## is necessary because you are not able to call the the new method of a
## parent class, when having a class name (new $class::SUPER::new, does not work.).
##in> %hash, key => val, ...
##out> blessed object of the class
return $self;
}
## Init function (initializes class context)
## Module dependent initialization, every subclass shall override it
## and call the _Init of its SUPER class. This method is called by the new method of C<Arc>.
##in> %hash, key => val, ...
##out> true, if all passed values are in their definition scope, otherwise false
##eg> see source code of any non-abstract sub class of Arc
sub _Init
croak("Ignored values at object-creation (this is probably not what you want): ",join(" ",keys (%values))) if keys %values;
# loglevel
$this->{loglevel} = 4 if not defined $this->{loglevel};
$this->{_syslog} = ! (defined $this->{logdestination} && $this->{logdestination} eq "stderr");
openlog("arcv2","cons,pid","user") if $this->{_syslog};
1;
}
}
## Log function.
## Logs messages to 'logdestination' if 'loglevel' is is set appropriatly.
## loglevel behaviour has changed in the 1.0 release of ARCv2, the "Arc"-class can export
## LOG_AUTH (authentication information), LOG_USER (connection information), LOG_ERR (errors),
## LOG_CMD (ARCv2 addition internal command information), LOG_SIDE (verbose client/server-specific
## information), LOG_DEBUG (verbose debug information). It possible to combine the
## levels with or (resp. +) to allow a message to appear when not all loglevels are
## requested by the user.
## Commonly used for logging errors from application level.
##in> $facility, ... (message)
##out> always false
##eg> return $arc->Log(LOG_ERR,"Message");
sub Log
{
my $this = shift;
my $pr = shift;
my $ll = $this->{loglevel};
my $lev = 1;
my @syslog_arr = ('err','info','debug');
$lev = 0 if $pr & LOG_ERR;
$lev = 2 if $pr & LOG_DEBUG;
if ($pr & $this->{loglevel}) {
}
return;
}
## SetError function.
## This function prepends the error message (@_) to an existing error message (if any) and
## logs the message with LOG_ERR facility.
## Use this function for setting an error from class level. Users should use IsError
## to get the message if a function failed.
##in> ... (message)
##out> always false
##eg> return $this->_SetError("User is not allowed to do this."); # breaks when an error occured
sub _SetError
{
my $this = shift;
$this->Log(LOG_ERR,@_);
my $errstr = "";
if ($this->{_error}) {
$errstr = ' maybe caused by: '.$this->{_error};
}
unless (@_) {
$errstr .= 'Error, but no message.';
} else {
$errstr = join(" ",@_).$errstr ;
}
$errstr =~ s/\r//g;
$errstr =~ s/\n/ /g;
$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-Abs
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
ARGV-ENV
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
ARGV-JSON
view release on metacpan or search on metacpan
software--to make sure the software is free for all its users. The
General Public License applies to the Free Software Foundation's
software and to any other program whose authors commit to using it.
You can use it for your programs, too.
When we speak of free software, we are referring to freedom, not
price. Specifically, the General Public License is designed to make
sure that you have the freedom to give away or sell copies of free
software, that you receive source code or can get it if you want it,
that you can change the software or use pieces of it in new free
programs; and that you know you can do these things.
appropriately publish on each copy an appropriate copyright notice and
disclaimer of warranty; keep intact all the notices that refer to this
General Public License and to the absence of any warranty; and give any
other recipients of the Program a copy of this General Public License
along with the Program. You may charge a fee for the physical act of
transferring a copy.
2. You may modify your copy or copies of the Program or any portion of
it, and copy and distribute such modifications under the terms of Paragraph
1 above, provided that you also do the following:
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
Mere aggregation of another independent work with the Program (or its
derivative) on a volume of a storage or distribution medium does not bring
c) accompany it with the information you received as to where the
corresponding source code may be obtained. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form alone.)
Source code for a work means the preferred form of the work for making
modifications to it. For an executable file, complete source code means
all the source code for all modules it contains; but, as a special
exception, it need not include source code for modules which are standard
libraries that accompany the operating system on which the executable
file runs, or for standard header files or definitions files that
ARGV-Struct
view release on metacpan or search on metacpan
- First version
0.02 2015-02-04 21:30:00
- Breakage: now the arguments are JSONY compatible
(thanks to Matt S Trout for the suggestion)
- Refactor parsing code
- Better errors
- More tests
0.03 2015-08-05 23:45:00
- Compatibility with pre 5.14 Perls (GH Issue #1)
0.04 2018-09-18 22:33:00
- Migrate to Moo and Type::Tiny
ARGV-URL
view release on metacpan or search on metacpan
More DZ plugins => META.json, perl prereq
Add an example: examples/sherlock.pl
0.92 2011-09-04 DOLMEN (Olivier Mengué)
Add tests.
Fixes a minor POD error.
0.91 2011-08-12 DOLMEN (Olivier Mengué)
Fixing mistakes of a release late in the night:
- missing $VERSION
- missing Github meta
ARS-Simple
view release on metacpan or search on metacpan
lib/ARS/Simple.pm view on Meta::CPAN
my ($self, $args) = @_;
my $qual = ars_LoadQualifier($self->{ctl}, $args->{form}, $args->{query});
unless ($qual)
{
$self->_carp("_load_qualifier() Error processing query:\n$ars_errstr\n");
}
return $qual;
}
lib/ARS/Simple.pm view on Meta::CPAN
$self->_reset_max_entries();
unless (%entryList)
{
no warnings qw(uninitialized);
if ($ars_errstr)
{
$self->_carp("get_data_by_label() failed.\nError=$ars_errstr\nForm=$form\nQuery=$query\n");
}
else
{
if ($self->{log})
{
lib/ARS/Simple.pm view on Meta::CPAN
# $m = {
# "numMatches" => integer,
# "rows" => [ [r1col1, r1col2], [r2col1, r2col2] ... ],
# }
if ($ars_errstr && $ars_errstr ne '')
{
$self->_carp('get_SQL() - ars_GetListSQL error, sql=', $self->{sql}, "\nars_errstr=$ars_errstr\n");
}
return $m;
}
lib/ARS/Simple.pm view on Meta::CPAN
if (defined $max)
{
unless(ars_SetServerInfo($self->{ctl}, &ARS::AR_SERVER_INFO_MAX_ENTRIES, $max))
{
$self->_carp("set_max_entries() - Could not set the AR_SERVER_INFO_MAX_ENTRIES to $max:\n$ars_errstr\n");
}
}
}
sub _reset_max_entries
lib/ARS/Simple.pm view on Meta::CPAN
$self->_carp("get_fields() requires the 'form' as a argument\n");
return;
}
my %fids = ars_GetFieldTable($self->{ctl}, $form);
$self->_carp("get_fields() error: $ars_errstr\n") unless (%fids);
return \%fids;
}
sub update_record
lib/ARS/Simple.pm view on Meta::CPAN
}
my $rv = ars_SetEntry($self->{ctl}, $form, $eID, 0, %lvp);
# Check for errors
unless (defined $rv && $rv == 1)
{
# Update failed
my $msg = "update_record(eid=$eID, form=$form, ...) failed:\nars_errstr=$ars_errstr\nlvp data was:\n";
foreach my $label (sort keys %{$args->{lvp}})
{
$msg .= sprintf("%30s (%10d) ---> %s\n", $label, $args->{lfid}{$label}, defined($lvp{$args->{lfid}{$label}}) ? $lvp{$args->{lfid}{$label}} : '<undefined>');
}
carp($msg);
lib/ARS/Simple.pm view on Meta::CPAN
{
$self->{ctl} = $ctl;
}
else
{
croak(__PACKAGE__ . " object initialisation failed.\nFailed to log into Remedy server=" . $self->{server} . " as user '$user' with supplied password: $ars_errstr\n");
}
}
else
{
croak(__PACKAGE__ . " object initialisation failed, server, user and password are required\n");
lib/ARS/Simple.pm view on Meta::CPAN
Turn on, if true (1), the ARSperl debugging output.
Not something you would normally use.
=item log
Pass a object to use to log erros/information to a log file.
The log object is expected to have methods I<exp> and I<msg>
as per the File::Log object.
=back
lib/ARS/Simple.pm view on Meta::CPAN
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
form => $form, # The form to update
lvp => \%lvp, # The data to be updated as a label => value hash ref
lib/ARS/Simple.pm view on Meta::CPAN
and the values are the field ids (fid).
=head2 set_max_entries
This requires that the 'user' has administrator access. This
allows the overriding of the B<system wide> maximum rows returned
setting AR_SERVER_INFO_MAX_ENTRIES, setting this to zero (0) will
allow unlimited returns.
B<Beware of setting this to a small value, it is system wide and
could have a major impact on your system>
ARSObject
view release on metacpan or search on metacpan
lib/ARSObject.pm view on Meta::CPAN
# },...}
,-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
lib/ARSObject.pm view on Meta::CPAN
}
sub ineval { # is inside eval{}?
# for PerlEx and mod_perl
# see CGI::Carp::ineval comments and errors
return $^S if !($ENV{GATEWAY_INTERFACE}
&& ($ENV{GATEWAY_INTERFACE} =~/PerlEx/))
&& !$ENV{MOD_PERL};
my ($i, @a) =(1);
while (@a =caller($i)) {
lib/ARSObject.pm view on Meta::CPAN
$i +=1;
}
$^S
}
# error message form ??? use ???
# (err/var, command, operation, function, args)
sub efmt {
efmt1(@_)
}
sub efmt0 {
lib/ARSObject.pm view on Meta::CPAN
,join(': '
,($c ? $c : ())
,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
,($o ? $o : ())
)
.($e && ($e eq '$!') && $^E ? (' -> ' .$! .' / ' .$^E) : ( ' -> ' .($e || 'unknown error')))
)
}
sub efmt1 {
my ($s, $e, $c, $o, $f, @a) =@_;
cpcon($s
,join(' # '
,($e && ($e eq '$!') && $^E ? ($! .' / ' .$^E) : ($e || 'unknown error'))
,($o ? $o : ())
,($f ? $f .'(' .join(',', map {$s->dsquot($_)} @a) .')' : ())
,($c ? $c : ())
)
)
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
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 $ull =$s->{-lang} =~/^([A-Za-z]+)/ ? $1 : $s->{-lang};
my $ulc =$s->{-lang} =~/^([A-Za-z_]+)/ ? $1 : $s->{-lang};
my $i =0;
foreach my $vi (ars_GetListVUI($s->{-ctrl}, $f, 0)) {
my $vw =ars_GetVUI($s->{-ctrl}, $f, $vi);
# language[_territory[.codeset]][@modifier]
# en_US.ISO8859-15@euro
$vli =$i if !defined($vli) && !$vw->{locale};
$vlc =$i if !defined($vlc) && $vw->{locale} && ($vw->{locale} =~/^\Q$ulc\E/);
$vll =$i if !defined($vll) && $vw->{locale} && ($vw->{locale} =~/^\Q$ull\E/);
last if defined($vli) && defined($vlc) && defined($vll);
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
}
$tc
}
sub ars_errstr {# Last ARS error
$ARS::ars_errstr
}
sub schema { # Schema by form name
lib/ARSObject.pm view on Meta::CPAN
.($q ? ",-where=>$q" : '')
.(@fs ? ',-order=>' .join(', ', map {"'$_'"} @fs) : '')
.")"
if 0;
$q =ARS::ars_LoadQualifier($s->{-ctrl}, $f, $q);
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr,$s->{-cmd})))
if !$q;
$s->{-cmd} .=": qual". $s->dsquot(ARS::ars_perl_qualifier($s->{-ctrl}, $q))
if 0;
print $s->cpcon(join(";\n", split /\):\s/, $s->{-cmd})), "\n"
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 $_ ='';
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
, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
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
, $a{-limit} ||$a{-max} ||$s->{-maxRetrieve} ||0
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
$rr->{$id} =$r{$id}
}
}
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
lib/ARSObject.pm view on Meta::CPAN
}
else {
$r =$s->{-entryNo} =ARS::ars_CreateEntry($s->{-ctrl}, $f, %a)
}
if (!$r) {
my $t =$s->efmt($ARS::ars_errstr,$s->{-cmd});
return(&{$s->{-die}}($t)) if !$r && $ARS::ars_errstr;
# warn($t) if !$r && !$ARS::ars_errstr;
}
$r ||$s
}
lib/ARSObject.pm view on Meta::CPAN
if $s->{-strFields}
}
($k => $v)
} keys %a;
my $r =ARS::ars_SetEntry($s->{-ctrl}, $f, $id, 0, %a);
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr, $s->{-cmd})))
if !$r && $ARS::ars_errstr;
$id
}
sub entryDel { # ars_DeleteEntry
lib/ARSObject.pm view on Meta::CPAN
my $id=$a{-id};
print $s->cpcon("entryDel(-form=>'$f',-id=>'$id')\n")
if exists($a{-echo}) ? $a{-echo} : $s->{-echo};
delete @a{qw(-schema -form -from -into -id -echo)};
my $r =ARS::ars_DeleteEntry($s->{-ctrl}, $f, $id);
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr
,"entryDel(-form=>'$f',-id=>'$id')")))
if !$r && $ARS::ars_errstr;
$id
}
sub entryBLOB { # BLOB field retrieve/update
lib/ARSObject.pm view on Meta::CPAN
}
else {
my $r =ARS::ars_GetEntryBLOB($s->{-ctrl}, $f, $a{-id}
,$a{-field} =~/^\d+$/ ? $a{-field} : schdn($s,$f,$a{-field})->{fieldId}
,$a{-file} ? (ARS::AR_LOC_FILENAME(), $a{-file}) : (ARS::AR_LOC_BUFFER()));
return(&{$s->{-die}}($s->efmt($ARS::ars_errstr
,"entryBLOB(-form=>'$f',-id=>'" .$a{-id} ."',-field=>" .$a{-field} ."')")))
if !defined($r) && $ARS::ars_errstr;
return(!$a{-file} ? $r : $r ? $a{-id} : $r)
}
}
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
}
sub dbitables { # DBI tables array
my ($s, $sch, $tbl) =@_;
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;
}
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
}
}
}
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
: '')
.' 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
$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
# __B_ button for javascript
lib/ARSObject.pm view on Meta::CPAN
}
sub cgitext { # CGI textarea field
$_[0]->{-cgi}->textarea(@_[1..$#_])
# -default=>$v, -override=>1
}
sub cgistring { # CGI string field
$_[0]->{-cgi}->textfield(@_[1..$#_])
lib/ARSObject.pm view on Meta::CPAN
$a{-values}
};
my $ac=$a{-class} ? ' class="' .$a{-class} .'"' : '';
my $as=$a{-style} ? ' style="' .$a{-style} .'"' : '';
my $aw=$a{-size} ||80;
my $v =!defined($s->{-cgi}->param($n)) ||$a{-override}
? $a{-default}
: $s->{-cgi}->param($n);
$v =&$av()->[0]
if $a{-strict} && (!defined($v) || !grep /^\Q$v\E$/, @{&$av()});
$s->{-cgi}->param($n, defined($v) ? $v : '');
lib/ARSObject.pm view on Meta::CPAN
: $a{-textfield} && $a{-textfield}->{$_} && !$s->{-cgi}->param("${n}__O_")
? ($_ => $a{-textfield}->{$_})
: ()
} qw(-name -title -class -style -size -maxlength))
, -default=>$v
, -override=>1
, ($a{-strict} && !$s->{-cgi}->param("${n}__O_")
? (-readonly=>1) # ,-hidefocus=>0, -disabled=>0
: ())
)
.($s->{-cgi}->param("${n}__O_")
lib/ARSObject.pm view on Meta::CPAN
: ($_->{-namedb} => &$fvu($s, $_))
} cfpused($s))}
if $frm;
$r =1 if ref($r);
if (!$r) {
$@ ="Unknown 'entryIns' error" if !$@
}
elsif (!$fs ||!$f->{-key}) {
}
elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {
$s->vfclear($fs);
lib/ARSObject.pm view on Meta::CPAN
? ()
: ($_->{-namedb} => &$fvu($s, $_))
} cfpused($s))}
if $frm && cfpvv($s,$f);
if (!$r) {
$@ ="Unknown 'entryUpd' error" if !$@
}
elsif (!$f->{-key} ||!$fs) {
}
elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {
$s->vfclear($fs);
lib/ARSObject.pm view on Meta::CPAN
$r =eval{$s->connect()
&& $s->entryDel(-form=>$frm
, -id=>cfpvv($s,$f))}
if $frm && cfpvv($s,$f);
if (!$r) {
$@ ="Unknown 'entryDel' error" if !$@
}
elsif (!$fs ||!$f->{-key}) {
}
elsif (($af->{-vfclear} || $f->{-vfclear}) && $s->{"${fs}-calc"}) {
$s->vfclear($fs);
lib/ARSObject.pm view on Meta::CPAN
$cfld0="\n<table>" if !$cfld0;
$cfld1="\n</table>" if !$cfld1;
$s->cgi();
cfpinit($s);
local $s->{-fpmsg} =$cmsg;
my $err;
my $act;
my $acf;
my $aec;
my $arv;
foreach my $f (@{$s->{-fpl}}) {
lib/ARSObject.pm view on Meta::CPAN
push @$act, $f
}
if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {
$aec =cfpvv($s, $f);
}
if ($f->{-key} && $act && !$err) {
$arv =1;
foreach my $a (@$act) {
$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;
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)
lib/ARSObject.pm view on Meta::CPAN
) {
print &$cmsg($s, 'Warning', "'" .$f->{-namelbl} ."' - $ev");
}
}
return(undef)
if $err;
$act = $acf =$arv =undef;
foreach my $f (@{$s->{-fpl}}) {
next if (ref($f) ne 'HASH')
|| (exists($f->{-used}) && !$f->{-used});
next if !cfpused($s, $f);
if ($f->{-action} && ($f->{-action} !~/^\d$/) && cfpvv($s, $f)) {
$acf =1;
$act =[] if !$act;
push @$act, $f
}
if ($f->{-key} && $act && !$err) {
$arv =1;
foreach my $a (@$act) {
print &$cmsg($s, 'Executing', ($a->{-namelbl} ||$a->{-namecgi} ||'') .' ', $arv)
if $a->{-namelbl} ||$a->{-namecgi};
$arv =cfpaction($s, $a, '-action', $arv, $f);
next if $arv;
$err =$@;
last;
}
$act =undef;
if (!$arv) {
&$emsg($s, $err ||"Unknown 'cfpaction' error");
$err =1;
last;
}
}
if ($f->{-key}) {
$act =undef;
}
}
if ($acf) {
print &$cmsg($s, 'Done', $err ? ('Error', $@) : ('Success', $arv))
}
return(undef)
if $err;
return(1)
if $acf;
foreach my $f (@{$s->{-fpl}}) {
next if (ref($f) ne 'HASH')
|| (exists($f->{-used}) && !$f->{-used});
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
#
# Mailing List (must be subscribed to post):
# arsperl@arsperl.org
#
# Routines for grabbing the current error message "stack"
# by simply referring to the $ars_errstr scalar.
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++) {
# If debugging is not enabled, don't show traceback messages
if($ARS::DEBUGGING == 1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
$mTypes{@{$ARS::ars_errhash{messageType}}[$i]},
@{$ARS::ars_errhash{messageText}}[$i],
@{$ARS::ars_errhash{messageNum}}[$i]);
$s .= "\n" if($i < $ARS::ars_errhash{numItems}-1);
} else {
if(@{$ARS::ars_errhash{messageType}}[$i] != -1) {
$s .= sprintf("[%s] %s (ARERR \#%d)",
$mTypes{@{$ARS::ars_errhash{messageType}}[$i]},
@{$ARS::ars_errhash{messageText}}[$i],
@{$ARS::ars_errhash{messageNum}}[$i]);
$s .= "\n" if($i < $ARS::ars_errhash{numItems}-1);
}
}
}
return $s;
}
require Carp unless $^S;
use AutoLoader 'AUTOLOAD';
use Config;
require 'ARS/ar-h.pm';
require 'ARS/arerrno-h.pm';
require 'ARS/nparm.pm';
@ARS::ISA = qw(Exporter DynaLoader);
@ARS::EXPORT = qw(isa_int isa_float isa_string ars_LoadQualifier ars_Login
ars_Logoff ars_GetListField ars_GetFieldByName ars_GetFieldTable
ars_GetListContainer ars_GetContainer ars_DeleteContainer ars_SetServerPort
ars_SetLogging ars_SetSessionConfiguration ars_SetImpersonatedUser
ars_CreateField ars_SetField ars_CreateSchema ars_SetSchema ars_CreateVUI ars_SetVUI
ars_CreateContainer ars_SetContainer ars_CreateCharMenu ars_SetCharMenu
ars_SetActiveLink ars_CreateFilter ars_CreateEscalation ars_SetEscalation
$ars_errstr %ARServerStats %ars_errhash
ars_decodeStatusHistory ars_APIVersion ars_encodeStatusHistory
ars_BeginBulkEntryTransaction ars_EndBulkEntryTransaction
ars_Signal ars_GetTextForErrorMessage ars_DateToJulianDate
ars_GetListLicense ars_ValidateMultipleLicenses
ars_GetServerCharSet ars_GetClientCharSet
if (!defined &ARS::AR_IMPORT_OPT_OVERWRITE) {
eval 'sub AR_IMPORT_OPT_OVERWRITE { 1; }';
}
bootstrap ARS $ARS::VERSION;
tie $ARS::ars_errstr, ARS::ERRORSTR;
# This HASH is used by the ars_GetServerStatistics call.
# Refer to your ARS API Programmer's Manual or the "ar.h"
# file for an explaination of what each of these stats are.
#
# 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;
# compile new qual
# pass to Expand2
if(ref($q) eq "ARQualifierStructPtr") {
$q = ars_perl_qualifier($c, $q);
die Carp::longmess("ars_perl_qualifier failed: $ARS::ars_errstr")
unless defined($q);
}
if(0) {
while($#_) {
my ($f, $v) = (shift @_, shift @_);
sub ars_GetCharMenuItems {
my ($ctrl, $menuName, $qual) = (shift, shift, shift);
if(defined($qual)) {
my $menu = ars_GetCharMenu($ctrl, $menuName);
die "ars_GetCharMenuItems failed: $ARS::ars_errstr"
unless defined($menu);
die "ars_GetCharMenuItems failed: qualifier was specified, but menu is not a 'query' menu"
if($menu->{'menuType'} ne "query");
if(ref($qual) ne "ARQualifierStruct") {
ASNMTAP
view release on metacpan or search on metacpan
applications/archive.pl view on Meta::CPAN
archiveCommentsAndEventsTables ( '-14 days', '-1 year' );
}
removeCgisessFiles ($removeCgisessEpoch) if ($doCgisess);
my $emailreport = "\nRemove *-MySQL-sql-error.txt:\n-----------------------------\n";
if ( $debug ) { print "$emailreport"; } else { print EMAILREPORT "$emailreport"; }
my @sqlErrorTxtFiles = glob("$RESULTSPATH/*-MySQL-sql-error.txt");
foreach my $sqlErrorTxtFile (@sqlErrorTxtFiles) {
if ($debug) {
print "E- unlink <$sqlErrorTxtFile>\n";
} else {
applications/archive.pl view on Meta::CPAN
# Init parameters
my ($rv, $dbh, $sth, $sql, $year, $month, $day, $timeslot, $yearMOVE, $monthMOVE, $sqlMOVE, $sqlUPDATE);
$rv = 1;
$dbh = DBI->connect("dbi:mysql:$DATABASE:$SERVERNAMEREADWRITE:$SERVERPORTREADWRITE", "$SERVERUSERREADWRITE", "$SERVERPASSREADWRITE" ) or $rv = errorTrapDBI("Cannot connect to the database", $debug);
if ($dbh and $rv) {
$year = get_year ($eventsAgo);
$month = get_month ($eventsAgo);
$day = get_day ($eventsAgo);
applications/archive.pl view on Meta::CPAN
} else {
$sql = "select SQL_NO_CACHE catalogID, id, endDate from $SERVERTABLEVENTS force index (key_timeslot) where timeslot < '" .$timeslot. "'";
print EMAILREPORT "\nTable: '$SERVERTABLEVENTS', Year: '$year', Month: '$month', Day: '$day', Timeslot: '$timeslot'\n";
}
$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});
applications/archive.pl view on Meta::CPAN
$sqlMOVE = 'REPLACE INTO `' .$SERVERTABLEVENTS. '_' .$yearMOVE. '_' .$monthMOVE. '` SELECT * FROM `' .$SERVERTABLEVENTS. '` WHERE catalogID = "' .$ref->{catalogID}. '" and id = "' .$ref->{id}. '"';
if ( $yearMOVE ne '0000' and $monthMOVE ne '00' ) {
print "$sqlMOVE\n" if ($debug);
$dbh->do( $sqlMOVE ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug) unless ( $debug );
if ( $rv ) {
$sqlMOVE = 'DELETE FROM `' .$SERVERTABLEVENTS. '` WHERE catalogID = "' .$ref->{catalogID}. '" and id = "' .$ref->{id}. '"';
print "$sqlMOVE\n" if ($debug);
$dbh->do( $sqlMOVE ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug) unless ( $debug );
}
} else {
if ($debug) {
print "DATABASE ERROR ... CRITICAL: Update table ${SERVERTABLEVENTS}_${yearMOVE}_${monthMOVE}' not possible for '$sqlMOVE'\n";
} else {
print EMAILREPORT "DATABASE ERROR ... CRITICAL: Update table ${SERVERTABLEVENTS}_${yearMOVE}_${monthMOVE}' not possible for '$sqlMOVE'\n";
}
}
}
$sth->finish() or $rv = errorTrapDBI("sth->finish", $debug);
}
$sql = "select SQL_NO_CACHE distinct $SERVERTABLCOMMENTS.catalogID, $SERVERTABLCOMMENTS.uKey, $SERVERTABLCOMMENTS.commentData from $SERVERTABLCOMMENTS, $SERVERTABLPLUGINS, $SERVERTABLVIEWS, $SERVERTABLDISPLAYDMNS, $SERVERTABLCRONTABS as crontabOu...
if ($debug) {
print "\nUpdate table '$SERVERTABLCOMMENTS': <$sql>\n";
} else {
print EMAILREPORT "\nUpdate table '$SERVERTABLCOMMENTS': <$sql>\n";
}
$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 ) {
my ($localYear, $localMonth, $currentYear, $currentMonth, $currentDay, $currentHour, $currentMin, $currentSec) = ((localtime)[5], (localtime)[4], ((localtime)[5] + 1900), ((localtime)[4] + 1), (localtime)[3,2,1,0]);
my $solvedDate = "$currentYear-$currentMonth-$currentDay";
my $solvedTime = "$currentHour:$currentMin:$currentSec";
my $solvedTimeslot = timelocal($currentSec, $currentMin, $currentHour, $currentDay, $localMonth, $localYear);
while (my $ref = $sth->fetchrow_hashref()) {
$sqlUPDATE = 'UPDATE ' .$SERVERTABLCOMMENTS. ' SET replicationStatus="U", problemSolved="1", solvedDate="' .$solvedDate. '", solvedTime="' .$solvedTime. '", solvedTimeslot="' .$solvedTimeslot. '", commentData="' .$ref->{commentData}. '<br>AUT...
print "$sqlUPDATE;\n" if ($debug);
$dbh->do( $sqlUPDATE ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug) unless ( $debug );
}
$sth->finish() or $rv = errorTrapDBI("sth->finish", $debug);
}
$year = get_year ($commentsAgo);
$month = get_month ($commentsAgo);
$day = get_day ($commentsAgo);
applications/archive.pl view on Meta::CPAN
print "\nTable: '$SERVERTABLCOMMENTS', Year: '$year', Month: '$month', Day: '$day', Timeslot: '$timeslot', Date: " .scalar(localtime($timeslot)). "\n<$sql>\n";
} else {
print EMAILREPORT "\nTable: '$SERVERTABLCOMMENTS', Year: '$year', Month: '$month', Day: '$day', Timeslot: '$timeslot'\n";
}
$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' ) {
print "$sqlMOVE\n" if ($debug);
$dbh->do( $sqlMOVE ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug) unless ( $debug );
if ( $rv ) {
$sqlMOVE = 'DELETE FROM `' .$SERVERTABLCOMMENTS. '` WHERE catalogID = "' .$ref->{catalogID}. '" and id = "' .$ref->{id}. '"';
print "$sqlMOVE\n" if ($debug);
$dbh->do( $sqlMOVE ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug) unless ( $debug );
}
} else {
if ($debug) {
print "DATABASE ERROR ... CRITICAL: Update table ${SERVERTABLCOMMENTS}_${yearMOVE}' not possible for '$sqlMOVE'\n";
} else {
print EMAILREPORT "DATABASE ERROR ... CRITICAL: Update table ${SERVERTABLCOMMENTS}_${yearMOVE}' not possible for '$sqlMOVE'\n";
}
}
}
$sth->finish() or $rv = errorTrapDBI("sth->finish", $debug);
}
# cleanup automatically scheduled donwtimes when sheduled OFFLINE
my ($localYear, $localMonth, $currentYear, $currentMonth, $currentDay, $currentHour, $currentMin, $currentSec) = ((localtime)[5], (localtime)[4], ((localtime)[5] + 1900), ((localtime)[4] + 1), (localtime)[3,2,1,0]);
applications/archive.pl view on Meta::CPAN
my $solvedTime = "$currentHour:$currentMin:$currentSec";
my $solvedTimeslot = timelocal($currentSec, $currentMin, $currentHour, $currentDay, $localMonth, $localYear);
my $sqlUPDATE = 'UPDATE ' .$SERVERTABLCOMMENTS. ' SET replicationStatus="U", problemSolved="1", solvedDate="' .$solvedDate. '", solvedTime="' .$solvedTime. '", solvedTimeslot="' .$solvedTimeslot. '" where catalogID="'. $CATALOGID. '" and problemS...
print "$sqlUPDATE\n" if ($debug);
$dbh->do ( $sqlUPDATE ) or $rv = errorTrapDBI("Cannot dbh->do: $sqlUPDATE", $debug) unless ( $debug );
$dbh->disconnect or $rv = errorTrapDBI("Sorry, the database was unable to add your entry.", $debug);
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
applications/archive.pl view on Meta::CPAN
my ($Table, $Op, $Msg_type, $Msg_text) = '';
my $rv = 1;
my $sql = "check table $table";
my $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()) {
$Table = $ref->{Table};
$Op = $ref->{Op};
$Msg_type = $ref->{Msg_type};
$Msg_text = $ref->{Msg_text};
print "<- <$Table>, <$Op>, <$Msg_type>, <$Msg_text>\n" if ($debug);
}
$sth->finish() or $rv = errorTrapDBI("sth->finish", $debug);
$rv = ($rv and "$database.$table" eq $Table and $op eq $Op and $msg_type eq $Msg_type and $msg_text eq $Msg_text) ? 1 : 0;
}
return ($rv);
}
applications/archive.pl view on Meta::CPAN
# Init parameters
my ($rv, $dbh, $sql, $year, $month);
$year = get_year ($daysBefore);
$rv = 1;
$dbh = DBI->connect("dbi:mysql:$DATABASE:$SERVERNAMEREADWRITE:$SERVERPORTREADWRITE", "$SERVERUSERREADWRITE", "$SERVERPASSREADWRITE" ) or $rv = errorTrapDBI("Cannot connect to the database", $debug);
if ($dbh and $rv) {
foreach $month ('01'..'12') {
$sql = 'CREATE TABLE IF NOT EXISTS `'. $SERVERTABLEVENTS .'_'. $year .'_'. $month .'` LIKE `'. $SERVERTABLEVENTS .'`';
$rv = ! checkTableDBI ($dbh, $DATABASE, $SERVERTABLEVENTS .'_'. $year .'_'. $month, 'check', 'status', 'OK');
applications/archive.pl view on Meta::CPAN
if ($rv) {
if ($debug) {
print "\nTable: '$SERVERTABLEVENTS', Year: '$year', Month: '$month'\n<$sql>\n";
} else {
print EMAILREPORT "\nTable: '$SERVERTABLEVENTS', Year: '$year', Month: '$month', Status: ";
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
$rv = checkTableDBI ($dbh, $DATABASE, $SERVERTABLEVENTS .'_'. $year .'_'. $month, 'check', 'status', 'OK');
if ($rv) { print EMAILREPORT "Created\n"; } else { print EMAILREPORT "NOT CREATED, PLEASE VERIFY\n"; }
}
} else {
$rv = 1;
applications/archive.pl view on Meta::CPAN
if ($debug) {
print "Table: '$SERVERTABLEVENTS', Year: '$year', Month: '$month', Status: ENGINE\n";
} else {
print EMAILREPORT "Table: '$SERVERTABLEVENTS', Year: '$year', Month: '$month', Status: ENGINE\n";
$sql = sprintf ("ALTER TABLE `%s_%s_%02d` ENGINE = MyISAM", $SERVERTABLEVENTS, $year, $month);
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
if ($rv) { print EMAILREPORT "ENGINE = MyISAM\n\n"; } else { print EMAILREPORT "NOT ENGINE = MyISAM, PLEASE VERIFY '$sql'\n\n"; }
}
}
}
applications/archive.pl view on Meta::CPAN
if ($debug) {
print "\nTable: '$SERVERTABLEVENTS', Year: '$year', Status: MERGE\n";
} else {
print EMAILREPORT "\nTable: '$SERVERTABLEVENTS', Year: '$year', Status: MERGE\n";
$sql = 'DROP TABLE IF EXISTS `'. $SERVERTABLEVENTS .'_'. $year .'`';
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
if ($rv) {
$sql = 'CREATE TABLE IF NOT EXISTS `'. $SERVERTABLEVENTS .'_'. $year .'` LIKE `'. $SERVERTABLEVENTS .'_'. $year .'_01`';
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
}
if ($rv) {
$sql = 'ALTER TABLE `'. $SERVERTABLEVENTS .'_'. $year .'` ENGINE=MERGE UNION=(`'. $SERVERTABLEVENTS .'_'. $year .'_01`, `'. $SERVERTABLEVENTS .'_'. $year .'_02`, `'. $SERVERTABLEVENTS .'_'. $year .'_03`, `'. $SERVERTABLEVENTS .'_'. $year .'...
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
}
if ($rv) { print EMAILREPORT "MERGED\n\n"; } else { print EMAILREPORT "NOT MERGED, PLEASE VERIFY '$sql'\n\n"; }
}
applications/archive.pl view on Meta::CPAN
if ($debug) {
print "\nTable: '$SERVERTABLEVENTS', Year: '$year' Quarter: 'Q$quarter', Status: MERGE\n";
} else {
print EMAILREPORT "\nTable: '$SERVERTABLEVENTS', Year: '$year' Quarter: 'Q$quarter', Status: MERGE\n";
$sql = 'DROP TABLE IF EXISTS `'. $SERVERTABLEVENTS .'_'. $year .'_Q'. $quarter .'`';
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
if ($rv) {
$sql = 'CREATE TABLE IF NOT EXISTS `'. $SERVERTABLEVENTS .'_'. $year .'_Q'. $quarter .'` LIKE `'. $SERVERTABLEVENTS .'_'. $year .'_'. sprintf ("%02d", ($quarter * 3 ) - 2) .'`';
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
}
if ($rv) {
$sql = 'ALTER TABLE `'. $SERVERTABLEVENTS .'_'. $year .'_Q'. $quarter .'` ENGINE=MERGE UNION=(`'. $SERVERTABLEVENTS .'_'. $year .'_'. sprintf ("%02d", ($quarter * 3 ) - 2) .'`, `'. $SERVERTABLEVENTS .'_'. $year .'_'. sprintf ("%02d", ($qu...
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
}
if ($rv) { print EMAILREPORT "MERGED\n\n"; } else { print EMAILREPORT "NOT MERGED, PLEASE VERIFY '$sql'\n\n"; }
}
}
applications/archive.pl view on Meta::CPAN
if ($rv) {
if ($debug) {
print "\nTable: '$SERVERTABLCOMMENTS', Year: '$year'\n<$sql>\n";
} else {
print EMAILREPORT "\nTable: '$SERVERTABLCOMMENTS', Year: '$year', Status: ";
$dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
$rv = checkTableDBI ($dbh, $DATABASE, $SERVERTABLCOMMENTS .'_'. $year, 'check', 'status', 'OK');
if ($rv) { print EMAILREPORT "Created\n\n"; } else { print EMAILREPORT "NOT CREATED, PLEASE VERIFY\n\n"; }
}
} else {
print "Table: '$SERVERTABLCOMMENTS', Year: '$year', Status: ALREADY CREATED\n\n" if ($debug);
}
$dbh->disconnect or $rv = errorTrapDBI("Sorry, the database was unable to add your entry.", $debug);
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub doBackupCsvSqlErrorWeekDebugReport {
my ($RESULTSPATH, $DEBUGDIR, $REPORTDIR, $gzipEpoch, $removeAllNokEpoch, $removeGzipEpoch, $removeDebugEpoch, $removeReportsEpoch, $removeWeeksEpoch, $firstDayOfWeekEpoch, $yesterdayEpoch, $currentEpoch) = @_;
print EMAILREPORT "\nDo backup, csv, sql, error, week, and debug files:\n--------------------------------------------------\n" unless ( $debug );
my ($darchivelist, $dtest, $pagedir, $ttest, $command, $rvOpendir, $path, $filename, $debugPath, $debugFilename, $reportPath, $reportFilename, $weekFilename);
my @files = ();
foreach $darchivelist (@archivelisttable) {
($pagedir, $ttest) = split(/\#/, $darchivelist, 2);
applications/archive.pl view on Meta::CPAN
if ($datum le get_yearMonthDay($gzipEpoch)) {
if ($debug) {
print "C+ <$datum><", get_yearMonthDay($gzipEpoch), "><$path><$filename>\n";
} else {
print EMAILREPORT "C+ <$datum><", get_yearMonthDay($gzipEpoch), "> gzip <$path><$filename>\n";
my ($status, $stdout, $stderr) = call_system ('gzip --force '.$path.'/'.$filename, $debug);
print EMAILREPORT "C+ E R R O R: <$stderr>\n" unless ( $status );
}
}
} elsif ( $staart eq "$command-$catalogID_uKey-csv.txt.gz" ) {
if ($datum le get_yearMonthDay($removeGzipEpoch)) {
if ($debug) {
applications/archive.pl view on Meta::CPAN
if ( $jaarWeekFilename lt $jaarWeekYesterday ) {
if ($debug) {
print "CW+<$jaarWeekYesterday><$jaarWeekFilename><$path><$filename>\n";
} else {
print EMAILREPORT "CW+<$jaarWeekYesterday><$jaarWeekFilename> gzip <$path><$filename>\n";
my ($status, $stdout, $stderr) = call_system ('gzip --force '.$path.'/'.$filename, $debug);
print EMAILREPORT "CW+ E R R O R: <$stderr>\n" unless ( $status );
}
}
} elsif ( $staart eq "$command-$catalogID_uKey-csv-week.txt.gz" ) {
my ($jaar, $week) = split(/w/, $datum);
my $jaarWeekFilename = int($jaar.$week);
applications/archive.pl view on Meta::CPAN
# Init parameters
# my ($rv, $dbh, $sql);
# open connection to database and query data
# $rv = 1;
# $dbh = DBI->connect("dbi:mysql:$DATABASE:$SERVERNAMEREADWRITE:$SERVERPORTREADWRITE", "$SERVERUSERREADWRITE", "$SERVERPASSREADWRITE" ) or $rv = errorTrapDBI("Cannot connect to the database", $debug);
# if ($dbh and $rv) {
# $sql = "LOAD DATA LOW_PRIORITY LOCAL INFILE '$path/$filename' INTO TABLE $SERVERTABLEVENTS FIELDS TERMINATED BY ',' ENCLOSED BY '\"' LINES TERMINATED BY '\\n'";
# $dbh->do( $sql ) or $rv = errorTrapDBI("Cannot dbh->do: $sql", $debug);
# if ( $rv ) {
# my $mysqlInfo = $dbh->{mysql_info};
# my ($records, $deleted, $skipped, $warnings) = ($mysqlInfo =~ /^Records:\s+(\d+)\s+Deleted:\s+(\d+)\s+Skipped:\s+(\d+)\s+Warnings: (\d+)$/);
# if ($deleted eq '0' and $skipped eq '0' and $warnings eq '0') {
# print EMAILREPORT "S+ LOAD DATA ... : $records record(s) added for $filename\n";
# my ($status, $stdout, $stderr) = call_system ('gzip --force '.$path.'/'.$filename, $debug);
# print EMAILREPORT "S+ E R R O R: <$stderr>\n" unless ( $status );
# } else {
# print EMAILREPORT "S+ LOAD DATA ... WARNING for $filename: $mysqlInfo, <$records> <$deleted> <$skipped> <$warnings>\n";
# rename("$path/$filename", "$path/$filename-LOAD-DATA-FAILED");
# }
# }
# $dbh->disconnect or $rv = errorTrapDBI("Sorry, the database was unable to add your entry.", $debug);
# }
my $_debug = ( ( $debug eq 'T' ) ? 1 : 0);
my $dbh = CSV_prepare_table ("$path/", $filename, '', $SERVERTABLEVENTS, \@EVENTS, \%EVENTS, \$logger, $_debug);
my $rv = CSV_import_from_table (1, $dbh, $SERVERTABLEVENTS, \@EVENTS, 'id', $doForce, \$logger, $_debug);
applications/archive.pl view on Meta::CPAN
if ( $rv ) {
if ($debug) {
print "S+ IMPORT CSV DATA ... OK: ALL records imported from $path/$filename\n";
} else {
print EMAILREPORT "S+ IMPORT CSV DATA ... OK: ALL records imported from $path/$filename\n";
my ($status, $stdout, $stderr) = call_system ('gzip --force '.$path.'/'.$filename, $debug);
print EMAILREPORT "S+ E R R O R: <$stderr>\n" unless ( $status );
}
} else {
if ($debug) {
print "S- IMPORT CSV DATA ... CRITICAL: ZERO records imported from $path/$filename\n";
} else {
applications/archive.pl view on Meta::CPAN
} else {
print EMAILREPORT "S- <$datum><", get_yearMonthDay($removeGzipEpoch), "> unlink <$path><$filename>\n";
unlink ($path.'/'.$filename);
}
}
} elsif ( $staart eq "$command-$catalogID_uKey-sql-error.txt" ) {
if ($datum le get_yearMonthDay($removeGzipEpoch)) {
if ($debug) {
print "SE-<$datum><", get_yearMonthDay($removeDebugEpoch), "><$path><$filename>\n";
} else {
print EMAILREPORT "SE-<$datum><", get_yearMonthDay($removeDebugEpoch), "> unlink <$path><$filename>\n";
applications/archive.pl view on Meta::CPAN
if ($datum le get_yearMonthDay($gzipDebugEpoch)) {
if ($debug) {
print "HT+<$datum><".get_yearMonthDay($gzipDebugEpoch)."><$debugPath><$debugFilename>\n";
} else {
print EMAILREPORT "HT+<$datum><".get_yearMonthDay($gzipDebugEpoch)."> gzip <$debugPath><$debugFilename>\n";
my ($status, $stdout, $stderr) = call_system ('gzip --force '.$debugPath.'/'.$debugFilename, $debug);
print EMAILREPORT "HT+ E R R O R: <$stderr>\n" unless ( $status );
}
}
} elsif ( $extentie eq 'htm.gz' ) {
if ($datum le get_yearMonthDay($removeDebugEpoch)) {
if ($debug) {
applications/archive.pl view on Meta::CPAN
if ($removeCgisessEpoch > $session{_SESSION_CTIME}) {
if ($debug) {
print "CS <$cgisessPathFilename><" .$session{_SESSION_CTIME}. ">\n";
} else {
print EMAILREPORT "CS unlink <$cgisessPathFilename><" .$session{_SESSION_CTIME}. ">\n";
my ($status, $stdout, $stderr) = call_system ('rm -f '.$cgisessPathFilename, $debug); # unlink ($cgisessPathFilename);
}
} else {
print "CS-<$cgisessPathFilename><$removeCgisessEpoch><" .$session{_SESSION_CTIME}. ">\n" if ($debug >= 2);
}
} else {
applications/archive.pl view on Meta::CPAN
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub errorTrapDBI {
my ($error_message, $debug) = @_;
print EMAILREPORT " DBI Error:\n", $error_message, "\nERROR: $DBI::err ($DBI::errstr)\n";
return 0;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ASP
view release on metacpan or search on metacpan
=head2 AddDeathHook LIST
Allows cleanup code to be executed when you C<die> or C<exit>.
Useful for closing database connections in the event of a
fatal error.
<%
my $conn = Win32::OLE-new('ADODB.Connection');
$conn->Open("MyDSN");
$conn->BeginTrans();
ASP4-PSGI
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
ASP4
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
ASP4x-Captcha-Imager
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
ASP4x-Linker
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
ASP4x-Router
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
AUBBC
view release on metacpan or search on metacpan
our $VERSION = '4.06';
our $BAD_MESSAGE = 'Unathorized';
our $DEBUG_AUBBC = 0;
our $MEMOIZE = 1;
my $msg = '';
my $aubbc_error = '';
my $long_regex = '[\w\.\/\-\~\@\:\;\=]+(?:\?[\w\~\.\;\:\,\$\-\+\!\*\?\/\=\&\@\#\%]+?)?';
my @do_f = (1,1,1,1,1,0,0,0,time.$$.'000','',1);
my @key64 = ('A'..'Z','a'..'z',0..9,'+','/');
my %SMILEYS = ();
my %Build_AUBBC = ();
Memoize::memoize('AUBBC::add_build_tag');
Memoize::memoize('AUBBC::do_all_ubbc');
Memoize::memoize('AUBBC::script_escape');
Memoize::memoize('AUBBC::html_to_text');
}
$aubbc_error .= $@."\n" if $@;
}
return bless {};
}
sub DESTROY {
$NewTag{function2} = $NewTag{function} || 'undefined!';
$NewTag{function} = check_subroutine($NewTag{function},'')
if $NewTag{type} ne '4';
$self->aubbc_error("Usage: add_build_tag - function 'Undefined subroutine' => $NewTag{function2}")
if ! $NewTag{function};
if ($NewTag{function}) {
$NewTag{pattern} = 'l' if $NewTag{type} eq '3' || $NewTag{type} eq '4';
if ($NewTag{type} && $NewTag{name} =~ m/\A[\w\-]+\z/ && $NewTag{pattern} =~ m/\A[lns_:\-,]+|all\z/) {
$NewTag{pattern} .= $is_pat{$_} || '' foreach @pat_split;
}
$Build_AUBBC{$NewTag{name}} = [$NewTag{pattern}, $NewTag{type}, $NewTag{function}];
$NewTag{level} ||= 0;
$NewTag{error} ||= $BAD_MESSAGE;
$Tag_SecLVL{$NewTag{name}} = {level => $NewTag{level}, text => $NewTag{error},};
$do_f[5] = 1 if !$do_f[5];
warn 'Added Build_AUBBC Tag '.$Build_AUBBC{$NewTag{name}} if $DEBUG_AUBBC && $Build_AUBBC{$NewTag{name}};
}
else {
$self->aubbc_error('Usage: add_build_tag - Bad name or pattern format');
}
}
}
sub remove_build_tag {
sub version {
my $self = shift;
return $VERSION;
}
sub aubbc_error {
my ($self, $error) = @_;
defined $error && $error
? $aubbc_error .= $error . "\n"
: return $aubbc_error;
}
1;
__END__
AVLTree
view release on metacpan or search on metacpan
incurs a performance overhead.
WARNING:
setting this macro involves additional changes to the XS code. For example, if the XS file has static functions that
call into the Perl API, you'll get somewhat cryptic error messages like the following:
/usr/lib/i386-linux-gnu/perl/5.20/CORE/perl.h:155:16: error: ‘my_perl’ undeclared (first use in this function)
# define aTHX my_perl
See http://perldoc.perl.org/perlguts.html#How-do-I-use-all-this-in-extensions? for ways in which to avoid these
errors when using the macro.
One way is to begin each static function that invoke the perl API with the dTHX macro to fetch context. This is
used in the following static functions.
Another more efficient approach is to prepend pTHX_ to the argument list in the declaration of each static
function and aTHX_ when each of these functions are invoked. This is used directly in the AVL tree library
static SV* callback = (SV*)NULL;
static int svcompare(SV *p1, SV *p2) {
/*
This is one way to avoid the above mentioned error when
declaring the PERL_NO_GET_CONTEXT macro
*/
dTHX;
int cmp;
( run in 0.882 second using v1.01-cache-2.11-cpan-49f99fa48dc )