view release on metacpan or search on metacpan
lib/Acme/Crux.pm view on Meta::CPAN
}, $class;
# Modes
foreach my $mode ( @{(ALOWED_MODES)}) {
$self->{$mode."mode"} = 1 if is_true_flag($args->{$mode});
}
# Root dir
my $root = $self->{root};
$root = $self->{root} = $pwd if defined($root) && $root eq '.';
unless (defined($root) && length($root)) {
$root = $self->{root} = File::Spec->catdir(SYSCONFDIR, $moniker);
}
# Temp dir
my $temp = $self->{tempdir};
unless (defined($temp) && length($temp)) {
$temp = $self->{tempdir} = File::Spec->catdir(File::Spec->tmpdir(), $moniker);
}
# Data dir
my $datadir = $self->{datadir};
unless (defined($datadir) && length($datadir)) {
$datadir = $self->{datadir} = File::Spec->catdir(SHAREDSTATEDIR, $moniker);
}
# Log dir
my $logdir = $self->{logdir};
unless (defined($logdir) && length($logdir)) {
$logdir = $self->{logdir} = File::Spec->catdir(LOGDIR, $moniker);
}
# Share dir
my $sharedir = $self->{sharedir};
unless (defined($sharedir) && length($sharedir)) {
$self->{sharedir} = File::Spec->catdir(DATADIR, $moniker);
}
# Doc dir
my $docdir = $self->{docdir};
unless (defined($docdir) && length($docdir)) {
$self->{docdir} = File::Spec->catdir(DOCDIR, $moniker);
}
# Cache dir
my $cachedir = $self->{cachedir};
unless (defined($cachedir) && length($cachedir)) {
$self->{cachedir} = File::Spec->catdir(CACHEDIR, $moniker);
}
# Spool dir
my $spooldir = $self->{spooldir};
unless (defined($spooldir) && length($spooldir)) {
$self->{spooldir} = File::Spec->catdir(SPOOLDIR, $moniker);
}
# Run dir
my $rundir = $self->{rundir};
unless (defined($rundir) && length($rundir)) {
$rundir = $self->{rundir} = File::Spec->catdir(RUNDIR, $moniker);
}
# Lock dir
my $lockdir = $self->{lockdir};
unless (defined($lockdir) && length($lockdir)) {
$self->{lockdir} = File::Spec->catdir(LOCKDIR, $moniker);
}
# Web dir
my $webdir = $self->{webdir};
unless (defined($webdir) && length($webdir)) {
$self->{webdir} = File::Spec->catdir(WEBDIR, $moniker);
}
# Config file
my $configfile = $self->{configfile};
unless (defined($configfile) && length($configfile)) {
$self->{configfile} = File::Spec->catfile(IS_ROOT ? $root : $pwd, sprintf("%s.conf", $moniker));
}
# Log file
my $logfile = $self->{logfile};
unless (defined($logfile) && length($logfile)) {
$self->{logfile} = File::Spec->catfile(IS_ROOT ? $logdir : $pwd, sprintf("%s.log", $moniker));
}
# PID file
my $pidfile = $self->{pidfile};
unless (defined($pidfile) && length($pidfile)) {
$self->{pidfile} = File::Spec->catfile(IS_ROOT ? $rundir : $pwd, sprintf("%s.pid", $moniker));
}
# Define plugins list to plugin map
$self->plugins(as_hash_ref($args->{plugins}));
# Preloading plugins
my $preload_plugins = $self->{preload_plugins};
$preload_plugins = [$preload_plugins] unless is_array_ref($preload_plugins);
my $pplgns = words(@$preload_plugins);
lib/Acme/Crux.pm view on Meta::CPAN
}
# Plugins
sub plugins {
my $self = shift;
return $self->{plugins} if scalar(@_) < 1;
my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
my $plugins = $self->{plugins};
foreach my $k (keys %$args) {
next if exists($plugins->{$k}) && $plugins->{$k}->{loaded}; # Skip loaded plugins
$plugins->{$k} = { class => $args->{$k}, loaded => 0 } if length($args->{$k} // '');
}
return $self;
}
sub plugin {
my $self = shift;
my $name = shift // ''; # Plugin name
my $class = shift // ''; # Plugin class
my @args = @_;
my $plugins = $self->{plugins}; # Get list of plugins
return unless length $name;
# Lookup class by name
unless (length($class)) {
# Lookup in existing plugins
$class = $plugins->{$name}->{class} // '' if exists $plugins->{$name};
# Lookup in defaults
$class = DEFAULT_PLUGINS()->{$name} // '' unless length $class;
}
return unless length $class;
# Register found plugin
$self->register_plugin($name, $class, @args); # name, class, args
}
sub register_plugin {
my $self = shift;
my $name = shift // ''; # Plugin name
my $class = shift // ''; # Plugin class
my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}; # Plugin arguments
my $plugins = $self->{plugins};
croak "No plugin name specified!" unless length $name;
croak "No plugin class specified!" unless length $class;
# Load plugin if not exists in already loaded plugins list
return 1 if exists($plugins->{$name}) && $plugins->{$name}->{loaded};
if (my $error = load_class($class)) {
$self->verbosemode
? die qq{Plugin "$name" missing, maybe you need to install it?\n$error\n}
: die qq{Plugin "$name" missing, maybe you need to install it?\n};
}
# Create plugin instance
lib/Acme/Crux.pm view on Meta::CPAN
sub register_handler {
my $class = shift;
$class = ref($class) if ref($class);
my %info = @_;
my $k = "$class.$$";
$Acme::Crux::Sandbox::HANDLERS{$k} = {} unless exists($Acme::Crux::Sandbox::HANDLERS{$k});
my $handlers = $Acme::Crux::Sandbox::HANDLERS{$k};
# Handler name
my $name = trim($info{handler} // $info{name} // 'default');
croak("The handler name missing") unless length($name);
delete $info{handler};
$info{name} = $name;
croak("The $name duplicate handler definition") if defined($handlers->{$name});
# Handler aliases
my $_aliases = $info{alias} // $info{aliases} // [];
$_aliases = [ trim($_aliases) ] unless is_array_ref($_aliases);
my $aliases = words(@$_aliases);
#foreach my $al (@$_aliases) {
# next unless defined($al) && is_value($al);
# foreach my $p (split(/[\s;,]+/, $al)) {
# next unless defined($p) && length($p);
# $aliases{$p} = 1;
# }
#}
delete $info{alias};
$info{aliases} = [grep {$_ ne $name} @$aliases];
# Handler description
$info{description} //= '';
# Handler params
lib/Acme/Crux.pm view on Meta::CPAN
my $code = $info{code} || sub {return 1};
$info{code} = is_code_ref($code) ? $code : sub { $code };
# Set info to handler data
$handlers->{$name} = {%info};
return 1;
}
sub lookup_handler {
my $self = shift;
my $name = trim(shift // '');
return undef unless length $name;
my $invocant = ref($self) || scalar(caller(0));
my $handlers = $Acme::Crux::Sandbox::HANDLERS{"$invocant.$$"};
return undef unless defined($handlers) && is_hash_ref($handlers);
foreach my $n (keys %$handlers) {
my $aliases = as_array_ref($handlers->{$n}->{aliases});
return $handlers->{$n} if grep {defined && $_ eq $name} ($n, @$aliases);
}
return undef;
}
sub handlers {
lib/Acme/Crux.pm view on Meta::CPAN
my $invocant = ref($self) || scalar(caller(0));
my $handlers = $Acme::Crux::Sandbox::HANDLERS{"$invocant.$$"};
return [] unless defined($handlers) && is_hash_ref($handlers);
return [(sort {$a cmp $b} keys %$handlers)] unless $all;
# All: names and aliases
my %seen = ();
foreach my $n (keys %$handlers) {
my $aliases = as_array_ref($handlers->{$n}->{aliases});
foreach my $_a ($n, @$aliases) {
$seen{$_a} = 1 if defined($_a) and length($_a);
}
}
return [(sort {$a cmp $b} keys %seen)];
}
sub run_handler {
my $self = shift;
my $name = shift // 'default';
my @args = @_;
if ($self->{running}) {
$self->error(sprintf(qq{The application "%s" is already runned}, $self->project));
return 0;
}
unless(length($name)) {
$self->error("Invalid handler name");
return 0;
}
my $meta = $self->lookup_handler($name);
unless ($meta) {
$self->error(sprintf("Handler %s not found", $name));
return 0;
}
# Run
lib/Acme/Crux.pm view on Meta::CPAN
}
sub run { goto &run_handler }
# Internal functions (NOT METHODS)
sub _project2moniker {
my $prj = shift;
return unless defined($prj);
$prj =~ s/::/-/g;
$prj =~ s/[^A-Za-z0-9_\-.]/_/g; # Remove incorrect chars
$prj =~ s/([_\-.]){2,}/$1/g; # Remove dubles
return unless length($prj);
return lc($prj);
}
1;
package Acme::Crux::Sandbox;
our %HANDLERS = ();
1;
lib/Acme/Crux/Plugin/Log.pm view on Meta::CPAN
|| ($has_config ? $app->config->get("/logfacility") : ''); # From config file
# Log file: PLGARGS || OPTS || CONF || ORIG || DEFS
my $file = $args->{file} # From plugin arguments first
|| $app->getopt("logfile") # From command line options
|| ($has_config ? $app->config->get("/logfile") : '') # From config file
|| $app->logfile; # From App arguments
# Format: PLGARGS || DEFS
my $frmt = $args->{format} || $app->orig->{"logformat"};
if (defined($frmt) && length($frmt)) {
croak(qq{Invalid log format coderef}) unless is_code_ref($frmt);
}
# Handle: PLGARGS || DEFS
my $handle = $args->{handle} || $app->orig->{"loghandle"};
if (defined $handle) {
croak(qq{Invalid log handle}) unless is_ref($handle);
}
# Log ident: PLGARGS || OPTS || ORIG || CONF || DEFS
lib/Acrux/Config.pm view on Meta::CPAN
root => $args->{root} // '', # base path to default files/directories
dirs => $args->{dirs} || [],
noload => $args->{noload} || 0,
options => {},
error => '',
config => {},
pointer => Acrux::Pointer->new,
files => [],
orig => $args->{options} || $args->{opts} || {},
}, $class;
my $myroot = length($self->{root}) ? $self->{root} : getcwd();
# Set dirs
my @dirs = ();
foreach my $dir (as_array($self->{dirs})) {
unless (File::Spec->file_name_is_absolute($dir)) { # rel
$dir = length($myroot)
? File::Spec->rel2abs($dir, $myroot)
: File::Spec->rel2abs($dir);
}
push @dirs, $dir if -e $dir;
}
$self->{dirs} = [@dirs];
# Set config file
my $file = $self->{file};
$file = sprintf("%s.conf", basename($0)) unless length $file;
unless (File::Spec->file_name_is_absolute($file)) { # rel
$file = length($myroot)
? File::Spec->rel2abs($file, $myroot)
: File::Spec->rel2abs($file);
}
$self->{file} = $file;
unless ($self->{noload}) {
unless (-r $file) {
$self->{error} = sprintf("Configuration file \"%s\" not found or unreadable", $file);
return $self;
}
}
lib/Acrux/Config.pm view on Meta::CPAN
# Set config data
$self->{config} = {%config}; # hash data
$self->pointer->data(clone($self->{config}));
return $self;
}
sub config {
my $self = shift;
my $key = shift;
return undef unless $self->{config};
return $self->{config} unless defined $key and length $key;
return $self->{config}->{$key};
}
sub conf { goto &config }
sub get {
my $self = shift;
my $key = shift;
return $self->pointer->get($key);
}
sub first {
my $self = shift;
return undef unless defined($_[0]) && length($_[0]);
my $node = $self->pointer->get($_[0]);
if (is_array_ref($node)) { # Array ref
return exists($node->[0]) ? $node->[0] : undef;
} elsif (is_value($node)) { # Scalar value
return $node;
}
return undef;
}
sub latest {
my $self = shift;
return undef unless defined($_[0]) && length($_[0]);
my $node = $self->pointer->get($_[0]);
if (is_array_ref($node)) { # Array ref
return exists($node->[0]) ? $node->[-1] : undef;
} elsif (is_value($node)) { # Scalar value
return $node;
}
return undef;
}
sub array {
my $self = shift;
return undef unless defined($_[0]) && length($_[0]);
my $node = $self->pointer->get($_[0]);
if (is_array_ref($node)) { # Array ref
return $node;
} elsif (defined($node)) {
return [$node];
}
return [];
}
sub list { goto &array }
sub hash {
my $self = shift;
return undef unless defined($_[0]) && length($_[0]);
my $node = $self->pointer->get($_[0]);
return $node if is_hash_ref($node);
return {};
}
sub object { goto &hash }
1;
__END__
lib/Acrux/Digest/M11R.pm view on Meta::CPAN
use parent qw/Acrux::Digest/;
sub digest {
# See also: Algorithm::CheckDigits::M11_015 and check_okpo()
my $self = shift;
my $data = shift;
$self->data($data) if defined $data;
my $test = $self->data;
croak "Incorrect input digit-string" if !defined($test) || $test =~ m/[^0-9]/g;
my $len = length($test);
my $iters = ($len + (($len & 1) ? 1 : 0)) / 2;
my @digits = split(//, $test); # Get all digits from input string of chars
#printf "Test=%s; len=%d; iters=%d\n", $test, $len, $iters;
my $w_lim = 10; # Maximum for round-robin(10) weight list: 1,2,3,4,5,6,7,8,9,10,1,2,3,4,5...
my $step = 2; # Step for weight list offset calculation for next iteration
# Calculation sum for one weight list by ofset
my $calc = sub {
my $off = shift || 0;
lib/Acrux/Log.pm view on Meta::CPAN
return $logger->$code(@msg);
} else {
carp(sprintf("Can't found '%s' method in '%s' package", $name, ref($logger)));
}
return 0;
}
# Handle
if (my $handle = $self->handle) {
# Set message
my $pfx = (defined($self->{prefix}) && length($self->{prefix})) ? $self->{prefix} : '';
my $_msg = $ENCODING->encode($pfx . $self->{format}->(time, $level, @msg), 0);
# Flush
if ($self->{provider} eq "file") { # Flush to file
flock $handle, LOCK_EX;
$handle->print($_msg) or croak "Can't write to log file: $!";
flock $handle, LOCK_UN;
} elsif ($self->{provider} eq "handle") { # Flush to handle
print $handle $_msg;
} else {
lib/Acrux/Pointer.pm view on Meta::CPAN
}
sub contains { shift->_p(0, @_) }
sub get { shift->_p(1, @_) }
sub _p {
my $self = shift;
my $get = shift;
my $pointer = shift // '';
$pointer =~ s|^/||;
my $data = $self->data;
return $get ? $data : 1 unless length($pointer);
foreach my $p (length($pointer) ? (split /\//, $pointer, -1) : ($pointer)) {
$p =~ s|~1|/|g;
$p =~ s|~0|~|g;
if ((ref($data) eq 'HASH') && exists $data->{$p}) { # Hash ref
$data = $data->{$p}
} elsif ((ref($data) eq 'ARRAY') && ($p =~ /^[0-9]+$/) && @$data > $p) { # Array ref
$data = $data->[$p]
} else { # Not found
return undef;
}
}
lib/Acrux/RefUtil.pm view on Meta::CPAN
Checks for a regular expression reference generated by the C<qr//> operator
=item is_value
Checks whether I<value> is a primitive value, i.e. a defined, non-ref, and
non-type-glob value
=item is_string
Checks whether I<value> is a string with non-zero-length contents,
equivalent to is_value($value) && length($value) > 0
=item is_number
Checks whether I<value> is a number
=item is_integer, is_int8, is_int16, is_int32, is_int64
Checks whether I<value> is an integer
=item is_undef
lib/Acrux/RefUtil.pm view on Meta::CPAN
sub is_undef { !defined($_[0]) }
sub is_scalar_ref { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
sub is_array_ref { ref($_[0]) eq 'ARRAY' }
sub is_hash_ref { ref($_[0]) eq 'HASH' }
sub is_code_ref { ref($_[0]) eq 'CODE' }
sub is_glob_ref { ref($_[0]) eq 'GLOB' }
sub is_regexp_ref { ref($_[0]) eq 'Regexp' }
sub is_regex_ref { goto &is_regexp_ref }
sub is_rx { goto &is_regexp_ref }
sub is_value { defined($_[0]) && !ref($_[0]) && ref(\$_[0]) ne 'GLOB' }
sub is_string { defined($_[0]) && !ref($_[0]) && (ref(\$_[0]) ne 'GLOB') && length($_[0]) }
sub is_number { (defined($_[0]) && !ref($_[0]) && $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?(?:[Ee](?:[+-]?\d+))?$/) ? 1 : 0 }
sub is_integer { (defined($_[0]) && !ref($_[0]) && $_[0] =~ /^[+-]?\d+$/) ? 1 : 0 }
sub is_int8 { (defined($_[0]) && !ref($_[0]) && ($_[0] =~ /^[0-9]{1,3}$/) && ($_[0] < 2**8)) ? 1 : 0 }
sub is_int16 { (defined($_[0]) && !ref($_[0]) && ($_[0] =~ /^[0-9]{1,5}$/) && ($_[0] < 2**16)) ? 1 : 0 }
sub is_int32 { (defined($_[0]) && !ref($_[0]) && ($_[0] =~ /^[0-9]{1,10}$/) && ($_[0] < 2**32)) ? 1 : 0 }
sub is_int64 { (defined($_[0]) && !ref($_[0]) && $_[0] =~ /^[0-9]{1,20}$/) ? 1 : 0 }
# Extended
sub is_void {
my $struct = shift;
lib/Acrux/Util.pm view on Meta::CPAN
=head2 trim
print '"'.trim( " string " ).'"'; # "string"
Returns the string with all leading and trailing whitespace removed.
Trim on undef returns undef. Original this function see String::Util
=head2 truncstr
print truncstr( $string, $cutoff_length, $continued_symbol );
If the $string is longer than the $cutoff_length, then the string will be truncated
to $cutoff_length characters, including the $continued_symbol
(which defaults to '.' if none is specified).
print truncstr( "qwertyuiop", 3, '.' ); # q.p
print truncstr( "qwertyuiop", 7, '.' ); # qw...op
print truncstr( "qwertyuiop", 7, '*' ); # qw***op
Returns a line the fixed length from 3 to the n chars
See also L<CTK::Util/variant_stf>
=head2 tz_diff
print tz_diff( time ); # +0300
print tz_diff( time, ':' ); # +03:00
Returns TimeZone difference value
lib/Acrux/Util.pm view on Meta::CPAN
$dth{'%MONTH'} = DTF->{MOY}->[$dt[4] || 0];
$dth{'%month'} = DTF->{MOY}->[$dt[4] || 0];
# Second block
$dth2{'%G'} = 'GMT' if $g;
$dth2{'%U'} = 'UTC' if $g;
$dth2{'%z'} = tz_diff($t, ':');
$dth2{'%Z'} = $dth2{'%z'}; $dth2{'%Z'} =~ s/\://;
$dth2{'%%'} = '%';
$f =~ s/$_/$dth{$_}/sge for sort { length($b) <=> length($a) } keys %dth;
$f =~ s/$_/$dth2{$_}/sge for qw/%G %U %Z %z %%/;
return $f
}
sub dtf { goto &fdt }
sub tz_diff {
my $tm = shift || time;
my $chr = shift // '';
my $diff = Time::Local::timegm(localtime($tm)) - Time::Local::timegm(gmtime($tm));
$diff = abs($diff);
lib/Acrux/Util.pm view on Meta::CPAN
}
sub dformat { # Simple templating processor
my $f = shift;
my $d = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
$f =~ s/\[([A-Z0-9_\-.]+?)\]/(defined($d->{$1}) ? $d->{$1} : "[$1]")/eg;
return $f;
}
sub strf { # Yet another simple templating processor
my $s = shift // '';
my $h = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
return '' unless length $s;
$h->{'%'} //= '%'; # by default '%' eq '%''
$s =~ s/
(?:
%\{(\w+)\} # short name like %{name}
|
%([%a-zA-Z]) # single character specifier like %d
)
/
( $1
lib/Acrux/Util.pm view on Meta::CPAN
my $string = shift // '';
my $cutoff = shift || 0;
my $marker = shift // '.';
# Get dots dumber
my $dots = 0;
$cutoff = 3 if $cutoff < 3;
if ($cutoff < 6) { $dots = $cutoff - 2 }
else { $dots = 3 }
# Real length of cutted string
my $reallenght = $cutoff - $dots;
# Input string is too short
return $string if length($string) <= $cutoff;
# Truncate
my $fix = floor($reallenght / 2);
my $new_start = substr($string, 0, ($reallenght - $fix)); # Start part of string
$new_start =~ s/\s+$//; # trim
my $new_midle = $marker x $dots; # Middle part of string
my $new_end = substr($string, (length($string) - $fix), $fix); # Last part of string
$new_end =~ s/^\s+//; # trim
return sprintf ("%s%s%s", $new_start, $new_midle, $new_end);
}
sub indent {
my $str = shift // '';
my $ind = floor(shift || 0);
my $chr = shift // ' ';
return $str unless $ind && $ind <= 65535;
return join '', map { ($chr x $ind) . $_ . "\n" } split /\n/, $str;
}
sub words {
my @in;
foreach my $r (@_) {
if (ref($r) eq 'ARRAY') { push @in, @$r } else { push @in, $r }
}
my %o;
my $i = 0;
foreach my $s (@in) {
$s = trim($s // '');
next unless length($s) && !ref($s);
foreach my $w (split(/[\s;,]+/, $s)) {
next unless length($w);
$o{$w} = ++$i unless exists $o{$w};
}
}
return [sort {$o{$a} <=> $o{$b}} keys %o ];
}
# File utils
sub touch {
my $fn = shift // '';
return 0 unless length($fn);
my $t = time;
my $ostat = open my $fh, '>>', $fn;
unless ($ostat) {
carp("Can't touch file \"$fn\": $!");
return 0;
}
close $fh if $ostat;
utime($t, $t, $fn);
return 1;
}
sub eqtime {
my $src = shift // '';
my $dst = shift // '';
return 0 unless length($src);
return 0 unless length($dst);
unless ($src && -e $src) {
carp("Can't get access and modification times of file \"$src\": no file found");
return 0;
}
unless (utime((stat($src))[8,9], $dst)) {
carp("Can't change access and modification times on file \"$dst\": $!");
return 0;
}
return 1;
}
sub slurp {
my $file = shift // '';
my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
return unless length($file) && -r $file;
my $cleanup = 1;
# Open filehandle
my $fh;
if (ref($file)) {
$fh = $file;
$cleanup = 0; # Disable closing filehandle for passed filehandle
} else {
$fh = IO::File->new($file, "r");
unless (defined $fh) {
lib/Acrux/Util.pm view on Meta::CPAN
$fh->close if $cleanup;
return 1;
}
sub spurt { goto &spew }
# Colored helper function
sub color {
my $clr = shift;
my $txt = (scalar(@_) == 1) ? shift(@_) : sprintf(shift(@_), @_);
return $txt unless defined($clr) && length($clr);
return IS_TTY ? colored([$clr], $txt) : $txt;
}
# Misc
sub os_type {
my $os = shift // $^O;
return $OSTYPES{$os} || '';
}
sub is_os_type {
my $type = shift || return;
return os_type(shift) eq $type;
}
# Copied from ExtUtils::MakeMaker and IO::Prompt::Tiny
sub prompt {
my $msg = shift // '';
my $def = shift // '';
my $dispdef = length($def) ? "[$def] " : " ";
# Flush vars
local $|=1;
local $\;
# Prompt message
print length($msg) ? "$msg $dispdef" : "$dispdef";
my $ans;
if (!IS_TTY && eof STDIN) {
print "$def\n";
} else {
$ans = <STDIN>;
if( defined $ans ) {
chomp $ans;
} else { # user hit ctrl-D
print "\n";