CTKlib
view release on metacpan or search on metacpan
lib/CTK/Util.pm view on Meta::CPAN
Tags: API, BASE
=head3 isos
Returns true or false if the OS name is of the current value of C<$^O>
isos('mswin32') ? "OK" : "NO";
See L<Perl::OSType> for details
Tags: API, BASE
=head3 isostype
Given an OS type and OS name, returns true or false if the OS name is of the
given type.
isostype('Windows') ? "OK" : "NO";
isostype('Unix', 'dragonfly') ? "OK" : "NO";
See L<Perl::OSType/"is_os_type">
Tags: API, BASE
=head3 isFalseFlag
print "Disabled" if isFalseFlag("off");
If specified argument value is set to false then will be normalised to 1.
The following values will be considered as false:
no, off, 0, false, disable
This effect is case-insensitive, i.e. both "No" or "no" will result in 1.
Tags: BASE, UTIL
=head3 isTrueFlag
print "Enabled" if isTrueFlag("on");
If specified argument value is set to true then will be normalised to 1.
The following values will be considered as true:
yes, on, 1, true, enable
This effect is case-insensitive, i.e. both "Yes" or "yes" will result in 1.
Tags: BASE, UTIL
=head3 lf_normalize, nl_normalize
my $normalized_string = lf_normalize( $string );
Returns CR/LF normalized string
Tags: BASE, FORMAT
=head3 localedir
my $value = localedir();
For example value can be set as: /usr/share/locale
See L<Sys::Path/"localedir">
Tags: CORE, BASE, FILE
=head3 localstatedir
my $value = localstatedir();
For example value can be set as: /var
/var - $Config::Config{'prefix'}
/var contains variable data files. This includes spool directories and files, administrative and logging data, and
transient and temporary files.
Some portions of /var are not shareable between different systems. For instance, /var/log, /var/lock, and
/var/run. Other portions may be shared, notably /var/mail, /var/cache/man, /var/cache/fonts, and
/var/spool/news.
/var is specified here in order to make it possible to mount /usr read-only. Everything that once went into /usr
that is written to during system operation (as opposed to installation and software maintenance) must be in /var.
If /var cannot be made a separate partition, it is often preferable to move /var out of the root partition and into
the /usr partition. (This is sometimes done to reduce the size of the root partition or when space runs low in the
root partition.) However, /var must not be linked to /usr because this makes separation of /usr and /var
more difficult and is likely to create a naming conflict. Instead, link /var to /usr/var.
Applications must generally not add directories to the top level of /var. Such directories should only be added if
they have some system-wide implication, and in consultation with the FHS mailing list.
See L<Sys::Path/"localstatedir">
Tags: CORE, BASE, FILE
=head3 localtime2date
$date = localtime2date( time() )
Returns time in format dd.mm.yyyy
Tags: BASE, DATE
=head3 localtime2date_time
$datetime = localtime2date_time( time() )
Returns time in format dd.mm.yyyy hh.mm.ss
Tags: BASE, DATE
=head3 lockdir
my $value = lockdir();
For example value can be set as: /var/lock
Lock files should be stored within the /var/lock directory structure.
Lock files for devices and other resources shared by multiple applications, such as the serial device lock files that
were originally found in either /usr/spool/locks or /usr/spool/uucp, must now be stored in /var/lock.
The naming convention which must be used is "LCK.." followed by the base name of the device. For example, to
lock /dev/ttyS0 the file "LCK..ttyS0" would be created. 5
The format used for the contents of such lock files must be the HDB UUCP lock file format. The HDB format is
lib/CTK/Util.pm view on Meta::CPAN
Get all paths to specified command. Same as which() but will return all the matches.
Based on L<File::Which>
Tags: UTIL, EXT, ATOM
=head3 which
my $ls = which( "ls" );
Get full path to specified command
First argument is the name used in the shell to call the program, e.g., perl.
If it finds an executable with the name you specified, which() will return
the absolute path leading to this executable, e.g., /usr/bin/perl or C:\Perl\Bin\perl.exe.
If it does not find the executable, it returns undef.
Based on L<File::Which>
Tags: UTIL, EXT, ATOM
=head2 TAGS
=over 8
=item B<:ALL>
Exports all functions
=item B<:API>
Exports functions:
L</"getsyscfg">,
L</"isos">,
L</"isostype">,
L</"read_attributes">,
L</"syscfg">
=item B<:ATOM>
Exports all function FILE and EXT
=item B<:BASE>
Exports all function API, FILE, FORMAT, DATE and:
L</"randchars">,
L</"randomize">,
L</"shuffle">
=item B<:CORE>
Exports functions:
L</"cachedir">,
L</"docdir">,
L</"localedir">,
L</"localstatedir">,
L</"lockdir">,
L</"prefixdir">,
L</"rundir">,
L</"sharedir">,
L</"sharedstatedir">,
L</"spooldir">,
L</"srvdir">,
L</"sysconfdir">,
L</"syslogdir">,
L</"webdir">
=item B<:DATE>
Exports functions:
L</"basetime">,
L</"correct_date">,
L</"current_date">,
L</"current_date_time">,
L</"date_time2dig">,
L</"date2dig">,
L</"date2localtime">,
L</"datef">,
L</"datetime2localtime">,
L</"datetimef">,
L</"dig2date">,
L</"dig2date_time">,
L</"dtf">,
L</"localtime2date">,
L</"localtime2date_time">,
L</"tz_diff">,
L</"visokos">
=item B<:EXT>
Exports functions:
L</"exe">,
L</"execute">,
L</"ftp">,
L</"ftpgetlist">,
L</"ftptest">,
L</"send_mail">,
L</"sendmail">,
L</"where">,
L</"which">
=item B<:FILE>
Exports all function CORE and:
L</"bload">,
L</"bsave">,
L</"eqtime">,
L</"file_load">,
L</"file_save">,
L</"fload">,
L</"fsave">,
L</"getdirlist">,
lib/CTK/Util.pm view on Meta::CPAN
=head1 COPYRIGHT
Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See C<LICENSE> file and L<https://dev.perl.org/licenses/>
=cut
use constant {
DEBUG => 1, # 0 - off, 1 - on, 2 - all (+ http headers and other)
WIN => $^O =~ /mswin/i ? 1 : 0,
NULL => $^O =~ /mswin/i ? 'NUL' : '/dev/null',
TONULL => $^O =~ /mswin/i ? '>NUL 2>&1' : '>/dev/null 2>&1',
ERR2OUT => '2>&1',
VOIDFILE => 'void.txt',
DTF => {
DOW => [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/],
DOWS => [qw/Sun Mon Tue Wed Thu Fri Sat/],
MOY => [qw/January February March April May June
July August September October November December/],
MOYS => [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/],
},
};
use vars qw/$VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS/;
$VERSION = '2.83';
use Encode;
use Time::Local;
use File::Spec::Functions qw/
catdir catfile rootdir tmpdir updir curdir
path splitpath splitdir abs2rel rel2abs
/;
use MIME::Base64;
use MIME::Lite;
use Net::FTP;
use File::Path; # mkpath / rmtree
use IPC::Open3;
use Symbol;
use Cwd;
use Carp qw/carp croak cluck confess/;
# carp -- as warn
# croak -- as die
# cluck -- as extended warn
# confess -- as extended die
use base qw /Exporter/;
my @est_api = qw(
read_attributes
syscfg getsyscfg isos isostype
);
my @est_core = qw(
prefixdir localstatedir sysconfdir srvdir
sharedir docdir localedir cachedir syslogdir spooldir rundir lockdir sharedstatedir webdir
);
my @est_util = qw(
randomize randchars shuffle isTrueFlag isFalseFlag
);
my @est_encoding = qw(
to_utf8 to_windows1251 to_cp1251 to_base64 from_utf8
);
my @est_format = qw(
escape unescape slash tag tag_create cdata dformat fformat
lf_normalize nl_normalize file_lf_normalize file_nl_normalize
correct_number correct_dig
variant_stf trim
);
my @est_datetime = qw(
current_date current_date_time localtime2date localtime2date_time correct_date date2localtime
datetime2localtime visokos date2dig dig2date date_time2dig dig2date_time basetime
dtf datetimef datef tz_diff
);
my @est_file = qw(
load_file save_file file_load file_save fsave fload bsave bload touch eqtime
);
my @est_dir = qw(
ls scandirs scanfiles getlist getfilelist getdirlist
preparedir
);
my @est_ext = qw(
sendmail send_mail
ftp ftptest ftpgetlist
exe execute where which
);
@EXPORT = (); # Defaults none
@EXPORT_OK = ( # All
@est_api, @est_core, @est_encoding, @est_format, @est_datetime,
@est_file, @est_dir, @est_ext, @est_util
);
%EXPORT_TAGS = (
DEFAULT => [@EXPORT],
ALL => [@EXPORT_OK],
API => [
@est_api
],
CORE => [
@est_core,
],
FORMAT => [
@est_encoding,
@est_format,
],
DATE => [
@est_datetime,
],
FILE => [
@est_core,
@est_file,
@est_dir,
],
EXT => [
lib/CTK/Util.pm view on Meta::CPAN
binmode(ERR, $bm) if defined($bm) && $bm =~ /\:/;
while (<ERR>) { $ierr .= $_ }
close ERR;
waitpid($pid, 0);
if ($err && ref($err) eq 'SCALAR') {
$$err = $ierr
} else {
carp("Executable error (".join(" ", @scmd)."): $ierr") if $ierr;
}
return $out;
}
sub exe { goto &execute }
sub which {
my $cs = shift;
my $wh = shift;
return undef unless defined $cs;
return undef if $cs eq '';
my @aliases = ($cs);
if (isostype('Windows')) {
my @pext = (qw/.com .exe .bat/);
if ($ENV{PATHEXT}) {
push @pext, split /\s*\;\s*/, lc($ENV{PATHEXT});
}
push @aliases, $cs.$_ for (_uniq(@pext));
}
my @path = path();
unshift @path, curdir();
my @arr = ();
foreach my $p ( @path ) {
foreach my $f ( @aliases ) {
my $file = catfile($p, $f);
next if -d $file;
if (isostype('Windows')) {
if (-e $file) {
my $nospcsf = ($file =~ /\s/) ? sprintf("\"%s\"", $file) : $file;
if ($wh) {push @arr, $nospcsf} else {return $nospcsf}
}
} elsif (isostype('Unix')) {
if (-e $file and -x _) {
if ($wh) {push @arr, $file} else {return $file}
}
} else {
if (-e $file) {
if ($wh) {push @arr, $file} else {return $file}
}
}
}
}
return @arr if $wh;
return undef;
}
sub where { which(shift,1) }
#
# See Sys::Path
#
# prefixdir localstatedir sysconfdir srvdir
# sharedir docdir localedir cachedir syslogdir spooldir rundir lockdir sharedstatedir webdir
#
sub prefixdir {
my $pfx = __PACKAGE__->ext_syscfg('prefix') ;
return defined $pfx ? $pfx : '';
}
sub localstatedir {
my $pfx = prefixdir();
if ($pfx eq '/usr') {
return '/var';
} elsif ($pfx eq '/usr/local') {
return '/var';
}
return catdir($pfx, 'var');
}
sub sysconfdir {
my $pfx = prefixdir();
return $pfx eq '/usr' ? '/etc' : catdir($pfx, 'etc');
}
sub srvdir {
my $pfx = prefixdir();
if ($pfx eq '/usr') {
return '/srv';
} elsif ($pfx eq '/usr/local') {
return '/srv';
}
return catdir($pfx, 'srv');
}
sub webdir {
my $pfx = prefixdir();
return $pfx eq '/usr' ? '/var/www' : catdir($pfx, 'www');
}
sub sharedir { catdir(prefixdir(), 'share') }
sub docdir { catdir(prefixdir(), 'share', 'doc') }
sub localedir { catdir(prefixdir(), 'share', 'locale') }
sub cachedir { catdir(localstatedir(), 'cache') }
sub syslogdir { catdir(localstatedir(), 'log') }
sub spooldir { catdir(localstatedir(), 'spool') }
sub rundir { catdir(localstatedir(), 'run') }
sub lockdir { catdir(localstatedir(), 'lock') }
sub sharedstatedir { catdir(localstatedir(), 'lib') }
#
# Sys core utils
#
sub getsyscfg { __PACKAGE__->ext_syscfg(@_) }
sub syscfg { __PACKAGE__->ext_syscfg(@_) }
sub isostype {__PACKAGE__->ext_isostype(@_)}
sub isos {__PACKAGE__->ext_isos(@_)}
#
# API
#
# Smart rearrangement of parameters to allow named parameter calling.
# See also CGI::Util
#
sub read_attributes {
my ($schema, @param) = @_;
unless ($schema && ref($schema) eq 'ARRAY') {
carp("No scheme specified");
return ();
}
my $first = $param[0];
my %params;
if (ref($first) eq 'HASH') {
%params = %$first;
} elsif (ref($first) eq 'ARRAY') {
%params = (@$first);
} elsif (!defined($first)) {
return ();
} else {
%params = @param
}
# Map parameters into positional indices
my %pos; # alias => name
my $i = 0;
foreach my $s (@$schema) {
my @ks = ref($s) eq 'ARRAY' ? @$s : ($s);
foreach my $k (@ks) {
$pos{lc($k)} = $i;
}
$i++;
}
my @result;
$#result = $#$schema; # Preextend
while (my ($k, $v) = each %params) {
my $key = lc($k);
$key =~ s/^\-//;
$result[$pos{$key}] = $v if exists $pos{$key};
}
return @result;
}
( run in 0.489 second using v1.01-cache-2.11-cpan-ceb78f64989 )