Result:
found more than 265 distributions - search limited to the first 2001 files matching your query
( run in 0.526 )
AUBBC
view release on metacpan or search on metacpan
code => { level => 0, text => $BAD_MESSAGE, },
img => { level => 0, text => $BAD_MESSAGE, },
url => { level => 0, text => $BAD_MESSAGE, },
);
sub security_levels {
my ($self,@s_levels) = @_;
$do_f[10] = 0;
@s_levels
? @security_levels = @s_levels
: return @security_levels;
}
sub user_level {
my ($self,$u_level) = @_;
$do_f[10] = 0;
defined $u_level
? $user_level = $u_level
: return $user_level;
}
sub tag_security {
my ($self,%s_tags) = @_;
%s_tags
? %Tag_SecLVL = %s_tags
: return %Tag_SecLVL;
}
sub check_access {
my $tag = shift;
unless ($do_f[10]) {
$do_f[10] = 1;
($high_level, $user_key) = (scalar(@security_levels), 0);
? return 1
: return '';
}
}
sub new {
warn 'CREATING AUBBC '.$VERSION if $DEBUG_AUBBC;
if ($MEMOIZE && ! $do_f[7]) {
$do_f[7] = 1;
eval 'use Memoize' if ! defined $Memoize::VERSION;
unless ($@ || ! defined $Memoize::VERSION) {
$aubbc_error .= $@."\n" if $@;
}
return bless {};
}
sub DESTROY {
warn 'DESTROY AUBBC '.$VERSION if $DEBUG_AUBBC;
}
sub settings_prep {
$AUBBC{href_target} = $AUBBC{href_target} ? ' target="_blank"' : '';
$AUBBC{image_wrap} = $AUBBC{image_wrap} ? ' ' : '';
$AUBBC{image_border} = $AUBBC{image_border} ? '1' : '0';
$AUBBC{html_type} = $AUBBC{html_type} eq 'xhtml' || $AUBBC{html_type} eq ' /' ? ' /' : '';
}
sub settings {
my ($self,%s_hash) = @_;
foreach (keys %s_hash) {
if ('highlight_function' eq $_) {
$AUBBC{highlight} = 0;
$s_hash{$_} = check_subroutine($s_hash{$_},'');
$uabbc_settings .= $_ . ' =>' . $AUBBC{$_} . ', ' foreach keys %AUBBC;
warn 'AUBBC Settings Change: '.$uabbc_settings;
}
}
sub get_setting {
my ($self,$name) = @_;
return $AUBBC{$name} if exists $AUBBC{$name};
}
sub code_highlight {
my $txt = shift;
warn 'ENTER code_highlight' if $DEBUG_AUBBC;
$txt =~ s/:/:/g;
$txt =~ s/\[/[/g;
$txt =~ s/\]/]/g;
$txt =~ s/(?<!\)((?:%|\$|\@)\w+(?:(?:[.+?]|{.+?})+|))/<span$AUBBC{highlight_class7}>$1<\/span>/g;
}
return $txt;
}
sub code_download {
if ($AUBBC{code_download}) {
$do_f[8]++;
$do_f[9] =
make_link('javascript:void(0)',$AUBBC{code_download}, "javascript:MyCodePrint('aubbcode$do_f[8]');",'');
return " id=\"aubbcode$do_f[8]\"";
} else { return ''; }
}
sub code_tag {
my ($code,$name) = @_;
if (check_access('code')) {
$name = "# $name:<br$AUBBC{html_type}>\n" if $name;
return "$name<div$AUBBC{code_class}".&code_download."><code>\n".
$AUBBC{highlight_function}->($code).
else {
return $Tag_SecLVL{code}{text};
}
}
sub make_image {
my ($align,$src,$width,$height,$alt) = @_;
my $img = "<img$align src=\"$src\"";
$img .= " width=\"$width\"" if $width;
$img .= " height=\"$height\"" if $height;
return $img." alt=\"$alt\" border=\"$AUBBC{image_border}\"$AUBBC{html_type}>";
}
sub make_link {
my ($link,$name,$javas,$targ) = @_;
my $linkd = "<a href=\"$link\"";
$linkd .= " onclick=\"$javas\"" if $javas;
$linkd .= $AUBBC{href_target} if $targ;
$linkd .= $AUBBC{href_class}.'>';
$linkd .= $name ? $name : $link;
return $linkd.'</a>';
}
sub do_ubbc {
warn 'ENTER do_ubbc' if $DEBUG_AUBBC;
$msg =~ s/\[(?:c|code)\](?s)(.+?)\[\/(?:c|code)\]/code_tag($1, '')/ge;
$msg =~ s/\[(?:c|code)=(.+?)\](?s)(.+?)\[\/(?:c|code)\]/code_tag($2, $1)/ge;
$do_f[9] = '' if $do_f[9];
$msg =~ s/\[url=(\w+\:\/\/$long_regex)\](.+?)\[\/url\]/link_check($1,fix_message($2),'',1)/ge;
$msg =~ s/(?<!["=\.\/\'\[\{\;])((?:\b\w+\b\:\/\/)$long_regex)/link_check($1,$1,'',1)/ge;
}
sub link_check {
my ($link,$name,$javas,$targ) = @_;
check_access('url')
? make_link($link,$name,$javas,$targ)
: return $Tag_SecLVL{url}{text};
}
sub fix_list {
my $list = shift;
if ($list =~ m/\[\*/) {
$list =~ s/<br$AUBBC{html_type}>//g;
my $type = 'ul';
$type = 'ol' if $list =~ s/\[\*=(\d+)\]/\[\*\]$1\|/g;
$list .= "<\/$type>";
}
return $list;
}
sub fix_image {
my ($tmp2, $tmp) = @_;
if (check_access('img')) {
if ($tmp !~ m/\A\w+:\/\/|\// || $tmp =~ m/\?|\#|\.\bjs\b\z/i) {
$tmp = "[<font color=red>$BAD_MESSAGE</font>]$tmp2";
}
else {
return $Tag_SecLVL{img}{text};
}
}
sub protect_email {
my $em = shift;
if (check_access('url')) {
my ($email1, $email2, $ran_num, $protect_email, @letters) =
('', '', '', '', split (//, $em));
$protect_email = '[' if $AUBBC{protect_email} eq 3 || $AUBBC{protect_email} eq 4;
else {
return $Tag_SecLVL{url}{text};
}
}
sub js_print {
my $self = shift;
print <<JS;
Content-type: text/javascript
/*
}
JS
exit(0);
}
sub do_build_tag {
warn 'ENTER do_build_tag' if $DEBUG_AUBBC;
foreach (keys %Build_AUBBC) {
warn 'ENTER foreach do_build_tag' if $DEBUG_AUBBC;
$msg =~ s/(\[$_\:\/\/([$Build_AUBBC{$_}[0]]+)\])/
check_access($_) ? $Build_AUBBC{$_}[2] : $Tag_SecLVL{$_}{text};
/eg if $Build_AUBBC{$_}[1] eq '4';
}
}
sub do_sub {
my ($key, $term, $fun) = @_;
warn 'ENTER do_sub' if $DEBUG_AUBBC;
check_access($key)
? return $fun->($key, $term) || ''
: return $Tag_SecLVL{$key}{text};
}
sub check_subroutine {
my $name = shift;
defined $name && exists &{$name} && (ref $name eq 'CODE' || ref $name eq '')
? return \&{$name}
: return '';
}
sub add_build_tag {
my ($self,%NewTag) = @_;
warn 'ENTER add_build_tag' if $DEBUG_AUBBC;
$NewTag{function2} = $NewTag{function} || 'undefined!';
$NewTag{function} = check_subroutine($NewTag{function},'')
$self->aubbc_error('Usage: add_build_tag - Bad name or pattern format');
}
}
}
sub remove_build_tag {
my ($self,$name,$type) = @_;
warn 'ENTER remove_build_tag' if $DEBUG_AUBBC;
delete $Build_AUBBC{$name} if exists $Build_AUBBC{$name} && !$type; # clear one
%Build_AUBBC = () if $type && !$name; # clear all
}
sub do_unicode{
warn 'ENTER do_unicode' if $DEBUG_AUBBC;
$msg =~ s/\[utf:\/\/(\#?\w+)\]/&$1;/g;
}
sub do_smileys {
warn 'ENTER do_smileys' if $DEBUG_AUBBC;
$msg =~
s/\[$_\]/make_image('',"$AUBBC{images_url}\/smilies\/$SMILEYS{$_}",'','',$_).$AUBBC{image_wrap}/ge
foreach keys %SMILEYS;
}
sub smiley_hash {
my ($self,%s_hash) = @_;
warn 'ENTER smiley_hash' if $DEBUG_AUBBC;
if (keys %s_hash) {
%SMILEYS = %s_hash;
$do_f[6] = 1;
}
}
sub do_all_ubbc {
my ($self,$message) = @_;
warn 'ENTER do_all_ubbc' if $DEBUG_AUBBC;
$msg = defined $message ? $message : '';
if ($msg) {
check_access();
}
$msg =~ tr/\000//d if $AUBBC{aubbc_escape};
return $msg;
}
sub fix_message {
my $txt = shift;
$txt =~ s/\././g;
$txt =~ s/\:/:/g;
return $txt;
}
sub escape_aubbc {
warn 'ENTER escape_aubbc' if $DEBUG_AUBBC;
$msg =~ s/\[\[/\000[/g;
$msg =~ s/\]\]/\000]/g;
}
sub script_escape {
my ($self, $text, $option) = @_;
warn 'ENTER html_escape' if $DEBUG_AUBBC;
$text = '' unless defined $text;
if ($text) {
$text =~ s/(&|;)/$1 eq '&' ? '&' : ';'/ge;
: $text =~ s/\n/<br$AUBBC{html_type}>\n/g if !$option && $AUBBC{line_break} eq '1';
return $text;
}
}
sub html_to_text {
my ($self, $html, $option) = @_;
warn 'ENTER html_to_text' if $DEBUG_AUBBC;
$html = '' unless defined $html;
if ($html) {
$html =~ s/&/&/g;
$html =~ s/<br(?:\s?\/)?>\n?/\n/g if $AUBBC{line_break};
return $html;
}
}
sub version {
my $self = shift;
return $VERSION;
}
sub aubbc_error {
my ($self, $error) = @_;
defined $error && $error
? $aubbc_error .= $error . "\n"
: return $aubbc_error;
}
AVLTree
view release on metacpan or search on metacpan
lib/AVLTree.pm view on Meta::CPAN
use AVLTree;
# Define a function to compare two numbers i1 and i2,
# return -1 if i1 < i2, 1 if i2 > i1 and 0 otherwise
sub cmp_f = sub {
my ($i1, $i2) = @_;
return $i1<$i2?-1:($i1>$i2)?1:0;
}
lib/AVLTree.pm view on Meta::CPAN
# Suppose you want the tree to hold generic data items, e.g. hashrefs
# which hold some data. We can deal with these by definying a custom
# comparison function based on one of the attributes of these data items,
# e.g. 'id':
sub compare {
my ($i1, $i2) = @_;
my ($id1, $id2) = ($i1->{id}, $i2->{id});
croak "Cannot compare items based on id"
unless defined $id1 and defined $id2;
AWS-ARN
view release on metacpan or search on metacpan
lib/AWS/ARN.pm view on Meta::CPAN
use Types::Standard qw/Str/;
use Type::Utils;
our $VERSION = '0.007';
use overload '""' => sub {
shift->arn;
};
my $partitionRe = my $serviceRe = qr{[\w-]+};
my $regionRe = qr{[\w-]*};
lib/AWS/ARN.pm view on Meta::CPAN
as Str,
where { m{^$resource_idRe$} },
message { "$_ is not a valid AWS Resource" },
);
sub _split_arn {
my $self = shift;
my ($index) = @_;
return "" unless $self->_has_arn;
my @parts = split( /:/, $self->arn, 6 );
return $parts[$index||0]||"";
lib/AWS/ARN.pm view on Meta::CPAN
isa => $ArnPartition,
lazy => 1,
builder => '_build_partition',
clearer => '_clear_partition',
default => 'aws',
trigger => sub { shift->_clear_arn },
);
has service => (
is => 'rw',
isa => $ArnService,
lazy => 1,
required => 1,
builder => '_build_service',
clearer => '_clear_service',
trigger => sub { shift->_clear_arn },
);
has region => (
is => 'rw',
isa => $ArnRegion,
lazy => 1,
builder => '_build_region',
clearer => '_clear_region',
trigger => sub { shift->_clear_arn },
);
has account_id => (
is => 'rw',
isa => $ArnAccountID,
lazy => 1,
builder => '_build_account_id',
clearer => '_clear_account_id',
trigger => sub { shift->_clear_arn },
);
has resource_id => (
is => 'rw',
isa => $ArnResourceID,
lazy => 1,
builder => '_build_resource_id',
clearer => '_clear_resource_id',
trigger => sub { shift->_clear_arn },
);
sub _build_arn {
my $self = shift;
my $arn = join( ':',
'arn',
$self->partition,
$self->service,
lib/AWS/ARN.pm view on Meta::CPAN
$self->account_id,
$self->resource_id,
);
}
sub _build_partition {
shift->_split_arn( 1 )
}
sub _build_service {
shift->_split_arn( 2 )
}
sub _build_region {
shift->_split_arn( 3 )
}
sub _build_account_id {
shift->_split_arn( 4 )
}
sub _build_resource_id {
shift->_split_arn( 5 )
}
sub _trigger_arn {
my $self = shift;
$self->_clear_partition;
$self->_clear_service;
$self->_clear_region;
$self->_clear_account_id;
$self->_clear_resource_id;
}
around BUILDARGS => sub {
my ( $orig, $class, @args ) = @_;
return { arn => $args[0] }
if @args == 1 && !ref $args[0];
AWS-CLI-Config
view release on metacpan or search on metacpan
lib/AWS/CLI/Config.pm view on Meta::CPAN
no strict 'refs';
*{__PACKAGE__ . "::$name"} = _mk_accessor($name, %{$opts});
}
}
sub _mk_accessor {
my $attr = shift;
my %opt = @_;
my $env_var = $opt{env};
my $profile_key = $opt{key} || $attr;
return sub {
if ($env_var && exists $ENV{$env_var} && $ENV{$env_var}) {
return $ENV{$env_var};
}
my $profile = shift || _default_profile();
lib/AWS/CLI/Config.pm view on Meta::CPAN
return undef;
};
}
sub credentials {
my $profile = shift || _default_profile();
$CREDENTIALS ||= _parse(
(exists $ENV{AWS_CONFIG_FILE} and $ENV{AWS_CONFIG_FILE})
? $ENV{AWS_CONFIG_FILE}
lib/AWS/CLI/Config.pm view on Meta::CPAN
$CREDENTIALS_PROFILE_OF{$profile} ||=
AWS::CLI::Config::Profile->new($CREDENTIALS->{$profile});
return $CREDENTIALS_PROFILE_OF{$profile};
}
sub config {
my $profile = shift || _default_profile();
$CONFIG ||= _parse(
(exists $ENV{AWS_CONFIG_FILE} and $ENV{AWS_CONFIG_FILE})
? $ENV{AWS_CONFIG_FILE}
lib/AWS/CLI/Config.pm view on Meta::CPAN
$CONFIG_PROFILE_OF{$profile} ||=
AWS::CLI::Config::Profile->new($CONFIG->{$profile});
return $CONFIG_PROFILE_OF{$profile};
}
sub _base_dir {
($^O eq 'MSWin32') ? $ENV{USERPROFILE} : $ENV{HOME};
}
sub _default_dir {
File::Spec->catdir(_base_dir(), '.aws');
}
sub _default_profile {
(exists $ENV{AWS_DEFAULT_PROFILE} && $ENV{AWS_DEFAULT_PROFILE})
? $ENV{AWS_DEFAULT_PROFILE}
: $DEFAULT_PROFILE;
}
# This only supports one level of nesting, but it seems AWS config files
# themselves only have but one level
sub _parse {
my $file = shift;
my $profile = shift || _default_profile();
my $hash = {};
my $nested = {};
lib/AWS/CLI/Config.pm view on Meta::CPAN
use 5.008001;
use strict;
use warnings;
sub new {
my $class = shift;
my $data = @_ ? @_ > 1 ? { @_ } : shift : {};
return bless $data, $class;
}
sub AUTOLOAD {
our $AUTOLOAD;
my $self = shift;
return if $AUTOLOAD =~ /DESTROY/;
my $method = $AUTOLOAD;
$method =~ s/.*:://;
no strict 'refs';
*{$AUTOLOAD} = sub {
return shift->{$method}
};
return $self->{$method};
}
AWS-CLIWrapper
view release on metacpan or search on metacpan
lib/AWS/CLIWrapper.pm view on Meta::CPAN
my $AWSCLI_VERSION = undef;
my $DEFAULT_CATCH_ERROR_RETRIES = 3;
my $DEFAULT_CATCH_ERROR_MIN_DELAY = 3;
my $DEFAULT_CATCH_ERROR_MAX_DELAY = 10;
sub new {
my($class, %param) = @_;
my $region = $param{region};
my @opt = ();
lib/AWS/CLIWrapper.pm view on Meta::CPAN
}, $class;
return $self;
}
sub region { shift->{region} }
sub awscli_path {
my ($self) = @_;
return $self->{awscli_path};
}
sub awscli_version {
my ($self) = @_;
unless (defined $AWSCLI_VERSION) {
$AWSCLI_VERSION = do {
my $awscli_path = $self->awscli_path;
my $vs = qx($awscli_path --version 2>&1) || '';
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};
lib/AWS/CLIWrapper.pm view on Meta::CPAN
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}
lib/AWS/CLIWrapper.pm view on Meta::CPAN
$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}
lib/AWS/CLIWrapper.pm view on Meta::CPAN
$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}
lib/AWS/CLIWrapper.pm view on Meta::CPAN
$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 {
my($k, $v) = @_;
my @v;
$k =~ s/_/-/g;
lib/AWS/CLIWrapper.pm view on Meta::CPAN
return ($k, @v);
}
# >= 0.14.0 : Key, Values, Value, Name
# < 0.14.0 : key, values, value, name
sub _compat_kv_uc {
my $v = shift;
my $type = ref $v;
if ($type && $type eq 'HASH') {
for my $hk (keys %$v) {
lib/AWS/CLIWrapper.pm view on Meta::CPAN
}
}
return $v;
}
# sub _compat_kv_lc {
# my $v = shift;
# my $type = ref $v;
# if ($type && $type eq 'HASH') {
# for my $hk (keys %$v) {
lib/AWS/CLIWrapper.pm view on Meta::CPAN
# return $v;
# }
# Drop support < 0.14.0 for preventing execute aws command in loading this module
*_compat_kv = *_compat_kv_uc;
sub json { $_[0]->{json} }
sub _execute {
my $self = shift;
my $service = shift;
my $operation = shift;
my @cmd = ($self->awscli_path, @{$self->{opt}}, $service, $operation);
if ($service eq 'ec2' && $operation eq 'wait') {
lib/AWS/CLIWrapper.pm view on Meta::CPAN
return $ret;
}
}
sub _run {
my ($self, $opt, $cmd) = @_;
my $ret;
if (exists $opt->{'nofork'} && $opt->{'nofork'}) {
# better for perl debugger
lib/AWS/CLIWrapper.pm view on Meta::CPAN
}
return $ret;
}
sub _handle {
my ($self, $service, $operation, $ret) = @_;
if ($ret->{exit_code} == 0 && $ret->{timeout} == 0) {
my $json = $ret->{stdout};
warn sprintf("%s.%s[%s]: %s\n",
lib/AWS/CLIWrapper.pm view on Meta::CPAN
# aws s3 returns null HTTP body, so failed to parse as JSON
# Temporary disable __DIE__ handler to prevent the
# exception from decode() from catching by outer
# __DIE__ handler.
local $SIG{__DIE__} = sub {};
$self->json->decode($json);
};
if ($@) {
if ($ENV{AWSCLI_DEBUG}) {
lib/AWS/CLIWrapper.pm view on Meta::CPAN
return;
}
}
# aws help | col -b | perl -ne 'if (/^AVAILABLE/.../^[A-Z]/) { s/^\s+o\s+// or next; chomp; next if $_ eq 'help'; my $sn = $_; $sn =~ s/-/_/g; printf "sub %-18s { shift->_execute('"'"'%s'"'"', \@_) }\n", $sn, $_ }'
# aws help | col -b | perl -ne 'if (/^AVAILABLE/.../^[A-Z]/) { s/^\s+o\s+// or next; chomp; next if $_ eq 'help'; my $sn = $_; $sn =~ s/-/_/g; printf "=item B<%s>(\$operation:Str, \$param:HashRef, %%opt:Hash)\n\n", $sn}'
# =item B<s3>($operation:Str, $path:ArrayRef, $param:HashRef, %opt:Hash)
sub accessanalyzer { shift->_execute('accessanalyzer', @_) }
sub account { shift->_execute('account', @_) }
sub acm { shift->_execute('acm', @_) }
sub acm_pca { shift->_execute('acm-pca', @_) }
sub alexaforbusiness { shift->_execute('alexaforbusiness', @_) }
sub amp { shift->_execute('amp', @_) }
sub amplify { shift->_execute('amplify', @_) }
sub amplifybackend { shift->_execute('amplifybackend', @_) }
sub amplifyuibuilder { shift->_execute('amplifyuibuilder', @_) }
sub apigateway { shift->_execute('apigateway', @_) }
sub apigatewaymanagementapi { shift->_execute('apigatewaymanagementapi', @_) }
sub apigatewayv2 { shift->_execute('apigatewayv2', @_) }
sub appconfig { shift->_execute('appconfig', @_) }
sub appconfigdata { shift->_execute('appconfigdata', @_) }
sub appfabric { shift->_execute('appfabric', @_) }
sub appflow { shift->_execute('appflow', @_) }
sub appintegrations { shift->_execute('appintegrations', @_) }
sub application_autoscaling { shift->_execute('application-autoscaling', @_) }
sub application_insights { shift->_execute('application-insights', @_) }
sub applicationcostprofiler { shift->_execute('applicationcostprofiler', @_) }
sub appmesh { shift->_execute('appmesh', @_) }
sub apprunner { shift->_execute('apprunner', @_) }
sub appstream { shift->_execute('appstream', @_) }
sub appsync { shift->_execute('appsync', @_) }
sub arc_zonal_shift { shift->_execute('arc-zonal-shift', @_) }
sub athena { shift->_execute('athena', @_) }
sub auditmanager { shift->_execute('auditmanager', @_) }
sub autoscaling { shift->_execute('autoscaling', @_) }
sub autoscaling_plans { shift->_execute('autoscaling-plans', @_) }
sub backup { shift->_execute('backup', @_) }
sub backup_gateway { shift->_execute('backup-gateway', @_) }
sub backupstorage { shift->_execute('backupstorage', @_) }
sub batch { shift->_execute('batch', @_) }
sub billingconductor { shift->_execute('billingconductor', @_) }
sub braket { shift->_execute('braket', @_) }
sub budgets { shift->_execute('budgets', @_) }
sub ce { shift->_execute('ce', @_) }
sub chime { shift->_execute('chime', @_) }
sub chime_sdk_identity { shift->_execute('chime-sdk-identity', @_) }
sub chime_sdk_media_pipelines { shift->_execute('chime-sdk-media-pipelines', @_) }
sub chime_sdk_meetings { shift->_execute('chime-sdk-meetings', @_) }
sub chime_sdk_messaging { shift->_execute('chime-sdk-messaging', @_) }
sub chime_sdk_voice { shift->_execute('chime-sdk-voice', @_) }
sub cleanrooms { shift->_execute('cleanrooms', @_) }
sub cloud9 { shift->_execute('cloud9', @_) }
sub cloudcontrol { shift->_execute('cloudcontrol', @_) }
sub clouddirectory { shift->_execute('clouddirectory', @_) }
sub cloudformation { shift->_execute('cloudformation', @_) }
sub cloudfront { shift->_execute('cloudfront', @_) }
sub cloudhsm { shift->_execute('cloudhsm', @_) }
sub cloudhsmv2 { shift->_execute('cloudhsmv2', @_) }
sub cloudsearch { shift->_execute('cloudsearch', @_) }
sub cloudsearchdomain { shift->_execute('cloudsearchdomain', @_) }
sub cloudtrail { shift->_execute('cloudtrail', @_) }
sub cloudtrail_data { shift->_execute('cloudtrail-data', @_) }
sub cloudwatch { shift->_execute('cloudwatch', @_) }
sub codeartifact { shift->_execute('codeartifact', @_) }
sub codebuild { shift->_execute('codebuild', @_) }
sub codecatalyst { shift->_execute('codecatalyst', @_) }
sub codecommit { shift->_execute('codecommit', @_) }
sub codeguru_reviewer { shift->_execute('codeguru-reviewer', @_) }
sub codeguru_security { shift->_execute('codeguru-security', @_) }
sub codeguruprofiler { shift->_execute('codeguruprofiler', @_) }
sub codepipeline { shift->_execute('codepipeline', @_) }
sub codestar { shift->_execute('codestar', @_) }
sub codestar_connections { shift->_execute('codestar-connections', @_) }
sub codestar_notifications { shift->_execute('codestar-notifications', @_) }
sub cognito_identity { shift->_execute('cognito-identity', @_) }
sub cognito_idp { shift->_execute('cognito-idp', @_) }
sub cognito_sync { shift->_execute('cognito-sync', @_) }
sub comprehend { shift->_execute('comprehend', @_) }
sub comprehendmedical { shift->_execute('comprehendmedical', @_) }
sub compute_optimizer { shift->_execute('compute-optimizer', @_) }
sub configservice { shift->_execute('configservice', @_) }
sub configure { shift->_execute('configure', @_) }
sub connect { shift->_execute('connect', @_) }
sub connect_contact_lens { shift->_execute('connect-contact-lens', @_) }
sub connectcampaigns { shift->_execute('connectcampaigns', @_) }
sub connectcases { shift->_execute('connectcases', @_) }
sub connectparticipant { shift->_execute('connectparticipant', @_) }
sub controltower { shift->_execute('controltower', @_) }
sub cur { shift->_execute('cur', @_) }
sub customer_profiles { shift->_execute('customer-profiles', @_) }
sub databrew { shift->_execute('databrew', @_) }
sub dataexchange { shift->_execute('dataexchange', @_) }
sub datapipeline { shift->_execute('datapipeline', @_) }
sub datasync { shift->_execute('datasync', @_) }
sub dax { shift->_execute('dax', @_) }
sub deploy { shift->_execute('deploy', @_) }
sub detective { shift->_execute('detective', @_) }
sub devicefarm { shift->_execute('devicefarm', @_) }
sub devops_guru { shift->_execute('devops-guru', @_) }
sub directconnect { shift->_execute('directconnect', @_) }
sub discovery { shift->_execute('discovery', @_) }
sub dlm { shift->_execute('dlm', @_) }
sub dms { shift->_execute('dms', @_) }
sub docdb { shift->_execute('docdb', @_) }
sub docdb_elastic { shift->_execute('docdb-elastic', @_) }
sub drs { shift->_execute('drs', @_) }
sub ds { shift->_execute('ds', @_) }
sub dynamodb { shift->_execute('dynamodb', @_) }
sub dynamodbstreams { shift->_execute('dynamodbstreams', @_) }
sub ebs { shift->_execute('ebs', @_) }
sub ec2 { shift->_execute('ec2', @_) }
sub ec2_instance_connect { shift->_execute('ec2-instance-connect', @_) }
sub ecr { shift->_execute('ecr', @_) }
sub ecr_public { shift->_execute('ecr-public', @_) }
sub ecs { shift->_execute('ecs', @_) }
sub efs { shift->_execute('efs', @_) }
sub eks { shift->_execute('eks', @_) }
sub elastic_inference { shift->_execute('elastic-inference', @_) }
sub elasticache { shift->_execute('elasticache', @_) }
sub elasticbeanstalk { shift->_execute('elasticbeanstalk', @_) }
sub elastictranscoder { shift->_execute('elastictranscoder', @_) }
sub elb { shift->_execute('elb', @_) }
sub elbv2 { shift->_execute('elbv2', @_) }
sub emr { shift->_execute('emr', @_) }
sub emr_containers { shift->_execute('emr-containers', @_) }
sub emr_serverless { shift->_execute('emr-serverless', @_) }
sub es { shift->_execute('es', @_) }
sub events { shift->_execute('events', @_) }
sub evidently { shift->_execute('evidently', @_) }
sub finspace { shift->_execute('finspace', @_) }
sub finspace_data { shift->_execute('finspace-data', @_) }
sub firehose { shift->_execute('firehose', @_) }
sub fis { shift->_execute('fis', @_) }
sub fms { shift->_execute('fms', @_) }
sub forecast { shift->_execute('forecast', @_) }
sub forecastquery { shift->_execute('forecastquery', @_) }
sub frauddetector { shift->_execute('frauddetector', @_) }
sub fsx { shift->_execute('fsx', @_) }
sub gamelift { shift->_execute('gamelift', @_) }
sub gamesparks { shift->_execute('gamesparks', @_) }
sub glacier { shift->_execute('glacier', @_) }
sub globalaccelerator { shift->_execute('globalaccelerator', @_) }
sub glue { shift->_execute('glue', @_) }
sub grafana { shift->_execute('grafana', @_) }
sub greengrass { shift->_execute('greengrass', @_) }
sub greengrassv2 { shift->_execute('greengrassv2', @_) }
sub groundstation { shift->_execute('groundstation', @_) }
sub guardduty { shift->_execute('guardduty', @_) }
sub health { shift->_execute('health', @_) }
sub healthlake { shift->_execute('healthlake', @_) }
sub history { shift->_execute('history', @_) }
sub honeycode { shift->_execute('honeycode', @_) }
sub iam { shift->_execute('iam', @_) }
sub identitystore { shift->_execute('identitystore', @_) }
sub imagebuilder { shift->_execute('imagebuilder', @_) }
sub importexport { shift->_execute('importexport', @_) }
sub inspector { shift->_execute('inspector', @_) }
sub inspector2 { shift->_execute('inspector2', @_) }
sub internetmonitor { shift->_execute('internetmonitor', @_) }
sub iot { shift->_execute('iot', @_) }
sub iot_data { shift->_execute('iot-data', @_) }
sub iot_jobs_data { shift->_execute('iot-jobs-data', @_) }
sub iot_roborunner { shift->_execute('iot-roborunner', @_) }
sub iot1click_devices { shift->_execute('iot1click-devices', @_) }
sub iot1click_projects { shift->_execute('iot1click-projects', @_) }
sub iotanalytics { shift->_execute('iotanalytics', @_) }
sub iotdeviceadvisor { shift->_execute('iotdeviceadvisor', @_) }
sub iotevents { shift->_execute('iotevents', @_) }
sub iotevents_data { shift->_execute('iotevents-data', @_) }
sub iotfleethub { shift->_execute('iotfleethub', @_) }
sub iotfleetwise { shift->_execute('iotfleetwise', @_) }
sub iotsecuretunneling { shift->_execute('iotsecuretunneling', @_) }
sub iotsitewise { shift->_execute('iotsitewise', @_) }
sub iotthingsgraph { shift->_execute('iotthingsgraph', @_) }
sub iottwinmaker { shift->_execute('iottwinmaker', @_) }
sub iotwireless { shift->_execute('iotwireless', @_) }
sub ivs { shift->_execute('ivs', @_) }
sub ivs_realtime { shift->_execute('ivs-realtime', @_) }
sub ivschat { shift->_execute('ivschat', @_) }
sub kafka { shift->_execute('kafka', @_) }
sub kafkaconnect { shift->_execute('kafkaconnect', @_) }
sub kendra { shift->_execute('kendra', @_) }
sub kendra_ranking { shift->_execute('kendra-ranking', @_) }
sub keyspaces { shift->_execute('keyspaces', @_) }
sub kinesis { shift->_execute('kinesis', @_) }
sub kinesis_video_archived_media { shift->_execute('kinesis-video-archived-media', @_) }
sub kinesis_video_media { shift->_execute('kinesis-video-media', @_) }
sub kinesis_video_signaling { shift->_execute('kinesis-video-signaling', @_) }
sub kinesis_video_webrtc_storage { shift->_execute('kinesis-video-webrtc-storage', @_) }
sub kinesisanalytics { shift->_execute('kinesisanalytics', @_) }
sub kinesisanalyticsv2 { shift->_execute('kinesisanalyticsv2', @_) }
sub kinesisvideo { shift->_execute('kinesisvideo', @_) }
sub kms { shift->_execute('kms', @_) }
sub lakeformation { shift->_execute('lakeformation', @_) }
sub lambda { shift->_execute('lambda', @_) }
sub lex_models { shift->_execute('lex-models', @_) }
sub lex_runtime { shift->_execute('lex-runtime', @_) }
sub lexv2_models { shift->_execute('lexv2-models', @_) }
sub lexv2_runtime { shift->_execute('lexv2-runtime', @_) }
sub license_manager { shift->_execute('license-manager', @_) }
sub license_manager_linux_subscriptions { shift->_execute('license-manager-linux-subscriptions', @_) }
sub license_manager_user_subscriptions { shift->_execute('license-manager-user-subscriptions', @_) }
sub lightsail { shift->_execute('lightsail', @_) }
sub location { shift->_execute('location', @_) }
sub logs { shift->_execute('logs', @_) }
sub lookoutequipment { shift->_execute('lookoutequipment', @_) }
sub lookoutmetrics { shift->_execute('lookoutmetrics', @_) }
sub lookoutvision { shift->_execute('lookoutvision', @_) }
sub m2 { shift->_execute('m2', @_) }
sub machinelearning { shift->_execute('machinelearning', @_) }
sub macie { shift->_execute('macie', @_) }
sub macie2 { shift->_execute('macie2', @_) }
sub managedblockchain { shift->_execute('managedblockchain', @_) }
sub marketplace_catalog { shift->_execute('marketplace-catalog', @_) }
sub marketplace_entitlement { shift->_execute('marketplace-entitlement', @_) }
sub marketplacecommerceanalytics { shift->_execute('marketplacecommerceanalytics', @_) }
sub mediaconnect { shift->_execute('mediaconnect', @_) }
sub mediaconvert { shift->_execute('mediaconvert', @_) }
sub medialive { shift->_execute('medialive', @_) }
sub mediapackage { shift->_execute('mediapackage', @_) }
sub mediapackage_vod { shift->_execute('mediapackage-vod', @_) }
sub mediapackagev2 { shift->_execute('mediapackagev2', @_) }
sub mediastore { shift->_execute('mediastore', @_) }
sub mediastore_data { shift->_execute('mediastore-data', @_) }
sub mediatailor { shift->_execute('mediatailor', @_) }
sub memorydb { shift->_execute('memorydb', @_) }
sub meteringmarketplace { shift->_execute('meteringmarketplace', @_) }
sub mgh { shift->_execute('mgh', @_) }
sub mgn { shift->_execute('mgn', @_) }
sub migration_hub_refactor_spaces { shift->_execute('migration-hub-refactor-spaces', @_) }
sub migrationhub_config { shift->_execute('migrationhub-config', @_) }
sub migrationhuborchestrator { shift->_execute('migrationhuborchestrator', @_) }
sub migrationhubstrategy { shift->_execute('migrationhubstrategy', @_) }
sub mobile { shift->_execute('mobile', @_) }
sub mq { shift->_execute('mq', @_) }
sub mturk { shift->_execute('mturk', @_) }
sub mwaa { shift->_execute('mwaa', @_) }
sub neptune { shift->_execute('neptune', @_) }
sub network_firewall { shift->_execute('network-firewall', @_) }
sub networkmanager { shift->_execute('networkmanager', @_) }
sub nimble { shift->_execute('nimble', @_) }
sub oam { shift->_execute('oam', @_) }
sub omics { shift->_execute('omics', @_) }
sub opensearch { shift->_execute('opensearch', @_) }
sub opensearchserverless { shift->_execute('opensearchserverless', @_) }
sub opsworks { shift->_execute('opsworks', @_) }
sub opsworks_cm { shift->_execute('opsworks-cm', @_) }
sub organizations { shift->_execute('organizations', @_) }
sub osis { shift->_execute('osis', @_) }
sub outposts { shift->_execute('outposts', @_) }
sub panorama { shift->_execute('panorama', @_) }
sub payment_cryptography { shift->_execute('payment-cryptography', @_) }
sub payment_cryptography_data { shift->_execute('payment-cryptography-data', @_) }
sub personalize { shift->_execute('personalize', @_) }
sub personalize_events { shift->_execute('personalize-events', @_) }
sub personalize_runtime { shift->_execute('personalize-runtime', @_) }
sub pi { shift->_execute('pi', @_) }
sub pinpoint { shift->_execute('pinpoint', @_) }
sub pinpoint_email { shift->_execute('pinpoint-email', @_) }
sub pinpoint_sms_voice { shift->_execute('pinpoint-sms-voice', @_) }
sub pinpoint_sms_voice_v2 { shift->_execute('pinpoint-sms-voice-v2', @_) }
sub pipes { shift->_execute('pipes', @_) }
sub polly { shift->_execute('polly', @_) }
sub pricing { shift->_execute('pricing', @_) }
sub privatenetworks { shift->_execute('privatenetworks', @_) }
sub proton { shift->_execute('proton', @_) }
sub qldb { shift->_execute('qldb', @_) }
sub qldb_session { shift->_execute('qldb-session', @_) }
sub quicksight { shift->_execute('quicksight', @_) }
sub ram { shift->_execute('ram', @_) }
sub rbin { shift->_execute('rbin', @_) }
sub rds { shift->_execute('rds', @_) }
sub rds_data { shift->_execute('rds-data', @_) }
sub redshift { shift->_execute('redshift', @_) }
sub redshift_data { shift->_execute('redshift-data', @_) }
sub redshift_serverless { shift->_execute('redshift-serverless', @_) }
sub rekognition { shift->_execute('rekognition', @_) }
sub resiliencehub { shift->_execute('resiliencehub', @_) }
sub resource_explorer_2 { shift->_execute('resource-explorer-2', @_) }
sub resource_groups { shift->_execute('resource-groups', @_) }
sub resourcegroupstaggingapi { shift->_execute('resourcegroupstaggingapi', @_) }
sub robomaker { shift->_execute('robomaker', @_) }
sub rolesanywhere { shift->_execute('rolesanywhere', @_) }
sub route53 { shift->_execute('route53', @_) }
sub route53_recovery_cluster { shift->_execute('route53-recovery-cluster', @_) }
sub route53_recovery_control_config { shift->_execute('route53-recovery-control-config', @_) }
sub route53_recovery_readiness { shift->_execute('route53-recovery-readiness', @_) }
sub route53domains { shift->_execute('route53domains', @_) }
sub route53resolver { shift->_execute('route53resolver', @_) }
sub rum { shift->_execute('rum', @_) }
sub s3 { shift->_execute('s3', @_) }
sub s3api { shift->_execute('s3api', @_) }
sub s3control { shift->_execute('s3control', @_) }
sub s3outposts { shift->_execute('s3outposts', @_) }
sub sagemaker { shift->_execute('sagemaker', @_) }
sub sagemaker_a2i_runtime { shift->_execute('sagemaker-a2i-runtime', @_) }
sub sagemaker_edge { shift->_execute('sagemaker-edge', @_) }
sub sagemaker_featurestore_runtime { shift->_execute('sagemaker-featurestore-runtime', @_) }
sub sagemaker_geospatial { shift->_execute('sagemaker-geospatial', @_) }
sub sagemaker_metrics { shift->_execute('sagemaker-metrics', @_) }
sub sagemaker_runtime { shift->_execute('sagemaker-runtime', @_) }
sub savingsplans { shift->_execute('savingsplans', @_) }
sub scheduler { shift->_execute('scheduler', @_) }
sub schemas { shift->_execute('schemas', @_) }
sub sdb { shift->_execute('sdb', @_) }
sub secretsmanager { shift->_execute('secretsmanager', @_) }
sub securityhub { shift->_execute('securityhub', @_) }
sub securitylake { shift->_execute('securitylake', @_) }
sub serverlessrepo { shift->_execute('serverlessrepo', @_) }
sub service_quotas { shift->_execute('service-quotas', @_) }
sub servicecatalog { shift->_execute('servicecatalog', @_) }
sub servicecatalog_appregistry { shift->_execute('servicecatalog-appregistry', @_) }
sub servicediscovery { shift->_execute('servicediscovery', @_) }
sub ses { shift->_execute('ses', @_) }
sub sesv2 { shift->_execute('sesv2', @_) }
sub shield { shift->_execute('shield', @_) }
sub signer { shift->_execute('signer', @_) }
sub simspaceweaver { shift->_execute('simspaceweaver', @_) }
sub sms { shift->_execute('sms', @_) }
sub snow_device_management { shift->_execute('snow-device-management', @_) }
sub snowball { shift->_execute('snowball', @_) }
sub sns { shift->_execute('sns', @_) }
sub sqs { shift->_execute('sqs', @_) }
sub ssm { shift->_execute('ssm', @_) }
sub ssm_contacts { shift->_execute('ssm-contacts', @_) }
sub ssm_incidents { shift->_execute('ssm-incidents', @_) }
sub ssm_sap { shift->_execute('ssm-sap', @_) }
sub sso { shift->_execute('sso', @_) }
sub sso_admin { shift->_execute('sso-admin', @_) }
sub sso_oidc { shift->_execute('sso-oidc', @_) }
sub stepfunctions { shift->_execute('stepfunctions', @_) }
sub storagegateway { shift->_execute('storagegateway', @_) }
sub sts { shift->_execute('sts', @_) }
sub support { shift->_execute('support', @_) }
sub support_app { shift->_execute('support-app', @_) }
sub swf { shift->_execute('swf', @_) }
sub synthetics { shift->_execute('synthetics', @_) }
sub textract { shift->_execute('textract', @_) }
sub timestream_query { shift->_execute('timestream-query', @_) }
sub timestream_write { shift->_execute('timestream-write', @_) }
sub tnb { shift->_execute('tnb', @_) }
sub transcribe { shift->_execute('transcribe', @_) }
sub transfer { shift->_execute('transfer', @_) }
sub translate { shift->_execute('translate', @_) }
sub verifiedpermissions { shift->_execute('verifiedpermissions', @_) }
sub voice_id { shift->_execute('voice-id', @_) }
sub vpc_lattice { shift->_execute('vpc-lattice', @_) }
sub waf { shift->_execute('waf', @_) }
sub waf_regional { shift->_execute('waf-regional', @_) }
sub wafv2 { shift->_execute('wafv2', @_) }
sub wellarchitected { shift->_execute('wellarchitected', @_) }
sub wisdom { shift->_execute('wisdom', @_) }
sub workdocs { shift->_execute('workdocs', @_) }
sub worklink { shift->_execute('worklink', @_) }
sub workmail { shift->_execute('workmail', @_) }
sub workmailmessageflow { shift->_execute('workmailmessageflow', @_) }
sub workspaces { shift->_execute('workspaces', @_) }
sub workspaces_web { shift->_execute('workspaces-web', @_) }
sub xray { shift->_execute('xray', @_) }
1;
__END__
AWS-CloudFront
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
goto &{$self->can('call')};
}
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
AWS-IP
view release on metacpan or search on metacpan
lib/AWS/IP.pm view on Meta::CPAN
Creates a new AWS::IP object and sets up the cache. Requires an number for the cache timeout seconds. Optionally takes a cache path argument. If no cache path is supplied, AWS::IP will use a random temp directory. If you want to reuse the cache over ...
=cut
sub new
{
croak 'Incorrect number of args passed to AWS::IP->new()' unless @_ >= 2 && @_ <= 3;
my ($class, $cache_timeout_secs, $cache_path) = @_;
# validate args
lib/AWS/IP.pm view on Meta::CPAN
If you are checking more than one ip address, it's more efficient to pull the CIDRs you want, then use L<Net::CIDR::Set> to test if the ips are present in the CIDRs (see example in SYNOPSIS).
=cut
sub ip_is_aws
{
my ($self, $ip, $service) = @_;
croak 'Error must supply an ip address' unless $ip;
lib/AWS/IP.pm view on Meta::CPAN
Returns the entire raw IP dataset as a Perl data structure.
=cut
sub get_raw_data
{
my ($self) = @_;
my $entry = $self->{cache}->entry(CACHE_KEY);
lib/AWS/IP.pm view on Meta::CPAN
Returns an arrayref of the L<CIDRs|http://en.wikipedia.org/wiki/Classless_Inter-Domain_Routing> in the AWS IP address data.
=cut
sub get_cidrs
{
my ($self) = @_;
[ map { $_->{ip_prefix} } @{$self->get_raw_data->{prefixes}} ];
}
lib/AWS/IP.pm view on Meta::CPAN
Returns an arrayref of CIDRs matching the provided region.
=cut
sub get_cidrs_by_region
{
my ($self, $region) = @_;
croak 'Error must provide region' unless $region;
[ map { $_->{ip_prefix} } grep { $_->{region} eq $region } @{$self->get_raw_data->{prefixes}} ];
lib/AWS/IP.pm view on Meta::CPAN
Returns an arrayref of CIDRs matching the provided service (AMAZON|EC2|CLOUDFRONT|ROUTE53|ROUTE53_HEALTHCHECKS).
=cut
sub get_cidrs_by_service
{
my ($self, $service) = @_;
croak 'Error must provide service' unless $service;
[ map { $_->{ip_prefix} } grep { $_->{service} eq $service } @{$self->get_raw_data->{prefixes}} ];
lib/AWS/IP.pm view on Meta::CPAN
Returns an arrayref of the regions in the AWS IP address data.
=cut
sub get_regions
{
my ($self) = @_;
my %regions;
for (@{$self->get_raw_data->{prefixes}})
{
lib/AWS/IP.pm view on Meta::CPAN
Returns an arrayref of the services (Amazon, EC2 etc) in the AWS IP address data.
=cut
sub get_services
{
my ($self) = @_;
my %services;
for (@{$self->get_raw_data->{prefixes}})
{
lib/AWS/IP.pm view on Meta::CPAN
Amazon's L<page|http://docs.aws.amazon.com/general/latest/gr/aws-ip-ranges.html> on AWS IP ranges.
=cut
sub _refresh_cache
{
my ($self) = @_;
my $response = HTTP::Tiny->new->get('https://ip-ranges.amazonaws.com/ip-ranges.json');
lib/AWS/IP.pm view on Meta::CPAN
{
croak "Error requesting $response->{url} $response->{code} $response->{reason}";
}
}
sub _refresh_cache_from_string
{
my ($self, $data) = @_;
my $entry = $self->{cache}->entry(CACHE_KEY);
$entry->set($data);
AWS-Lambda-Quick
view release on metacpan or search on metacpan
lib/AWS/Lambda/Quick.pm view on Meta::CPAN
our $VERSION = '1.0002';
use AWS::Lambda::Quick::Processor ();
sub import {
shift;
# where's the source code of the script calling us?
my ( undef, $file, undef ) = caller;
lib/AWS/Lambda/Quick.pm view on Meta::CPAN
use AWS::Lambda::Quick (
name => 'hello-world',
);
sub handler {
my $data = shift;
my $name = $data->{queryStringParameters}{who} // "World";
return {
statusCode => 200,
headers => {
lib/AWS/Lambda/Quick.pm view on Meta::CPAN
use AWS::Lambda::Quick (
name => 'echo',
);
sub handler {
my $data = shift;
return {
statusCode => 200,
headers => {
'Content-Type' => 'application/json',
AWS-Lambda
view release on metacpan or search on metacpan
author/perl-stripper/perl-stripper/handler.pl view on Meta::CPAN
my $stripper = Perl::Strip->new(
cache => '/tmp/.perl-strip',
optimise_size => 1,
);
my $app = sub {
my $env = shift;
my $req = Plack::Request->new($env);
my $code = do { local $/; my $body = $req->body; <$body> };
my $stripped = $stripper->strip($code);
author/perl-stripper/perl-stripper/handler.pl view on Meta::CPAN
return $res->finalize;
};
my $func = AWS::Lambda::PSGI->wrap($app);
sub handle($payload, $context) {
return $func->($payload);
}
1;
AWS-Networks
view release on metacpan or search on metacpan
lib/AWS/Networks.pm view on Meta::CPAN
);
has netinfo => (
is => 'ro',
isa => 'HashRef',
default => sub {
my $self = shift;
die "Can't get some properties from derived results" if (not $self->url);
my $response = HTTP::Tiny->new->get($self->url);
die "Error downloading URL" unless ($response->{ success });
return decode_json($response->{ content });
lib/AWS/Networks.pm view on Meta::CPAN
);
has sync_token => (
is => 'ro',
isa => 'DateTime',
default => sub {
return DateTime->from_epoch( epoch => shift->netinfo->{ syncToken } );
},
lazy => 1,
);
has networks => (
is => 'ro',
isa => 'ArrayRef',
default => sub {
return shift->netinfo->{ prefixes };
},
lazy => 1,
);
has regions => (
is => 'ro',
isa => 'ArrayRef',
default => sub {
my ($self) = @_;
my $regions = {};
map { $regions->{ $_->{ region } } = 1 } @{ $self->networks };
return [ keys %$regions ];
},
lazy => 1,
);
sub by_region {
my ($self, $region) = @_;
return AWS::Networks->new(
url => undef,
sync_token => $self->sync_token,
networks => [ grep { $_->{ region } eq $region } @{ $self->networks } ]
lib/AWS/Networks.pm view on Meta::CPAN
}
has services => (
is => 'ro',
isa => 'ArrayRef',
default => sub {
my ($self) = @_;
my $services = {};
map { $services->{ $_->{ service } } = 1 } @{ $self->networks };
return [ keys %$services ];
},
lazy => 1,
);
sub by_service {
my ($self, $service) = @_;
return AWS::Networks->new(
url => undef,
sync_token => $self->sync_token,
networks => [ grep { $_->{ service } eq $service } @{ $self->networks } ]
lib/AWS/Networks.pm view on Meta::CPAN
}
has cidrs => (
is => 'ro',
isa => 'ArrayRef',
default => sub {
my ($self) = @_;
return [ map { $_->{ ip_prefix } } @{ $self->networks } ];
},
lazy => 1,
);
AWS-S3
view release on metacpan or search on metacpan
lib/AWS/S3.pm view on Meta::CPAN
has 'session_token' => (
is => 'ro',
isa => 'Maybe[Str]',
lazy => 1,
default => sub { $ENV{AWS_SESSION_TOKEN} },
);
has 'region' => (
is => 'ro',
isa => 'Maybe[Str]',
lazy => 1,
default => sub { $ENV{AWS_REGION} },
);
has 'secure' => (
is => 'ro',
isa => 'Bool',
lib/AWS/S3.pm view on Meta::CPAN
has 'endpoint' => (
is => 'ro',
isa => 'Str',
lazy => 1,
default => sub {
my ( $s ) = @_;
if ( my $region = $s->region ) {
return "s3.$region.amazonaws.com"
} else {
lib/AWS/S3.pm view on Meta::CPAN
);
has 'ua' => (
is => 'ro',
isa => 'LWP::UserAgent',
default => sub { LWP::UserAgent::Determined->new }
);
has 'honor_leading_slashes' => (
is => 'ro',
isa => 'Bool',
default => sub { 0 },
);
sub request {
my ( $s, $type, %args ) = @_;
my $class = "AWS::S3::Request::$type";
load_class( $class );
return $class->new( %args, s3 => $s, type => $type );
} # end request()
sub owner {
my $s = shift;
my $type = 'ListAllMyBuckets';
my $request = $s->request( $type );
my $response = $request->request();
lib/AWS/S3.pm view on Meta::CPAN
id => $xpc->findvalue( '//s3:Owner/s3:ID' ),
display_name => $xpc->findvalue( '//s3:Owner/s3:DisplayName' ),
);
} # end owner()
sub buckets {
my ( $s ) = @_;
my $type = 'ListAllMyBuckets';
my $request = $s->request( $type );
my $response = $request->request();
lib/AWS/S3.pm view on Meta::CPAN
} # end foreach()
return @buckets;
} # end buckets()
sub bucket {
my ( $s, $name ) = @_;
my ( $bucket ) = grep { $_->name eq $name } $s->buckets
or return;
$bucket;
} # end bucket()
sub add_bucket {
my ( $s, %args ) = @_;
my $type = 'CreateBucket';
my $request = $s->request(
$type,
lib/AWS/S3.pm view on Meta::CPAN
# You can also set the contents with a coderef:
# Coderef should eturn a reference, not the actual string of content:
$new_file = $bucket->add_file(
key => 'foo/bar.txt',
contents => sub { return \"This is the contents" }
);
# Get the file:
my $same_file = $bucket->file( 'foo/bar.txt' );
lib/AWS/S3.pm view on Meta::CPAN
# Update the contents with a scalar ref:
$same_file->contents( \"New file contents" );
# Update the contents with a code ref:
$same_file->contents( sub { return \"New file contents" } );
# Delete the file:
$same_file->delete();
# Iterate through lots of files:
AWS-SNS-Confess
view release on metacpan or search on metacpan
lib/AWS/SNS/Confess.pm view on Meta::CPAN
our @EXPORT_OK = qw/confess/;
our ($access_key_id, $secret_access_key, $topic, $sns, $sns_topic);
sub setup
{
my (%args) = @_;
$access_key_id = $args{access_key_id};
$secret_access_key = $args{secret_access_key};
$topic = $args{topic};
lib/AWS/SNS/Confess.pm view on Meta::CPAN
});
$sns->service(_service_url());
$sns_topic = $sns->GetTopic($topic);
}
sub confess
{
my ($msg) = @_;
my $full_message = "Runtime Error: $msg\n"
. Devel::StackTrace->new->as_string;
_send_msg( $full_message );
die $msg;
}
sub _service_url
{
die "no topic specified" unless $topic;
if ($topic =~ m/^arn:aws:sns:([^:]+):\d+:[^:]+$/)
{
return "http://sns.$1.amazonaws.com";
}
return "http://sns.us-east-1.amazonaws.com";
}
sub _send_msg
{
$sns_topic->Publish(shift);
}
1;
AWS-SNS-Verify
view release on metacpan or search on metacpan
lib/AWS/SNS/Verify.pm view on Meta::CPAN
);
has message => (
is => 'ro',
lazy => 1,
default => sub {
my $self = shift;
return JSON::decode_json($self->body);
}
);
has certificate_string => (
is => 'ro',
lazy => 1,
default => sub {
my $self = shift;
return $self->fetch_certificate;
}
);
has certificate => (
is => 'ro',
lazy => 1,
default => sub {
my $self = shift;
return Crypt::PK::RSA->new(\$self->certificate_string);
}
);
lib/AWS/SNS/Verify.pm view on Meta::CPAN
is => 'ro',
lazy => 1,
default => 1,
);
sub fetch_certificate {
my $self = shift;
my $url = $self->valid_cert_url($self->message->{SigningCertURL});
my $response = HTTP::Tiny->new->get($url);
if ($response->{success}) {
return $response->{content};
lib/AWS/SNS/Verify.pm view on Meta::CPAN
else {
ouch $response->{status}, $response->{reason}, $response;
}
}
sub generate_signature_string {
my $self = shift;
my $body = $self->message;
my @fields;
if ($body->{Type} eq 'Notification') {
@fields = (qw(Message MessageId Subject Timestamp TopicArn Type)) ;
lib/AWS/SNS/Verify.pm view on Meta::CPAN
}
}
return join("\n", @parts)."\n";
}
sub decode_signature {
my $self = shift;
return decode_base64($self->message->{Signature});
}
sub verify {
my $self = shift;
my $pk = $self->certificate;
unless ($pk->verify_message($self->decode_signature, $self->generate_signature_string, 'SHA1', 'v1.5')) {
ouch 'Bad SNS Signature', 'Could not verify the SNS message from its signature.', $self;
}
return 1;
}
# See also:
# https://github.com/aws/aws-php-sns-message-validator/blob/master/src/MessageValidator.php#L22
sub valid_cert_url {
my $self = shift;
my ($url_string) = @_;
$url_string ||= '';
return $url_string unless $self->validate_signing_cert_url;
lib/AWS/SNS/Verify.pm view on Meta::CPAN
}
return $url_string;
}
sub TO_JSON {
my $self = shift;
return unbless($self);
}
=head1 NAME
AWS-SQS-Simple
view release on metacpan or search on metacpan
lib/AWS/SQS/Simple.pm view on Meta::CPAN
);
=cut
sub new {
my $class = shift;
my %parameter_hash;
lib/AWS/SQS/Simple.pm view on Meta::CPAN
$ob->create_queue->( \%params_hash )
=cut
sub create_queue {
my $self = shift ;
my $params = shift ;
my $params_to_pass = {
lib/AWS/SQS/Simple.pm view on Meta::CPAN
$ob->send_message->( \%params_hash )
=cut
sub send_message {
my $self = shift ;
my $params = shift ;
my $message_body = $params->{ MessageBody } ;
lib/AWS/SQS/Simple.pm view on Meta::CPAN
$ob->receive_message->( \%params_hash )
=cut
sub receive_message {
my $self = shift ;
my $params = shift ;
my $params_to_pass = {
lib/AWS/SQS/Simple.pm view on Meta::CPAN
$ob->delete_message->( \%params_hash )
=cut
sub delete_message {
my $self = shift ;
my $params = shift ;
my $receipt_handle = $params->{ ReceiptHandle } ;
lib/AWS/SQS/Simple.pm view on Meta::CPAN
$ob->get_queue_attributes->( \%params_hash )
=cut
sub get_queue_attributes {
my $self = shift ;
my $params = shift ;
my $params_to_pass = {
lib/AWS/SQS/Simple.pm view on Meta::CPAN
This function creates and returns url as per the parameters passed.
=cut
sub _get_url {
my $self = shift ;
my $params = shift ;
my $url_additional_str = $self->{ AWS_ACCOUNT_ID } . '/' . delete( $params->{ QUEUE_NAME } ) ;
lib/AWS/SQS/Simple.pm view on Meta::CPAN
This function generate signature using HMACSHA256 method and version 2.
=cut
sub _generate_signatue {
my $self = shift ;
my $query = shift ;
my $secret_access_key = $self->{ SECRET_ACCESS_KEY } ;
lib/AWS/SQS/Simple.pm view on Meta::CPAN
This function utf8 encodes and uri escapes the parameters passed to generate the signed string.
=cut
sub _get_signed_query {
my $params = shift ;
my $to_sign ;
for my $key( sort keys %$params ) {
lib/AWS/SQS/Simple.pm view on Meta::CPAN
URI escape only the characters that should be escaped, according to RFC 3986
=cut
sub escape {
my ($str) = @_;
return uri_escape_utf8( $str,'^A-Za-z0-9\-_.~' ) ;
}
lib/AWS/SQS/Simple.pm view on Meta::CPAN
Calculate current TimeStamp
=cut
sub _generate_timestamp {
return sprintf("%04d-%02d-%02dT%02d:%02d:%02d.000Z",
sub { ($_[5]+1900,
$_[4]+1,
$_[3],
$_[2],
$_[1],
$_[0])
lib/AWS/SQS/Simple.pm view on Meta::CPAN
=head2 _make_request
=cut
sub _make_request {
my $self = shift ;
my $url_to_access = shift ;
my $contents ;
AWS-Signature-V2
view release on metacpan or search on metacpan
lib/AWS/Signature/V2.pm view on Meta::CPAN
our $VERSION = "0.01";
has aws_access_key => (is => 'rw', required => 1, builder => 1);
has aws_secret_key => (is => 'rw', required => 1, builder => 1);
sub _build_aws_access_key { $ENV{AWS_ACCESS_KEY} }
sub _build_aws_secret_key { $ENV{AWS_SECRET_KEY} }
sub sign {
my ($self, $url) = @_;
my %eq = map { split /=/, $_ } split /&/, $url->query();
my %q = map { $_ => decode_utf8( uri_unescape( $eq{$_} ) ) } keys %eq;
$q{Keywords} =~ s/\+/ /g if $q{Keywords};
$q{AWSAccessKeyId} = $self->aws_access_key;
lib/AWS/Signature/V2.pm view on Meta::CPAN
$q{Signature} = $signature;
$url->query_form( \%q );
$url;
}
sub signature {
my ($self, $url) = @_;
my %eq = map { split /=/, $_ } split /&/, $url->query();
my %q = map { $_ => uri_unescape( $eq{$_} ) } keys %eq;
$q{Signature};
}
AWS-Signature4
view release on metacpan or search on metacpan
lib/AWS/Signature4.pm view on Meta::CPAN
set, their contents are used as defaults for -acccess_key and
-secret_key.
=cut
sub new {
my $self = shift;
my %args = @_;
my ($id,$secret,$token);
if (ref $args{-security_token} && $args{-security_token}->can('access_key_id')) {
lib/AWS/Signature4.pm view on Meta::CPAN
secret_key => $secret,
(defined($args{-security_token}) ? (security_token => $args{-security_token}) : ()),
},ref $self || $self;
}
sub access_key { shift->{access_key } }
sub secret_key { shift->{secret_key } }
=item $signer->sign($request [,$region] [,$payload_sha256_hex])
Given an HTTP::Request object, add the headers required by AWS and
then sign it with a version 4 signature by adding an "Authorization"
lib/AWS/Signature4.pm view on Meta::CPAN
=back
=cut
sub sign {
my $self = shift;
my ($request,$region,$payload_sha256_hex) = @_;
$self->_add_date_header($request);
$self->_sign($request,$region,$payload_sha256_hex);
}
lib/AWS/Signature4.pm view on Meta::CPAN
seconds.
=cut
sub signed_url {
my $self = shift;
my ($arg1,$expires) = @_;
my ($request,$uri);
lib/AWS/Signature4.pm view on Meta::CPAN
$uri->query_param_append('X-Amz-Signature' => $signature);
return $uri;
}
sub _add_date_header {
my $self = shift;
my $request = shift;
my $datetime;
unless ($datetime = $request->header('x-amz-date')) {
$datetime = $self->_zulu_time($request);
$request->header('x-amz-date'=>$datetime);
}
}
sub _scope {
my $self = shift;
my ($request,$region) = @_;
my $host = $request->uri->host;
my $datetime = $self->_datetime($request);
my ($date) = $datetime =~ /^(\d+)T/;
lib/AWS/Signature4.pm view on Meta::CPAN
$service ||= 's3';
$region ||= 'us-east-1'; # default
return "$date/$region/$service/aws4_request";
}
sub _parse_scope {
my $self = shift;
my $scope = shift;
return split '/',$scope;
}
sub _datetime {
my $self = shift;
my $request = shift;
return $request->header('x-amz-date') || $self->_zulu_time($request);
}
sub _algorithm { return 'AWS4-HMAC-SHA256' }
sub _sign {
my $self = shift;
my ($request,$region,$payload_sha256_hex) = @_;
return if $request->header('Authorization'); # don't overwrite
my $datetime = $self->_datetime($request);
lib/AWS/Signature4.pm view on Meta::CPAN
my $string_to_sign = $self->_string_to_sign($datetime,$scope,$hashed_request);
my $signature = $self->_calculate_signature($secret_key,$service,$region,$date,$string_to_sign);
$request->header(Authorization => "$algorithm Credential=$access_key/$scope, SignedHeaders=$signed_headers, Signature=$signature");
}
sub _zulu_time {
my $self = shift;
my $request = shift;
my $date = $request->header('Date');
my @datetime = $date ? gmtime(str2time($date)) : gmtime();
return strftime('%Y%m%dT%H%M%SZ',@datetime);
}
sub _hash_canonical_request {
my $self = shift;
my ($request,$hashed_payload) = @_; # (HTTP::Request,sha256_hex($content))
my $method = $request->method;
my $uri = $request->uri;
my $path = $uri->path || '/';
lib/AWS/Signature4.pm view on Meta::CPAN
my $request_digest = sha256_hex($canonical_request);
return ($request_digest,$signed_headers);
}
sub _string_to_sign {
my $self = shift;
my ($datetime,$credential_scope,$hashed_request) = @_;
return join("\n",'AWS4-HMAC-SHA256',$datetime,$credential_scope,$hashed_request);
}
lib/AWS/Signature4.pm view on Meta::CPAN
Return just the signing key in the event you wish to roll your own signature.
=cut
sub signing_key {
my $self = shift;
my ($kSecret,$service,$region,$date) = @_;
my $kDate = hmac_sha256($date,'AWS4'.$kSecret);
my $kRegion = hmac_sha256($region,$kDate);
my $kService = hmac_sha256($service,$kRegion);
my $kSigning = hmac_sha256('aws4_request',$kService);
return $kSigning;
}
sub _calculate_signature {
my $self = shift;
my ($kSecret,$service,$region,$date,$string_to_sign) = @_;
my $kSigning = $self->signing_key($kSecret,$service,$region,$date);
return hmac_sha256_hex($string_to_sign,$kSigning);
}
AWS-XRay
view release on metacpan or search on metacpan
lib/AWS/XRay.pm view on Meta::CPAN
our $TRACE_ID;
our $SEGMENT_ID;
our $ENABLED;
our $SAMPLED;
our $SAMPLING_RATE = 1;
our $SAMPLER = sub { rand() < $SAMPLING_RATE };
our $AUTO_FLUSH = 1;
our @PLUGINS;
our $DAEMON_HOST = "127.0.0.1";
lib/AWS/XRay.pm view on Meta::CPAN
($DAEMON_HOST, $DAEMON_PORT) = split /:/, $ENV{"AWS_XRAY_DAEMON_ADDRESS"};
}
my $Sock;
sub sampling_rate {
my $class = shift;
if (@_) {
$SAMPLING_RATE = shift;
}
$SAMPLING_RATE;
}
sub sampler {
my $class = shift;
if (@_) {
$SAMPLER = shift;
}
$SAMPLER;
}
sub plugins {
my $class = shift;
if (@_) {
@PLUGINS = @_;
Module::Load::load $_ for @PLUGINS;
}
@PLUGINS;
}
sub auto_flush {
my $class = shift;
if (@_) {
my $auto_flush = shift;
if ($auto_flush != $AUTO_FLUSH) {
$Sock->close if $Sock && $Sock->can("close");
lib/AWS/XRay.pm view on Meta::CPAN
$AUTO_FLUSH = $auto_flush;
}
$AUTO_FLUSH;
}
sub sock {
$Sock //= AWS::XRay::Buffer->new(
IO::Socket::INET->new(
PeerAddr => $DAEMON_HOST || "127.0.0.1",
PeerPort => $DAEMON_PORT || 2000,
Proto => "udp",
),
$AUTO_FLUSH,
);
}
sub new_trace_id {
sprintf(
"1-%x-%s",
CORE::time(),
unpack("H*", Crypt::URandom::urandom(12)),
);
}
sub new_id {
unpack("H*", Crypt::URandom::urandom(8));
}
sub is_valid_name {
$_[0] =~ $VALID_NAME_REGEXP;
}
# alias for backward compatibility
*trace = \&capture;
sub capture {
my ($name, $code) = @_;
if (!is_valid_name($name)) {
my $msg = "invalid segment name: $name";
$CROAK_INVALID_NAME ? croak($msg) : carp($msg);
}
lib/AWS/XRay.pm view on Meta::CPAN
}
die $error if $error;
return $wantarray ? @ret : $ret[0];
}
sub capture_from {
my ($header, $name, $code) = @_;
my ($trace_id, $segment_id, $sampled) = parse_trace_header($header);
local $AWS::XRay::SAMPLED = $sampled // $SAMPLER->();
local $AWS::XRay::ENABLED = $AWS::XRay::SAMPLED;
local ($AWS::XRay::TRACE_ID, $AWS::XRay::SEGMENT_ID) = ($trace_id, $segment_id);
capture($name, $code);
}
sub parse_trace_header {
my $header = shift or return;
my ($trace_id, $segment_id, $sampled);
if ($header =~ /Root=([0-9a-fA-F-]+)/) {
$trace_id = $1;
lib/AWS/XRay.pm view on Meta::CPAN
$sampled = $1;
}
return ($trace_id, $segment_id, $sampled);
}
sub add_capture {
my ($class, $package, @methods) = @_;
no warnings 'redefine';
no strict 'refs';
for my $method (@methods) {
my $orig = $package->can($method) or next;
*{"${package}::${method}"} = sub {
my @args = @_;
capture(
$package,
sub {
my $segment = shift;
$segment->{metadata}->{method} = $method;
$segment->{metadata}->{package} = $package;
$orig->(@args);
},
lib/AWS/XRay.pm view on Meta::CPAN
# patch the capture
no warnings 'redefine';
no strict 'refs';
my $org = \&capture;
*capture = sub {
my ($trace_id, $segment_id, $sampled) = parse_trace_header($ENV{_X_AMZN_TRACE_ID});
local $AWS::XRay::SAMPLED = $sampled // $SAMPLER->();
local $AWS::XRay::ENABLED = $AWS::XRay::SAMPLED;
local ($AWS::XRay::TRACE_ID, $AWS::XRay::SEGMENT_ID) = ($trace_id, $segment_id);
local *capture = $org;
lib/AWS/XRay.pm view on Meta::CPAN
=head1 SYNOPSIS
use AWS::XRay qw/ capture /;
capture "myApp", sub {
capture "remote", sub {
# do something ...
capture "nested", sub {
# ...
};
};
capture "myHTTP", sub {
my $segment = shift;
# ...
$segment->{http} = { # modify segment document
request => {
method => "GET",
lib/AWS/XRay.pm view on Meta::CPAN
};
};
};
my $header;
capture "source", sub {
my $segment = shift;
$header = $segment->trace_header;
};
capture_from $header, "dest", sub {
my $segment = shift; # is a child of "source" segment
# ...
};
=head1 DESCRIPTION
lib/AWS/XRay.pm view on Meta::CPAN
$segment is a AWS::XRay::Segment object.
When $AWS::XRay::TRACE_ID is not set, generates TRACE_ID automatically.
When capture() called from other capture(), $segment is a sub segment document.
See also L<AWS X-Ray Segment Documents|https://docs.aws.amazon.com/xray/latest/devguide/xray-api-segmentdocuments.html>.
=head2 capture_from($header, $name, $code)
capture_from() parses the trace header and capture the $code with sub segment of header's segment.
=head2 parse_trace_header($header)
my ($trace_id, $segment_id) = parse_trace_header($header);
lib/AWS/XRay.pm view on Meta::CPAN
=head2 sampler($code)
Set/Get a code ref to sample for capture().
AWS::XRay->sampler(sub {
if ($some_condition) {
return 1;
} else {
return 0;
}
AXL-Client-Simple
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
inc/Module/Install.pm view on Meta::CPAN
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
inc/Module/Install.pm view on Meta::CPAN
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
inc/Module/Install.pm view on Meta::CPAN
return $string;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
inc/Module/Install.pm view on Meta::CPAN
}
END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
inc/Module/Install.pm view on Meta::CPAN
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS {
(
defined $_[0]
and
! ref $_[0]
and
Aard
view release on metacpan or search on metacpan
lib/Aard.pm view on Meta::CPAN
[article_length_format => 'Z2' , 2 ],
];
my $header_length = sum map { $_->[2] } @{HEADER_SPEC()};
sub decompress {
my ($input) = @_;
my $output = $input;
inflate \$input => \$output;
bunzip2 \$input => \$output if $input =~ /^BZ/;
$output
}
sub read_at {
my ($self, $offset, $length) = @_;
my $fh = $self->{fh};
my $part;
seek $fh, $offset, 0;
read $fh, $part, $length;
$part
}
sub index1 {
my ($self, $index) = @_;
unless (exists $self->{index1}{$index}) {
my $part = $self->read_at($self->{index1_offset} + $index * $self->{index_length}, $self->{index_length});
$self->{index1}{$index} = [unpack $self->{index_format}, $part]
}
$self->{index1}{$index}
}
sub fh { shift->{fh} }
sub sha1sum { shift->{sha1sum} }
sub uuid { shift->{uuid} }
sub uuid_string { uuid_to_string shift->uuid }
sub volume { shift->{volume} }
sub total_volumes { shift->{total_volumes} }
sub count { shift->{index_count} }
sub meta { shift->{meta} }
sub article_count { shift->meta->{article_count} }
sub article_count_is_volume_total { shift->meta->{article_count_is_volume_total} }
sub index_language { shift->meta->{index_language} }
sub article_language { shift->meta->{article_language} }
sub title { shift->meta->{title} }
sub version { shift->meta->{version} }
sub description { shift->meta->{description} }
sub copyright { shift->meta->{copyright} }
sub license { shift->meta->{license} }
sub source { shift->meta->{source} }
sub key {
my ($self, $index) = @_;
unless (exists $self->{key}{$index}) {
my $part = $self->read_at($self->{index2_offset} + $self->index1($index)->[0], 2);
my $len = unpack 'S>', $part;
read $self->{fh}, $self->{key}{$index}, $len;
}
$self->{key}{$index}
}
sub article {
my ($self, $index) = @_;
unless (exists $self->{article}{$index}) {
my $part = $self->read_at($self->{article_offset} + $self->index1($index)->[1], 4);
my $len = unpack 'L>', $part;
read $self->{fh}, $part, $len;
$self->{article}{$index} = decompress $part
}
$self->{article}{$index}
}
sub new {
my ($self, $file) = @_;
open my $fh, '<', $file or die $!;
binmode $fh;
my %header;
for (@{HEADER_SPEC()}) {
Abilities
view release on metacpan or search on metacpan
lib/Abilities.pm view on Meta::CPAN
Receives the name of an action, and possibly a constraint, and returns a true
value if the user/role can perform the provided action.
=cut
sub can_perform {
my ($self, $action, $constraint) = @_;
# a super-user/super-role can do whatever they want
return 1 if $self->is_super;
lib/Abilities.pm view on Meta::CPAN
not to a role that inherits from that role (see L</"does_role( $role )">
instead).
=cut
sub assigned_role {
my ($self, $role) = @_;
return unless $role;
foreach ($self->roles) {
lib/Abilities.pm view on Meta::CPAN
and the 'admins' role inherits from the 'devs' role, then C<does_role('devs')>
will return true for that user (while C<assigned_role('devs')> returns false).
=cut
sub does_role {
my ($self, $role) = @_;
return unless $role;
foreach (map([$_, $self->get_role($_)], $self->roles)) {
lib/Abilities.pm view on Meta::CPAN
of actions, values will be 1 (for yes/no actions) or a single-item array-ref
with the name of a constraint (for constrained actions).
=cut
sub abilities {
my $self = shift;
my $abilities = {};
# load direct actions granted to this user/role
Abstract-Meta-Class
view release on metacpan or search on metacpan
examples/example1.pl view on Meta::CPAN
has '$.id';
has '$.name';
has '$.password' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
$$value_ref = sha1_hex($$value_ref);
$self;
}
);
has '$.email' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
die "invalid email format:" . $$value_ref
unless $$value_ref =~ m/^<?[^@<>]+@[^@.<>]+(?:\.[^@.<>]+)+>?$/;
$self;
}
);
has '$.address';
has '%.roles' ;
sub is_valid_password {
my ($self, $password) = @_;
!! ($self->password eq sha1_hex($password));
}
Ac_me-Local
view release on metacpan or search on metacpan
lib/Ac_me/Local.pm view on Meta::CPAN
=head2 function1
=cut
sub function1 {
}
=head2 function2
=cut
sub function2 {
}
=head1 AUTHOR
Thibault Duponchelle, C<< <thibault.duponchelle at gmail.com> >>
AcePerl
view release on metacpan or search on metacpan
# now completely deprecated and gone
# *find_many = \&fetch_many;
# *models = \&classes;
sub connect {
my $class = shift;
my ($host,$port,$user,$pass,$path,$program,
$objclass,$timeout,$query_timeout,$database,
$server_type,$url,$u,$p,$cache,$other);
$self->_create_cache($cache) if $cache;
$self->name2db("$self",$self);
return $self;
}
sub reopen {
my $self = shift;
return 1 if $self->ping;
my $class = ref($self->{database});
my $database;
if ($self->{path}) {
}
$self->{database} = $database;
1;
}
sub class {
my $self = shift;
my $d = $self->{class};
$self->{class} = shift if @_;
$d;
}
sub class_for {
my $self = shift;
my ($class,$id) = @_;
my $selected_class;
if (my $selector = $self->class) {
unless $selected_class->can('new');
$selected_class;
}
sub process_url {
my $class = shift;
my $url = shift;
my ($host,$port,$user,$pass,$path,$server_type) = ('','','','','','');
if ($url) { # look for host:port
return ($host,$port,$user,$pass,$path,$server_type);
}
# Return the low-level Ace::AceDB object
sub db {
return $_[0]->{'database'};
}
# Fetch a model from the database.
# Since there are limited numbers of models, we cache
# the results internally.
sub model {
my $self = shift;
require Ace::Model;
my $model = shift;
my $break_cycle = shift; # for breaking cycles when following #includes
my $key = join(':',$self,'MODEL',$model);
}
# cached get
# pass "1" for fill to get a full fill
# pass any other true value to get a tag fill
sub get {
my $self = shift;
my ($class,$name,$fill) = @_;
# look in caches first
my $obj = $self->memory_cache_fetch($class=>$name)
# _acedb_get() does the caching
$obj = $self->_acedb_get($class,$name,$fill) or return;
$obj;
}
sub _acedb_get {
my $self = shift;
my ($class,$name,$filltag) = @_;
return unless $self->count($class,$name) >= 1;
#return $self->{class}->new($class,$name,$self,1) unless $filltag;
#### CACHE AND CARRY CODE ####
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ":",$self,$class,$name;
return unless defined $MEMORY_CACHE{$key};
carp "memory_cache hit on $class:$name"
if Ace->debug;
return $MEMORY_CACHE{$key};
}
sub memory_cache_store {
my $self = shift;
croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
my $obj = shift;
my $key = join ':',$obj->db,$obj->class,$obj->name;
return if exists $MEMORY_CACHE{$key};
carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
weaken($MEMORY_CACHE{$key} = $obj);
}
sub memory_cache_clear {
my $self = shift;
%MEMORY_CACHE = ();
}
sub memory_cache_delete {
my $package = shift;
my $obj = shift or croak "Usage: memory_cache_delete(\$obj)";
my $key = join ':',$obj->db,$obj->class,$obj->name;
delete $MEMORY_CACHE{$key};
}
# Call as:
# $ace->file_cache_fetch($class=>$id)
sub file_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ':',$class,$name;
my $cache = $self->cache or return;
my $obj = $cache->get($key);
$obj;
}
# call as
# $ace->file_cache_store($obj);
sub file_cache_store {
my $self = shift;
my $obj = shift;
return unless $obj->name;
cluck "NULL OBJECT";
}
$cache->set($key,$obj);
}
sub file_cache_delete {
my $self = shift;
my $obj = shift;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
#### END: CACHE AND CARRY CODE ####
# Fetch one or a group of objects from the database
sub fetch {
my $self = shift;
my ($class,$pattern,$count,$offset,$query,$filled,$total,$filltag) =
rearrange(['CLASS',['NAME','PATTERN'],'COUNT','OFFSET','QUERY',
['FILL','FILLED'],'TOTAL','FILLTAG'],@_);
}
return wantarray ? @h : $h[0];
}
sub cache {
my $self = shift;
my $d = $self->{filecache};
$self->{filecache} = shift if @_;
$d;
}
sub _create_cache {
my $self = shift;
my $params = shift;
$params = {} if $params and !ref $params;
return unless eval {require Cache::SizeAwareFileCache}; # not installed
my $cache_obj = Cache::SizeAwareFileCache->new(\%cache_params);
$self->cache($cache_obj);
}
# class method
sub name2db {
shift;
my $name = shift;
return unless defined $name;
my $d = $NAME2DB{$name};
# weaken($NAME2DB{$name} = shift) if @_;
$NAME2DB{$name} = shift if @_;
$d;
}
# make a new object using indicated class and name pattern
sub new {
my $self = shift;
my ($class,$pattern) = rearrange([['CLASS'],['NAME','PATTERN']],@_);
croak "You must provide -class and -pattern arguments"
unless $class && $pattern;
# escape % signs in the string
}
$self->fetch($1 => $2);
}
# perform an AQL query
sub aql {
my $self = shift;
my $query = shift;
my $db = $self->db;
my $r = $self->raw_query("aql -j $query");
if ($r =~ /(AQL error.*)/) {
return @r;
}
# Return the contents of a keyset. Pattern matches are allowed, in which case
# the keysets will be merged.
sub keyset {
my $self = shift;
my $pattern = shift;
$self->raw_query (qq{find keyset "$pattern"});
$self->raw_query (qq{follow});
return $self->_list;
#########################################################
# These functions are for low-level (non OO) access only.
# This is for low-level access only.
sub show {
my ($self,$class,$pattern,$tag) = @_;
$Ace::Error = '';
return unless $self->count($class,$pattern);
# if we get here, then we've got some data to return.
return;
}
return grep (!m!^//!,split("\n\n",$result));
}
sub read_object {
my $self = shift;
return unless $self->{database};
my $result;
while ($self->{database}->status == STATUS_PENDING()) {
my $data = $self->{database}->read();
}
return $result;
}
# do a query, and return the result immediately
sub raw_query {
my ($self,$query,$no_alert,$parse) = @_;
$self->_alert_iterators unless $no_alert;
$self->{database}->query($query, $parse ? ACE_PARSE : () );
return $self->read_object;
}
# return the last error
sub error {
my $class = shift;
$Ace::Error = shift() if defined($_[0]);
$Ace::Error=~s/\0//g; # get rid of nulls
return $Ace::Error;
}
# close the database
sub close {
my $self = shift;
$self->raw_query('save') if $self->auto_save;
foreach (keys %{$self->{iterators}}) {
$self->_unregister_iterator($_);
}
delete $self->{database};
}
sub DESTROY {
my $self = shift;
return if caller() =~ /^Cache\:\:/;
warn "$self->DESTROY at ", join ' ',caller() if Ace->debug;
$self->close;
}
#####################################################################
###################### private routines #############################
sub rearrange {
my($order,@param) = @_;
return unless @param;
my %param;
if (ref $param[0] eq 'HASH') {
push (@return_array,\%param) if %param;
return @return_array;
}
# do a query, but don't return the result
sub _query {
my ($self,@query) = @_;
$self->_alert_iterators;
$self->{'database'}->query("@query");
}
# return a portion of the active list
sub _list {
my $self = shift;
my ($count,$offset) = @_;
my (@result);
my $query = 'list -j';
$query .= " -b $offset" if defined $offset;
}
return @result;
}
# return a portion of the active list
sub _fetch {
my $self = shift;
my ($count,$start,$tag) = @_;
my (@result);
$tag = '' unless defined $tag;
my $query = "show -j $tag";
}
}
return wantarray ? @result : $result[0];
}
sub _fetch_chunk {
my $self = shift;
return unless $self->{database}->status == STATUS_PENDING();
my $result = $self->{database}->read();
$result =~ s/\0//g; # get rid of &$#&@!! nulls
my @chunks = split("\n\n",$result);
push(@result,$self->class_for($class,$id)->newFromText($_,$self));
}
return @result;
}
sub _alert_iterators {
my $self = shift;
foreach (keys %{$self->{iterators}}) {
$self->{iterators}{$_}->invalidate if $self->{iterators}{$_};
}
undef $self->{active_list};
}
sub asString {
my $self = shift;
return "tace://$self->{path}" if $self->{'path'};
my $server = $self->db && $self->db->isa('Ace::SocketServer') ? 'sace' : 'rpcace';
return "$server://$self->{host}:$self->{port}" if $self->{'host'};
return ref $self;
}
sub cmp {
my ($self,$arg,$reversed) = @_;
my $cmp;
if (ref($arg) and $arg->isa('Ace')) {
$cmp = $self->asString cmp $arg->asString;
} else {
return $reversed ? -$cmp : $cmp;
}
# Count the objects matching pattern without fetching them.
sub count {
my $self = shift;
my ($class,$pattern,$query) = rearrange(['CLASS',
['NAME','PATTERN'],
'QUERY'],@_);
$Ace::Error = '';
=cut
# -------------------- AUTOLOADED SUBS ------------------
sub debug {
my $package = shift;
my $d = $DEBUG_LEVEL;
$DEBUG_LEVEL = shift if @_;
$d;
}
# Return true if the database is still connected. This is oddly convoluted
# because there are numerous things that can go wrong, including:
# 1. server has gone away
# 2. server has timed out our connection! (grrrrr)
# 3. communications channel contains unread garbage and is in an inconsistent state
sub ping {
my $self = shift;
local($SIG{PIPE})='IGNORE'; # so we don't get a fatal exception during the check
my $result = $self->raw_query('');
return unless $result; # server has gone away
return if $result=~/broken connection|client time out/; # server has timed us out
return unless $self->{database}->status() == STATUS_WAITING(); #communications oddness
return 1;
}
# Get or set the display style for dates
sub date_style {
my $self = shift;
$self->{'date_style'} = $_[0] if defined $_[0];
return $self->{'date_style'};
}
# Get or set whether we retrieve timestamps
sub timestamps {
my $self = shift;
$self->{'timestamps'} = $_[0] if defined $_[0];
return $self->{'timestamps'};
}
# Add one or more objects to the database
sub put {
my $self = shift;
my @objects = @_;
my $count = 0;
$Ace::Error = '';
foreach my $object (@objects) {
}
return $count;
}
# Parse a single object and return the result as an object
sub parse {
my $self = shift;
my $ace_data = shift;
my @lines = split("\n",$ace_data);
foreach (@lines) { s/;/\\;/; } # protect semicolons
my $query = join("; ",@lines);
return $results[0];
}
# Parse a single object as longtext and return the result
# as an object
sub parse_longtext {
my $self = shift;
my ($title,$body) = @_;
my $mm = "parse =
Longtext $title
$body
return $results[0];
}
# Parse a file and return all the results
sub parse_file {
my $self = shift;
my ($file,$keepgoing) = @_;
local(*ACE);
local($/) = ''; # paragraph mode
my(@objects,$errors);
return @objects;
}
# Create a new Ace::Object in the indicated database
# (doesn't actually write into database until you do a commit)
sub new {
my $self = shift;
my ($class,$name) = rearrange([qw/CLASS NAME/],@_);
return if $self->fetch($class,$name);
my $obj = $self->class_for($class,$name)->new($class,$name,$self);
return $obj;
}
# Return the layout, which contains classes that should be displayed
sub layout {
my $self = shift;
my $result = $self->raw_query('layout');
$result=~s{\n(\s*\n|//.*\n|\0)+\Z}{}m; # get rid of extraneous information
$result;
}
# Return a hash of all the classes and the number of objects in each
sub class_count {
my $self = shift;
return $self->raw_query('classes') =~ /^\s+(\S+) (\d+)/gm;
}
# Return a hash of miscellaneous status information from the server
# (to be expanded later)
sub status {
my $self = shift;
my $data = $self->raw_query('status');
study $data;
my %status;
memory => $memory * 1024,
};
return wantarray ? %status : \%status;
}
sub title {
my $self = shift;
my $status= $self->status;
$status->{database}{title};
}
sub version {
my $self = shift;
my $status= $self->status;
$status->{database}{version};
}
sub auto_save {
my $self = shift;
if ($self->db && $self->db->can('auto_save')) {
$self->db->auto_save;
} else {
$self->{'auto_save'} = $_[0] if defined $_[0];
return $self->{'auto_save'};
}
}
# Perform an ace query and return the result
sub find {
my $self = shift;
my ($query,$count,$offset,$filled,$total) = rearrange(['QUERY','COUNT',
'OFFSET',['FILL','FILLED'],'TOTAL'],@_);
$offset += 0;
$query = "find $query" unless $query=~/^find/i;
}
#########################################################
# Grep function returns count in a scalar context, list
# of retrieved objects in a list context.
sub grep {
my $self = shift;
my ($pattern,$count,$offset,$filled,$filltag,$total,$long) =
rearrange(['PATTERN','COUNT','OFFSET',['FILL','FILLED'],'FILLTAG','TOTAL','LONG'],@_);
$offset += 0;
my $grep = defined($long) && $long ? 'LongGrep' : 'grep';
@h = $filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
@h;
}
sub pick {
my ($self,$class,$item) = @_;
$Ace::Error = '';
# assumption of uniqueness of name is violated by some classes!
# return () unless $self->count($class,$item) == 1;
return unless $self->count($class,$item) >= 1;
return $result[0];
}
# these two only get loaded if the Ace::Freesubs .XS isn't compiled
sub freeprotect {
my $class = shift;
my $text = shift;
$text =~ s/\n/\\n/g;
$text =~ s/\t/\\t/g;
$text =~ s/"/\\"/g;
return qq("$text");
}
sub split {
my $class = shift;
my $text = shift;
$text =~ s/\\n/\n/g;
$text =~ s/\\t/\t/g;
my ($id,$ts);
return ($class,$id) unless $ts;
return ($class,$id,$ts); # return timestamp
}
# Return a list of all the classes known to the server.
sub classes {
my ($self,$invisible) = @_;
my $query = defined($invisible) && $invisible ?
"query find class !buried"
:
"query find class visible AND !buried";
return $self->_list;
}
################## iterators ##################
# Fetch many objects in iterative style
sub fetch_many {
my $self = shift;
my ($class,$pattern,$filled,$query,$chunksize) = rearrange( ['CLASS',
['PATTERN','NAME'],
['FILL','FILLED'],
'QUERY',
}
my $iterator = Ace::Iterator->new($self,$query,$filled,$chunksize);
return $iterator;
}
sub _register_iterator {
my ($self,$iterator) = @_;
$self->{iterators}{$iterator} = $iterator;
}
sub _unregister_iterator {
my ($self,$iterator) = @_;
$self->_restore_iterator($iterator);
delete $self->{iterators}{$iterator};
}
sub _save_iterator {
my $self = shift;
my $iterator = shift;
return unless $self->{iterators}{$iterator};
$self->{iterator_stack} ||= [];
return 1 if grep { $_ eq $iterator } @{$self->{iterator_stack}};
1; # result code -- CHANGE THIS LATER
}
# horrid method that keeps the database's view of
# iterators in synch with our view
sub _restore_iterator {
my $self = shift;
my $iterator = shift;
# no such iterator known, return false
return unless $self->{iterators}{$iterator};
splice(@$list,$i,1); # remove from position
return 1;
}
sub datetime {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d %02d:%02d:%02d",$year,$mon+1,$day,$hour,$min,$sec);
}
sub date {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d",$year,$mon+1,$day);
Acme-123
view release on metacpan or search on metacpan
lib/Acme/123.pm view on Meta::CPAN
'sp' => [qw /uno dos tres cuatro cinco seis siete ocho nueve diez/],
'it' => [qw /uno due tre quattro cinque sei sette otto nove dieci/]
);
my @numbers = @{$languages {en}};
sub printnumbers {
foreach (@numbers) {
print "$_ \n";
}
}
sub setLanguage {
my $self = shift;
my $language = shift;
@numbers = @{$languages {$language}};
}
sub getnumbers {
return @numbers;
}
sub new
{
my ($class, %parameters) = @_;
my $self = bless ({}, ref ($class) || $class);
Acme-1337
view release on metacpan or search on metacpan
lib/Acme/L337.pm view on Meta::CPAN
package L337;
use strict;
sub translate($string) {
# Common leet
my $tempstring;
$tempstring =~ "tr/[i,I]/!";
$tempstring =~ "tr/[t,T]/7";
$tempstring =~ "tr/[e,E]/3";
Acme-24
view release on metacpan or search on metacpan
lib/Acme/24.pm view on Meta::CPAN
use XML::RSSLite ();
use constant URL => 'http://www.notrly.com/jackbauer';
# Returns one random fact
sub random_jackbauer_fact
{
my $url = URL;
my $page = LWP::Simple::get($url);
my $fact = '';
lib/Acme/24.pm view on Meta::CPAN
return($fact);
}
# Returns an array of 24 random facts
sub random_jackbauer_facts
{
my @facts = ();
my $url = URL . '/rss.php';
my $tries = 5;
my %seen;
lib/Acme/24.pm view on Meta::CPAN
return(\@facts);
}
# Build a database of Jack Bauer facts
sub collect_facts
{
my($self, $file) = @_;
$file ||= './jackbauer.txt';
my $new_facts = $self->random_jackbauer_facts();
return unless $new_facts;
Acme-2zicon
view release on metacpan or search on metacpan
lib/Acme/2zicon.pm view on Meta::CPAN
TsurumiMoe
OtsukaMiyu
YamatoAo
);
sub new {
my $class = shift;
my $self = bless {members => []}, $class;
$self->_initialize;
return $self;
}
sub members {
my ($self, $type, @members) = @_;
@members = @{$self->{members}} unless @members;
return @members unless $type;
}
sub sort {
my ($self, $type, $order, @members) = @_;
@members = $self->members unless @members;
# order by desc if $order is true
if ($order) {
lib/Acme/2zicon.pm view on Meta::CPAN
else {
return sort {$a->$type <=> $b->$type} @members;
}
}
sub select {
my ($self, $type, $number, $operator, @members) = @_;
$self->_die('invalid operator was passed in')
unless grep {$operator eq $_} qw(== >= <= > <);
@members = $self->members unless @members;
my $compare = eval "(sub { \$number $operator \$_[0] })";
return grep { $compare->($_->$type) } @members;
}
sub _initialize {
my $self = shift;
for my $member (@members) {
my $module_name = 'Acme::2zicon::'.$member;
lib/Acme/2zicon.pm view on Meta::CPAN
}
return 1;
}
sub _die {
my ($self, $message) = @_;
Carp::croak($message);
}
1;
Acme-3mxA
view release on metacpan or search on metacpan
lib/Acme/3mxA.pm view on Meta::CPAN
use utf8;
package Acme::3mxA;
sub import {
Acme::ÇmÉ”A->import;
}
"með blóðnasir"
Acme-6502
view release on metacpan or search on metacpan
inc/MyBuilder.pm view on Meta::CPAN
package MyBuilder;
use base qw( Module::Build );
sub create_build_script {
my ( $self, @args ) = @_;
$self->_auto_mm;
return $self->SUPER::create_build_script( @args );
}
sub _auto_mm {
my $self = shift;
my $mm = $self->meta_merge;
my @meta = qw( homepage bugtracker MailingList repository );
for my $meta ( @meta ) {
next if exists $mm->{resources}{$meta};
inc/MyBuilder.pm view on Meta::CPAN
$mm->{resources}{$meta} = $av if defined $av;
}
$self->meta_merge( $mm );
}
sub _auto_repository {
my $self = shift;
if ( -d '.svn' ) {
my $info = `svn info .`;
return $1 if $info =~ /^URL:\s+(.+)$/m;
}
inc/MyBuilder.pm view on Meta::CPAN
return $url;
}
return;
}
sub _auto_bugtracker {
'http://rt.cpan.org/NoAuth/Bugs.html?Dist=' . shift->dist_name;
}
sub ACTION_testauthor {
my $self = shift;
$self->test_files( 'xt/author' );
$self->ACTION_test;
}
sub ACTION_critic {
exec qw( perlcritic -1 -q -profile perlcriticrc lib/ ), glob 't/*.t';
}
sub ACTION_tags {
exec(
qw(
ctags -f tags --recurse --totals
--exclude=blib
--exclude=.svn
inc/MyBuilder.pm view on Meta::CPAN
t/ lib/
)
);
}
sub ACTION_tidy {
my $self = shift;
my @extra = qw( Build.PL );
my %found_files = map { %$_ } $self->find_pm_files,
Acme-ADEAS-Utils
view release on metacpan or search on metacpan
lib/Acme/ADEAS/Utils.pm view on Meta::CPAN
Accepts a list, returns the sum of the numbers provided. Anything
that isn't a number will be treated as zero.
=cut
sub sum {
my $sum = 0;
foreach my $element ( @_ ) {
# I could get a module to do this check, but I don't want to
( run in 0.526 second using v1.01-cache-2.11-cpan-00829025b61 )