File Coverage

blib/lib/Lazy/Utils.pm

Criterion	Covered	Total	%
statement	31	220	14.0
branch	0	106	0.0
condition	0	42	0.0
subroutine	10	29	34.4
pod	12	18	66.6
total	53	415	12.7

package Lazy::Utils;
=head1 NAME

Lazy::Utils - Utility functions

=head1 VERSION

version 1.20

=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);

=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';
use FindBin;
use JSON;
use Pod::Simple::Text;


BEGIN
{
	require Exporter;
	our $VERSION     = '1.20';
	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);
	our @EXPORT_OK   = qw();
}


=head1 FUNCTIONS

=head2 trim($str)

trims given string

$str: I

return value: I

=cut
sub trim
{
	my ($s) = @_;
	$s =~ s/^\s+|\s+$//g;
	return $s
}

=head2 ltrim($str)

trims left given string

$str: I

return value: I

=cut
sub ltrim
{
	my ($s) = @_;
	$s =~ s/^\s+//;
	return $s
}

=head2 rtrim($str)

trims right given string

$str: I

return value: I

=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

$prefs: I

=over

utf8: I

=back

return value: I

=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

$contents: I

$prefs: I

=over

utf8: I

=back

return value: I

=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

$nonquoted: I

return value: I

=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

alternative implementation of perls core system subroutine that executes a system command

$cmd: I

@argv: I

return value: I

returned $?: I

returned $!: I

=cut
sub system2
{
	eval
	{
		my $pid;
		if (not defined($pid = fork))
		{
			return -1;
		}
		if (not $pid)
		{
			no warnings FATAL => 'exec';
			exec(@_);
			die $!;
		}
		if (waitpid($pid, 0) <= 0)
		{
			return -1;
		}
	};
	return -1 if $@;
	return $? >> 8;
}
sub _system
{
	return system2(@_);
}

=head2 bash_readline($prompt)

B I

reads a line from STDIN using Bash

$prompt: I

return value: I

=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 I

B I

resolves command line arguments

$prefs: I

=over

valuableArgs: I

noCommand: I

optionAtAll: I

=back

@argv: I

	-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 I

searches valid binary in search path

$name: I

$path: I

return value: I

=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 I

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

$expiry: I

=over

E0: I

=0: I

E0: I

=back

$coderef: I

return value: I

=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 I

gets a text of pod contents in given file

$file_name: I

$section: I

$exclude_section: I

return value: I

=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(@_);
}


1;
__END__