Lazy-Utils/lib/Lazy/Utils.pm
package Lazy::Utils;
=head1 NAME
Lazy::Utils - Utility functions
=head1 VERSION
version 1.22
=head1 SYNOPSIS
use Lazy::Utils;
trim($str);
ltrim($str);
rtrim($str);
file_get_contents($path, $prefs);
file_put_contents($path, $contents, $prefs);
shellmeta($s, $nonquoted);
system2($cmd, @argv);
bash_readline($prompt);
cmdargs($prefs, @argv);
whereis($name, $path);
file_cache($tag, $expiry, $coderef);
get_pod_text($file_name, $section, $exclude_section);
array_to_hash(@array);
=head1 DESCRIPTION
Collection of utility functions all of exported by default.
=cut
use strict;
use warnings;
use v5.10.1;
use feature qw(switch);
no if ($] >= 5.018), 'warnings' => 'experimental';
require bytes;
require utf8;
use FindBin;
use JSON;
use Pod::Simple::Text;
BEGIN
{
require Exporter;
our $VERSION = '1.22';
our @ISA = qw(Exporter);
our @EXPORT = qw(trim ltrim rtrim file_get_contents file_put_contents shellmeta system2 _system
bash_readline bashReadLine cmdargs commandArgs cmdArgs whereis whereisBin file_cache fileCache
get_pod_text getPodText array_to_hash);
our @EXPORT_OK = qw();
}
=head1 FUNCTIONS
=head2 trim($str)
trims given string
$str: I<string will be trimmed>
return value: I<trimmed string>
=cut
sub trim
{
my ($s) = @_;
$s =~ s/^\s+|\s+$//g;
return $s
}
=head2 ltrim($str)
trims left given string
$str: I<string will be trimmed>
return value: I<trimmed string>
=cut
sub ltrim
{
my ($s) = @_;
$s =~ s/^\s+//;
return $s
}
=head2 rtrim($str)
trims right given string
$str: I<string will be trimmed>
return value: I<trimmed string>
=cut
sub rtrim
{
my ($s) = @_;
$s =~ s/\s+$//;
return $s
}
=head2 file_get_contents($path, $prefs)
gets all contents of file in string type
$path: I<path of file>
$prefs: I<preferences in HashRef, by default undef>
=over
utf8: I<opens file-handle as :utf8 mode, by default 0>
=back
return value: I<file contents in string type, otherwise undef because of errors>
=cut
sub file_get_contents
{
my ($path, $prefs) = @_;
$prefs = {} unless ref($prefs) eq 'HASH';
my $result = do
{
local $/ = undef;
my $mode = "";
$mode .= " :utf8" if $prefs->{utf8};
open my $fh, "<$mode", $path or return;
my $result = <$fh>;
close $fh;
$result;
};
return $result;
}
=head2 file_put_contents($path, $contents, $prefs)
puts all contents of file in string type
$path: I<path of file>
$contents: I<file contents in string type>
$prefs: I<preferences in HashRef, by default undef>
=over
utf8: I<opens file-handle as :utf8 mode, by default 0>
=back
return value: I<success 1, otherwise undef>
=cut
sub file_put_contents
{
my ($path, $contents, $prefs) = @_;
return if not defined($contents) or ref($contents);
$prefs = {} unless ref($prefs) eq 'HASH';
my $result = do
{
local $\ = undef;
my $mode = "";
$mode .= " :utf8" if $prefs->{utf8};
open my $fh, ">$mode", $path or return;
my $result = print $fh $contents;
close $fh;
$result;
};
return $result;
}
=head2 shellmeta($s, $nonquoted)
escapes metacharacters of interpolated shell string
$s: I<interpolated shell string>
$nonquoted: I<also escapes whitespaces and * character for non-quoted interpolated shell string, by default 0>
return value: I<escaped string>
=cut
sub shellmeta
{
my ($s, $nonquoted) = @_;
return unless defined $s;
$s =~ s/(\\|\"|\$)/\\$1/g;
$s =~ s/(\s|\*)/\\$1/g if $nonquoted;
return $s;
}
=head2 system2($cmd, @argv)
B<_system($cmd, @argv)> I<OBSOLETE>
alternative implementation of perls core system subroutine that executes a system command
$cmd: I<command>
@argv: I<command line arguments>
return value: I<exit code of command. -1 if fatal error occurs>
returned $!: I<system error message>
returned $?: I<return code of wait call like on perls system call>
=cut
sub system2
{
my $pid;
return -1 unless defined($pid = fork);
unless ($pid)
{
no warnings FATAL => 'exec';
exec(@_);
exit 255;
}
return -1 unless waitpid($pid, 0) > 0;
return $? >> 8;
}
sub _system
{
return system2(@_);
}
=head2 bash_readline($prompt)
B<bashReadLine($prompt)> I<OBSOLETE>
reads a line from STDIN using Bash
$prompt: I<prompt, by default ''>
return value: I<line>
=cut
sub bash_readline
{
my ($prompt) = @_;
$prompt = "" unless defined($prompt);
my $in = \*STDIN;
unless (-t $in)
{
my $line = <$in>;
chomp $line if defined $line;
return $line;
}
local $/ = "\n";
my $cmd = '/usr/bin/env bash -c "read -p \"'.shellmeta(shellmeta($prompt)).'\" -r -e && echo -n \"\$REPLY\" 2>/dev/null"';
$_ = `$cmd`;
return (not $?)? $_: undef;
}
sub bashReadLine
{
return bash_readline(@_);
}
=head2 cmdargs([$prefs, ]@argv)
B<commandArgs([$prefs, ]@argv)> I<OBSOLETE>
B<cmdArgs([$prefs, ]@argv)> I<OBSOLETE>
resolves command line arguments
$prefs: I<preferences in HashRef, optional>
=over
valuableArgs: I<accepts option value after option if next argument is not an option, by default 0>
noCommand: I<use first parameter instead of command, by default 0>
optionAtAll: I<accepts options after command or first parameter otherwise evaluates as parameter, by default 1>
=back
@argv: I<command line arguments>
-a -b=c -d e --f g --h --i=j k l -- m n
by default, return value:
{ -a => '', -b => 'c', -d => '', --f => '', --h => '', --i => 'j', command => 'e', parameters => ['g', 'k', 'l'], late_parameters => ['m', 'n'] }
if valuableArgs is on, return value;
{ -a => '', -b => 'c', -d => 'e', --f => 'g', --h => '', --i => 'j', command => 'k', parameters => ['l'], late_parameters => ['m', 'n'] }
if noCommand is on, return value:
{ -a => '', -b => 'c', -d => '', --f => '', --h => '', --i => 'j', command => undef, parameters => ['e', 'g', 'k', 'l'], late_parameters => ['m', 'n'] }
if optionAtAll is off, return value:
{ -a => '', -b => 'c', -d => '', command => 'e', parameters => ['--f', 'g', '--h', '--i=j', 'k', 'l', '--','m', 'n'], late_parameters => [] }
=cut
sub cmdargs
{
my $prefs = {};
$prefs = shift if @_ >= 1 and ref($_[0]) eq 'HASH';
my @argv = @_;
my %result;
$result{command} = undef;
$result{parameters} = undef;
my @parameters;
my @late_parameters;
my $late;
my $opt;
while (@argv)
{
my $argv = shift @argv;
next unless defined($argv) and not ref($argv);
if (not (not defined($prefs->{optionAtAll}) or $prefs->{optionAtAll}) and @parameters)
{
push @parameters, $argv;
next;
}
if ($late)
{
push @late_parameters, $argv;
next;
}
if (substr($argv, 0, 2) eq '--')
{
$opt = undef;
if (length($argv) == 2)
{
$late = 1;
next;
}
my @arg = split('=', $argv, 2);
$result{$arg[0]} = $arg[1];
unless (defined($result{$arg[0]}))
{
$result{$arg[0]} = "";
$opt = $arg[0];
}
next;
}
if (substr($argv, 0, 1) eq '-' and length($argv) != 1)
{
$opt = undef;
my @arg = split('=', $argv, 2);
$result{$arg[0]} = $arg[1];
unless (defined($result{$arg[0]}))
{
$result{$arg[0]} = "";
$opt = $arg[0];
}
next;
}
if ($prefs->{valuableArgs} and $opt)
{
$result{$opt} = $argv;
$opt = undef;
next;
}
$opt = undef;
push @parameters, $argv;
}
$result{command} = shift @parameters unless $prefs->{noCommand};
$result{parameters} = \@parameters;
$result{late_parameters} = \@late_parameters;
return \%result;
}
sub commandArgs
{
return cmdargs(@_);
}
sub cmdArgs
{
return cmdargs(@_);
}
=head2 whereis($name, $path)
B<whereisBin($name, $path)> I<OBSOLETE>
searches valid binary in search path
$name: I<binary name>
$path: I<search path, by default "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin">
return value: I<array of binary path founded in search path>
=cut
sub whereis
{
my ($name, $path) = @_;
return () unless $name;
$path = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" unless $path;
return grep(-x $_, map("$_/$name", split(":", $path)));
}
sub whereisBin
{
return whereis(@_);
}
=head2 file_cache($tag, $expiry, $coderef)
B<fileCache($tag, $expiry, $coderef)> I<OBSOLETE>
gets most recent cached value in file cache by given tag and caller function if there is cached value in expiry period. Otherwise tries to get current value using $coderef, puts value in cache and cleanups old cache values.
$tag: I<tag for cache>
$expiry: I<cache expiry period>
=over
E<lt>0: I<always gets most recent cached value if there is any cached value. Otherwise tries to get current value using $coderef, puts and cleanups.>
=0: I<never gets cached value. Always tries to get current value using $coderef, puts and cleanups.>
E<gt>0: I<gets most recent cached value in cache if there is cached value in expiry period. Otherwise tries to get current value using $coderef, puts and cleanups.>
=back
$coderef: I<code reference to get current value>
return value: I<cached or current value, otherwise undef if there isn't cached value and current value doesn't get>
=cut
sub file_cache
{
my ($tag, $expiry, $coderef) = @_;
my $result;
my $now = time();
my @cleanup;
my $caller = (caller(1))[3];
$caller = (caller(0))[0] unless $caller;
$caller = (caller(0))[3].",$caller";
my $tag_encoded = "";
for (0..(bytes::length($tag)-1))
{
my $c = bytes::substr($tag, $_, 1);
if ($c =~ /\W/)
{
$c = uc(sprintf("%%%x", bytes::ord($c)));
}
$tag_encoded .= $c;
}
my $tmp_base = "/tmp/";
my $tmp_prefix = $caller;
$tmp_prefix =~ s/\Q::\E/-/g;
$tmp_prefix .= ".$tag_encoded,";
for my $tmp_path (sort {$b cmp $a} glob("${tmp_base}$tmp_prefix*"))
{
if (my ($epoch, $pid) = $tmp_path =~ /^\Q${tmp_base}$tmp_prefix\E(\d*)\.(\d*)/)
{
if ($expiry < 0 or ($expiry > 0 and $now-$epoch < $expiry))
{
if (not defined($result))
{
my $tmp;
$tmp = file_get_contents($tmp_path);
if ($tmp)
{
if ($tmp =~ /^SCALAR\n(.*)/)
{
$result = $1;
} else
{
eval { $result = from_json($tmp, {utf8 => 1}) };
}
}
}
next;
}
}
unshift @cleanup, $tmp_path;
}
if (not defined($result))
{
$result = $coderef->() if ref($coderef) eq 'CODE';
if (defined($result))
{
my $tmp;
unless (ref($result))
{
$tmp = "SCALAR\n$result";
} else
{
eval { $tmp = to_json($result, {utf8 => 1, pretty => 1}) } if ref($result) eq "ARRAY" or ref($result) eq "HASH";
}
if ($tmp and file_put_contents("${tmp_base}tmp.$tmp_prefix$now.$$", $tmp) and rename("${tmp_base}tmp.$tmp_prefix$now.$$", "${tmp_base}$tmp_prefix$now.$$"))
{
pop @cleanup;
for (@cleanup)
{
unlink($_);
}
}
}
}
return $result;
}
sub fileCache
{
return file_cache(@_);
}
=head2 get_pod_text($file_name, $section, $exclude_section)
B<getPodText($file_name, $section, $exclude_section)> I<OBSOLETE>
gets a text of pod contents in given file
$file_name: I<file name of searching pod, by default running file>
$section: I<searching head1 section of pod, by default undef gets all of contents>
$exclude_section: I<excludes section name, by default undef>
return value: I<text of pod in string or array by line, otherwise undef if an error occurs>
=cut
sub get_pod_text
{
my ($file_name, $section, $exclude_section) = @_;
$file_name = "$FindBin::Bin/$FindBin::Script" unless $file_name;
return unless -e $file_name;
my $parser = Pod::Simple::Text->new();
my $text;
$parser->output_string(\$text);
eval { $parser->parse_file($file_name) };
return if $@;
utf8::decode($text);
$section = ltrim($section) if $section;
my @text = split(/^/m, $text);
my $result;
my @result;
for my $line (@text)
{
chomp $line;
if (defined($section) and not defined($result))
{
if ($line eq $section)
{
unless ($exclude_section)
{
$result = "$line\n";
push @result, $line;
} else
{
$result = "";
}
}
next;
}
last if defined($section) and $line =~ /^\S+/;
$result = "" unless defined($result);
$result .= "$line\n";
push @result, $line;
}
return @result if wantarray;
return $result;
}
sub getPodText
{
return get_pod_text(@_);
}
=head2 array_to_hash(@array)
returns hash with indexes for given array
@array: I<command line arguments>
return value: I<Hash or HashRef by B<wantarray>>
=cut
sub array_to_hash
{
my %h;
my $i = 0;
%h = map { $i++ => $_ } @_;
return \%h unless wantarray;
return %h;
}
1;
__END__
=head1 INSTALLATION
To install this module type the following
perl Makefile.PL
make
make test
make install
from CPAN
cpan -i Lazy::Utils
=head1 DEPENDENCIES
This module requires these other modules and libraries:
=over
=item *
JSON
=item *
Pod::Simple::Text
=back
=head1 REPOSITORY
B<GitHub> L<https://github.com/orkunkaraduman/Lazy-Utils>
B<CPAN> L<https://metacpan.org/release/Lazy-Utils>
=head1 AUTHOR
Orkun Karaduman (ORKUN) <orkun@cpan.org>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2017 Orkun Karaduman <orkunkaraduman@gmail.com>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
=cut