view release on metacpan or  search on metacpan

lib/Lazy/Utils.pm  view on Meta::CPAN

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>