Result:
found more than 557 distributions - search limited to the first 2001 files matching your query
( run in 0.877 )
API-MailboxOrg
view release on metacpan or search on metacpan
lib/API/MailboxOrg/APIBase.pm view on Meta::CPAN
json => $rpc_data,
);
my $response = $tx->res;
if ( $tx->error ) {
carp $tx->error->{message};
return;
}
my $data = $response->json;
if ( $data->{error} ) {
carp $data->{error}->{message};
return;
}
return $data->{result};
}
API-Medium
view release on metacpan or search on metacpan
lib/API/Medium.pm view on Meta::CPAN
}
if ( $res->{success} ) {
return decode_json( $res->{content} );
}
else {
$log->errorf( "Could not talk to medium: %i %s",
$res->{status}, $res->{reason} );
die join( ' ', $res->{status}, $res->{reason} );
}
}
lib/API/Medium.pm view on Meta::CPAN
=head2 create_post
my $url = $m->create_post( $user_id, $post_data );
Create a new post. If you pass in bad data, Medium will probably
report an error.
C<publishStatus> is set to 'draft' unless you pass in another value.
=head2 create_publication_post
lib/API/Medium.pm view on Meta::CPAN
Create a new post under a publication. You will need to figure out the
publication_id by calling the API from the commandline (until
C<publications> is implemented.)
If you pass in bad data, Medium will probably report an error.
C<publishStatus> is set to 'draft' unless you pass in another value.
=head2 TODO
API-MikroTik
view release on metacpan or search on metacpan
lib/API/MikroTik.pm view on Meta::CPAN
use constant DEBUG => $ENV{API_MIKROTIK_DEBUG} || 0;
use constant PROMISES => !!(eval { require Mojo::Promise; 1 });
our $VERSION = 'v0.242';
has error => '';
has host => '192.168.88.1';
has ioloop => sub { Mojo::IOLoop->new() };
has password => '';
has port => 0;
has timeout => 10;
lib/API/MikroTik.pm view on Meta::CPAN
return $p;
}
sub subscribe {
do { $_[0]->{error} = 'can\'t subscribe in blocking mode'; return; }
unless ref $_[-1] eq 'CODE';
my $cb = pop;
my ($self, $cmd, $attr, $query) = @_;
$attr->{'.subscription'} = 1;
return $self->_command(Mojo::IOLoop->singleton, $cmd, $attr, $query, $cb);
lib/API/MikroTik.pm view on Meta::CPAN
$self->{handles}{$loop} = $stream;
weaken $self;
$stream->on(read => sub { $self->_read($loop, $_[1]) });
$stream->on(
error => sub { $self and $self->_fail_all($loop, $_[1]) });
$stream->on(close => sub { $self && $self->_close($loop) });
$self->_login(
$loop,
sub {
lib/API/MikroTik.pm view on Meta::CPAN
sub _finish {
my ($self, $r, $err) = @_;
delete $self->{requests}{$r->{tag}};
if (my $timer = $r->{timeout}) { $r->{loop}->remove($timer) }
$r->{cb}->($self, ($self->{error} = $err // ''), $r->{data});
}
sub _login {
my ($self, $loop, $cb) = @_;
warn "-- trying to log in\n" if DEBUG;
lib/API/MikroTik.pm view on Meta::CPAN
my $list = $api->command(
'/interface/print',
{'.proplist' => '.id,name,type'},
{type => ['ipip-tunnel', 'gre-tunnel'], running => 'true'}
);
if (my $err = $api->error) { die "$err\n" }
printf "%s: %s\n", $_->{name}, $_->{type} for @$list;
# Non-blocking
my $tag = $api->command(
lib/API/MikroTik.pm view on Meta::CPAN
=head1 ATTRIBUTES
L<API::MikroTik> implements the following attributes.
=head2 error
my $last_error = $api->error;
Keeps an error from last L</command> call. Empty string on successful commands.
=head2 host
my $host = $api->host;
$api = $api->host('border-gw.local');
lib/API/MikroTik.pm view on Meta::CPAN
my $command = '/interface/print';
my $attr = {'.proplist' => '.id,name,type'};
my $query = {type => ['ipip-tunnel', 'gre-tunnel'], running => 'true'};
my $list = $api->command($command, $attr, $query);
die $api->error if $api->error;
for (@$list) {...}
$api->command('/user/set', {'.id' => 'admin', comment => 'System admin'});
# Non-blocking
lib/API/MikroTik.pm view on Meta::CPAN
# 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};
}
Executes a command on a remote host and returns L<Mojo::Collection> with hashrefs
containing elements returned by a host. You can append a callback for non-blocking
calls.
In a case of error it may return extra attributes to C<!trap> or C<!fatal> API
replies in addition to error messages in an L</error> attribute or an C<$err>
argument. You should never rely on defines of the result to catch errors.
For a query syntax refer to L<API::MikroTik::Query>.
=head2 command_p
API-Octopart
view release on metacpan or search on metacpan
lib/API/Octopart.pm view on Meta::CPAN
$response = $ua->request($req);
if (!$response->is_success)
{
$tries++;
print STDERR "query error, retry $tries. "
. $response->code . ": "
. $response->message . "\n";
sleep 2**$tries;
}
else
lib/API/Octopart.pm view on Meta::CPAN
}
my $j = from_json($content);
if (!$j->{errors})
{
if ($hashfile)
{
open(my $out, ">", $hashfile) or die "$hashfile: $!";
print $out $content;
close($out);
}
}
else
{
my %errors;
foreach my $e (@{ $j->{errors} })
{
$errors{$e->{message}}++;
}
die "Octopart: " . join("\n", keys(%errors)) . "\n";
}
if ($self->{json_debug})
{
if ($hashfile)
API-ParallelsWPB
view release on metacpan or search on metacpan
lib/API/ParallelsWPB.pm view on Meta::CPAN
for my $site ( @{ $response->response } ) {
say "UUID: ". $site->{uuid};
}
}
else {
warn "Error occured: " . $response->error . ", Status: " . $response->status;
}
=head1 METHODS
=head2 B<new($class, %param)>
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/Accounts.pm view on Meta::CPAN
'status' => 'ok',
'expiration' => '-1',
'tmpl_id' => '1',
'id' => '15'
} ],
'error_codes' => ''
}, 'API::Plesk::Response' );
=cut
# Create element
lib/API/PleskExpand/Accounts.pm view on Meta::CPAN
'tmpl_id' => '1',
'id' => '15',
'plesk_client_id' => '384',
'login' => 'suxdffffxx'
} ],
'error_codes' => ''
}, 'API::Plesk::Response' );
Example (client deactivation):
lib/API/PleskExpand/Accounts.pm view on Meta::CPAN
'answer_data' => [ {
'server_id' => '1',
'status' => 'ok',
'id' => '15'
} ],
'error_codes' => ''
}, 'API::Plesk::Response' );
Example:
print Dumper $client->Accounts->delete( id => 11 );
lib/API/PleskExpand/Accounts.pm view on Meta::CPAN
# GET response handler
# STATIC
sub get_response_parse {
my $answer = abstract_parser('get', +shift, [ ], 'system_error' );
if (ref $answer eq 'ARRAY') {
for my $domain (@$answer) {
$domain->{data} = xml_extract_values($domain->{data} =~ m#<gen_info>(.*?)</gen_info>#);
}
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;
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 ($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
$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;
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},
});
APP-REST-RestTestSuite
view release on metacpan or search on metacpan
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
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')
}
## 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
{
}
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-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
# "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
$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}})
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
ARSObject
view release on metacpan or search on metacpan
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(@_)
}
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
}
$tc
}
sub ars_errstr {# Last ARS error
$ARS::ars_errstr
}
lib/ARSObject.pm view on Meta::CPAN
$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
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}));
}
}
}
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
: ($_->{-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
$err =$@;
last
}
$act =undef;
if (!$arv) {
&$emsg($s, $err ||"Unknown 'cfpaction' error");
$err =1;
last;
}
}
if ($f->{-key}) {
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;
}
lib/ARSObject.pm view on Meta::CPAN
$err =$@;
last;
}
$act =undef;
if (!$arv) {
&$emsg($s, $err ||"Unknown 'cfpaction' error");
$err =1;
last;
}
}
if ($f->{-key}) {
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 {
# 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;
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
# 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+)$/);
applications/archive.pl view on Meta::CPAN
# 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
} 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
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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;
AWS-CLIWrapper
view release on metacpan or search on metacpan
lib/AWS/CLIWrapper.pm view on Meta::CPAN
region => $region,
opt => \@opt,
json => JSON->new,
param => \%param,
awscli_path => $param{awscli_path} || 'aws',
croak_on_error => !!$param{croak_on_error},
timeout => (defined $ENV{AWS_CLIWRAPPER_TIMEOUT}) ? $ENV{AWS_CLIWRAPPER_TIMEOUT} : 30,
}, $class;
return $self;
}
lib/AWS/CLIWrapper.pm view on Meta::CPAN
};
}
return $AWSCLI_VERSION;
}
sub catch_error_pattern {
my ($self) = @_;
return $ENV{AWS_CLIWRAPPER_CATCH_ERROR_PATTERN}
if defined $ENV{AWS_CLIWRAPPER_CATCH_ERROR_PATTERN};
return $self->{param}->{catch_error_pattern}
if defined $self->{param}->{catch_error_pattern};
return;
}
sub catch_error_retries {
my ($self) = @_;
my $retries = defined $ENV{AWS_CLIWRAPPER_CATCH_ERROR_RETRIES}
? $ENV{AWS_CLIWRAPPER_CATCH_ERROR_RETRIES}
: defined $self->{param}->{catch_error_retries}
? $self->{param}->{catch_error_retries}
: $DEFAULT_CATCH_ERROR_RETRIES;
$retries = $DEFAULT_CATCH_ERROR_RETRIES if $retries < 0;
return $retries;
}
sub catch_error_min_delay {
my ($self) = @_;
my $min_delay = defined $ENV{AWS_CLIWRAPPER_CATCH_ERROR_MIN_DELAY}
? $ENV{AWS_CLIWRAPPER_CATCH_ERROR_MIN_DELAY}
: defined $self->{param}->{catch_error_min_delay}
? $self->{param}->{catch_error_min_delay}
: $DEFAULT_CATCH_ERROR_MIN_DELAY;
$min_delay = $DEFAULT_CATCH_ERROR_MIN_DELAY if $min_delay < 0;
return $min_delay;
}
sub catch_error_max_delay {
my ($self) = @_;
my $min_delay = $self->catch_error_min_delay;
my $max_delay = defined $ENV{AWS_CLIWRAPPER_CATCH_ERROR_MAX_DELAY}
? $ENV{AWS_CLIWRAPPER_CATCH_ERROR_MAX_DELAY}
: defined $self->{param}->{catch_error_max_delay}
? $self->{param}->{catch_error_max_delay}
: $DEFAULT_CATCH_ERROR_MAX_DELAY;
$max_delay = $DEFAULT_CATCH_ERROR_MAX_DELAY if $max_delay < 0;
$max_delay = $min_delay if $min_delay > $max_delay;
return $max_delay;
}
sub catch_error_delay {
my ($self) = @_;
my $min = $self->catch_error_min_delay;
my $max = $self->catch_error_max_delay;
return $min == $max ? $min : $min + (int rand $max - $min);
}
sub param2opt {
lib/AWS/CLIWrapper.pm view on Meta::CPAN
push @cmd, @o;
}
@cmd = map { shell_quote($_) } @cmd;
warn "cmd: ".join(' ', @cmd) if $ENV{AWSCLI_DEBUG};
my $error_re = $self->catch_error_pattern;
my $retries = $error_re ? $self->catch_error_retries : 0;
RETRY: {
$Error = { Message => '', Code => '' };
my $exit_value = $self->_run(\%opt, \@cmd);
my $ret = $self->_handle($service, $operation, $exit_value);
return $ret unless $Error->{Code};
if ($retries-- > 0 and $Error->{Message} =~ $error_re) {
my $delay = $self->catch_error_delay;
warn "Caught error matching $error_re, sleeping $delay seconds before retrying\n"
if $ENV{AWSCLI_DEBUG};
sleep $delay;
redo RETRY;
}
croak $Error->{Message} if $self->{croak_on_error};
return $ret;
}
}
lib/AWS/CLIWrapper.pm view on Meta::CPAN
Additionally, the these params can be used to control the wrapper behavior:
nofork Truthy to avoid forking when executing `aws`
timeout `aws` execution timeout
croak_on_error Truthy to croak() with the error message when `aws`
exits with non-zero code
catch_error_pattern Regexp pattern to match for error handling.
catch_error_retries Retries for handling errors.
catch_error_min_delay Minimal delay before retrying `aws` call
when an error was caught.
catch_error_max_delay Maximal delay before retrying `aws` call.
See below for more detailed explanation.
=item B<accessanalyzer>($operation:Str, $param:HashRef, %opt:Hash)
lib/AWS/CLIWrapper.pm view on Meta::CPAN
default is 30 seconds, unless overridden with AWS_CLIWRAPPER_TIMEOUT environment variable.
nofork => Int (>0)
Call IPC::Cmd::run vs. IPC::Cmd::run_forked (mostly useful if/when in perl debugger). Note: 'timeout', if used with 'nofork', will merely cause an alarm and return. ie. 'run' will NOT kill the awscli command like 'run_forked' will.
croak_on_error => Int (>0)
When set to a truthy value, this will make AWS::CLIWrapper to croak() with error message when `aws` command exits with non-zero status. Default behavior is to set $AWS::CLIWrapper::Error and return.
catch_error_pattern => RegExp
When defined, this option will enable catching `aws-cli` errors matching this pattern
and retrying `aws-cli` command execution. Environment variable
AWS_CLIWRAPPER_CATCH_ERROR_PATTERN takes precedence over this option, if both
are defined.
Default is undef.
catch_error_retries => Int (>= 0)
When defined, this option will set the number of retries to make when `aws-cli` error
was caught with catch_error_pattern, before giving up. Environment variable
AWS_CLIWRAPPER_CATCH_ERROR_RETRIES takes precedence over this option, if both
are defined.
0 (zero) retries is a valid way to turn off error catching via environment variable
in certain scenarios. Negative values are invalid and will be reset to default.
Default is 3.
catch_error_min_delay => Int (>= 0)
When defined, this option will set the minimum delay in seconds before attempting
a retry of failed `aws-cli` execution when the error was caught. Environment variable
AWS_CLIWRAPPER_CATCH_ERROR_MIN_DELAY takes precedence over this option, if both
are defined.
0 (zero) is a valid value. Negative values are invalid and will be reset to default.
Default is 3.
catch_error_max_delay => Int (>= 0)
When defined, this option will set the maximum delay in seconds before attempting
a retry of failed `aws-cli` execution. Environment variable AWS_CLIWRAPPER_CATCH_ERROR_MAX_DELAY
takes precedence over this option, if both are defined.
0 (zero) is a valid value. Negative values are invalid and will be reset to default.
If catch_error_min_delay is greater than catch_error_max_delay, both are set
to catch_error_min_delay value.
Default is 10.
=back
lib/AWS/CLIWrapper.pm view on Meta::CPAN
If this variable is set, AWS::CLIWrapper will retry `aws-cli` execution if stdout output
of failed `aws-cli` command matches the pattern. See L<ERROR HANDLING>.
=item AWS_CLIWRAPPER_CATCH_ERROR_RETRIES
How many times to retry command execution if an error was caught. Default is 3.
=item AWS_CLIWRAPPER_CATCH_ERROR_MIN_DELAY
Minimal delay before retrying command execution if an error was caught, in seconds.
Default is 3.
=item AWS_CLIWRAPPER_CATCH_ERROR_MAX_DELAY
lib/AWS/CLIWrapper.pm view on Meta::CPAN
=head1 ERROR HANDLING
=over 4
By default, when `aws-cli` exits with an error code (> 0), AWS::CLIWrapper will set
the error code and message to $AWS::CLIWrapper::Error (and optionally croak), thus
relaying the error to calling code. While this approach is beneficial 99% of the time,
in some use cases `aws-cli` execution fails for a temporary reason unrelated to
both calling code and AWS::CLIWrapper, and can be safely retried after a short delay.
One of this use cases is executing `aws-cli` on AWS EC2 instances, where `aws-cli`
retrieves its configuration and credentials from the API exposed to the EC2 instance;
at certain times these credentials may be rotated and calling `aws-cli` at exactly
the right moment will cause it to fail with `Unable to locate credentials` error.
To prevent this kind of errors from failing the calling code, AWS::CLIWrapper allows
configuring an RegExp pattern and retry `aws-cli` execution if it fails with an error
matching the configured pattern.
The error catching pattern, as well as other configuration, can be defined either
as AWS::CLIWrapper options in the code, or as respective environment variables
(see L<ENVIRONMENT>).
The actual delay before retrying a failed `aws-cli` execution is computed as a
random value of seconds between catch_error_min_delay (default 3) and catch_error_max_delay
(default 10). Backoff is not supported at this moment.
=back
=head1 AUTHOR
AWS-CloudFront
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:
AWS-Lambda
view release on metacpan or search on metacpan
lib/AWS/Lambda/Bootstrap.pm view on Meta::CPAN
package main;
require "${task_root}/${handler}.pl";
my $f = main->can($name) // die "handler $name is not found";
$self->{function} = $f;
} catch {
$self->lambda_init_error($_);
$self->{function} = sub {};
undef;
};
}
lib/AWS/Lambda/Bootstrap.pm view on Meta::CPAN
local $ENV{_X_AMZN_TRACE_ID} = $context->{trace_id};
$self->{function}->($payload, $context);
} catch {
my $err = $_;
print STDERR "$err";
$self->lambda_error($err, $context);
bless {}, 'AWS::Lambda::ErrorSentinel';
};
my $ref = ref($response);
if ($ref eq 'AWS::Lambda::ErrorSentinel') {
return;
lib/AWS/Lambda/Bootstrap.pm view on Meta::CPAN
});
} catch {
my $err = $_;
print STDERR "$err";
if ($writer) {
$writer->_close_with_error($err);
} else {
$self->lambda_error($err, $context);
}
};
if ($writer) {
my $response = $writer->_handle_response;
if (!$response->{success}) {
die "failed to response of execution: $response->{status} $response->{reason}";
}
}
}
sub lambda_error {
my $self = shift;
my ($error, $context) = @_;
my $runtime_api = $self->{runtime_api};
my $api_version = $self->{api_version};
my $request_id = $context->aws_request_id;
my $url = "http://${runtime_api}/${api_version}/runtime/invocation/${request_id}/error";
my $type = blessed($error) // "Error";
my $resp = $self->{http}->post($url, {
content => encode_json({
errorMessage => "$error",
errorType => "$type",
}),
});
if (!$resp->{success}) {
die "failed to send error of execution: $resp->{status} $resp->{reason}";
}
}
sub lambda_init_error {
my $self = shift;
my $error = shift;
my $runtime_api = $self->{runtime_api};
my $api_version = $self->{api_version};
my $url = "http://${runtime_api}/${api_version}/runtime/init/error";
my $type = blessed($error) // "Error";
my $resp = $self->{http}->post($url, {
content => encode_json({
errorMessage => "$error",
errorType => "$type",
}),
});
if (!$resp->{success}) {
die "failed to send error of execution: $resp->{status} $resp->{reason}";
}
}
1;
__END__
( run in 0.877 second using v1.01-cache-2.11-cpan-65fba6d93b7 )