File Coverage

blib/lib/CTK.pm

Criterion	Covered	Total	%
statement	123	177	69.4
branch	31	88	35.2
condition	20	48	41.6
subroutine	25	39	64.1
pod	27	27	100.0
total	226	379	59.6

package CTK;
use strict;
use utf8;

=encoding utf-8

=head1 NAME

CTK - CTK ToolKit library (CTKlib)

=head1 VERSION

Version 2.08

=head1 NOTE

The 2.00+ versions of this library is not compatible with earlier versions

=head1 SYNOPSIS

    use CTK;

    my $ctk = CTK->new;
    my $ctk = CTK->new (
        project => 'MyApp',
        configfile  => '/path/to/conf/file.conf',
        logfile     => '/path/to/log/file.log',
    );

=head1 DESCRIPTION

CTKlib - is library that provides "extended-features" (utilities) for your robots written on Perl.
Most of the functions and methods this module written very simple language and easy to understand.
To work with CTKlib, you just need to start using it!

=head2 new

    my $ctk = CTK->new;
    my $ctk = CTK->new (
        project    => 'MyApp',
        configfile => '/path/to/conf/file.conf',
        logfile    => '/path/to/log/file.log',
    );

Main constructor. All the params are optional

=over 4

=item B

    configfile => '/etc/myapp/myapp.conf'

Path to the configuration file of the your project

Default: /etc//.conf

=item B

    datadir => '/path/to/your/data/dir'

Directory for application data storing

Default:  (current directory)

=item B

    debug => 1
    debug => 'on'
    debug => 'yes'

Debug mode

Default: 0

=item B

    ident => "test"

Ident string for logs and debugging

Default: ""

=item B

    log => 1
    log => 'on'
    log => 'yes'

Log mode. For debug and error methods only!!

Default: 0

=item B

    logdir => '/var/log/myapp'

Log directory of project

Default: /var/log/

=item B

    logfile => '/var/log/myapp/myapp.log'

Full path to the log file

Default: /var/log//.log

=item B

    options => {foo => 'bar'}

Command-line options, hash-ref structure. See L

Default: {}

=item B

    plugins => [qw/ test /]
    plugins => "test"

Array ref of plugin list or plugin name as scalar:

Default: []

=item B

    prefix => "myapp"

Prefix of the Your project

Default: lc()

=item B

    project => "MyApp"
    name => "MyApp"

Project name

Default: $FindBin::Script without file extension

=item B

    root => "/etc/myapp"

Root dir of project

Default: /etc/

=item B

    suffix => "devel"
    suffix => "alpha"
    suffix => "beta"
    suffix => ".dev"

Suffix of the your project. Can use in plugins

Default: ""

=item B

    tempdir => "/tmp/myapp"

Temp directory of project

Default: /tmp/

=item B

    tempfile => "/tmp/myapp/myapp.tmp"

Temp file of project

Default: /tmp//.tmp

=item B

    test => 1
    test => 'on'
    test => 'yes'

Test mode

Default: 0

=item B

    verbose => 1
    verbose => 'on'
    verbose => 'yes'

Verbose mode

Default: 0

=back

=head2 again

For internal use only (plugins). Please not call this method

=head2 configfile

    my $configfile = $ctk->configfile;
    $ctk->configfile("/path/to/config/file.conf");

Gets and sets configfile value

=head2 datadir

    my $datadir = $ctk->datadir;
    $ctk->datadir("/path/to/data/dir");

Gets and sets datadir value

=head2 debug

    $ctk->debug( "Message" );

Prints debug information on STDOUT if is set debug mode.
Also sends message to log if log mode is enabled

=head2 debugmode

    $ctk->debugmode;

Returns debug flag. 1 - on, 0 - off

=head2 error

    my $error = $ctk->error;

Returns error string if occurred any errors while creating the object

    $ctk->error("error text");

Sets new error message and returns it. Also prints message on STDERR if is set debug mode
and sends message to log if log mode is enabled

=head2 exedir

    my $exedir = $ctk->exedir;

Gets exedir value

=head2 load

    $ctk->load("My::Foo::Package");

Internal method for loading modules.

Returns loading status: 0 - was not loaded; 1 - was loaded

=head2 load_plugins

    my $summary_status = $self->load_plugins( @plugins );

Loads list of plugins and returns summary status

=head2 logdir

    my $logdir = $ctk->logdir;
    $ctk->logdir("/path/to/log/dir");

Gets and sets logdir value

=head2 logfile

    my $logfile = $ctk->logfile;
    $ctk->logfile("/path/to/log/file.log");

Gets and sets logfile value

=head2 logmode

    $ctk->logmode;

Returns log flag. 1 - on, 0 - off

=head2 origin

    my $args = $ctk->origin();

Returns hash-ref structure to all origin arguments

=head2 option

    my $value = $ctk->option("key");

Returns option value by key

    my $options = $ctk->option;

Returns hash-ref structure to all options

See L

=head2 project, prefix, suffix

    my $project_name = $ctk->projtct;
    my $prefix = $ctk->prefix;
    my $suffix = $ctk->suffix;

Returns project, prefix and suffix values

=head2 revision

    my $revision = $ctk->revision;

Returns SVN revision number. Please not use it for your projects

=head2 root

    my $my_root = $ctk->root; # /etc/

Gets my root dir value

=head2 silentmode

    $ctk->silentmode;

Returns the verbose flag in the opposite value. 0 - verbose, 1 - silent.

See L

=head2 status

    my $status = $ctk->status;

Returns boolean status of creating and using the object

    my $status = $ctk->status( 1 );

Sets new status and just returns it

=head2 tempfile

    my $tempfile = $ctk->tempfile;
    $ctk->tempfile("/path/to/temp/file.tmp");

Gets and sets tempfile value

=head2 tempdir

    my $tempdir = $ctk->tempdir;
    $ctk->tempdir("/path/to/temp/dir");

Gets and sets tempdir value

=head2 testmode

    $ctk->testmode;

Returns test flag. 1 - on, 0 - off

=head2 tms

    print $ctk->tms; # +0.0080 sec

Returns formatted timestamp

    print $ctk->tms(1); # 0.008000

Returns NOT formatted timestamp

=head2 verbosemode

    $ctk->verbosemode;

Returns verbose flag. 1 - on, 0 - off

See L

=head1 VARIABLES

    use CTK qw/ WIN NULL TONULL ERR2OUT PREFIX /;
    use CTK qw/ :constants /

=over 4

=item B

Returns string:

    2>&1

=item B

Returns NULL device path or name for Windows platforms

=item B<%PLUGIN_ALIAS_MAP>

This hash is using for sets aliases of plugins, e.g.:

    use CTK qw/ %PLUGIN_ALIAS_MAP /;
    $PLUGIN_ALIAS_MAP{myplugin} = "My::Custom::Plugin::Module";

=item B

Return default prefix: ctk

=item B

Returns string:

    >/dev/null 2>&1

=item B

Returns 1 if Windows platform

=back

=head1 TAGS

=over 4

=item B<:constants>

Will be exported following variables:

    WIN, NULL, TONULL, ERR2OUT, PREFIX

=item B<:variables>

Will be exported following variables:

    %PLUGIN_ALIAS_MAP

=back

=head1 HISTORY

=over 4

=item B<1.00 / 18.06.2012>

Init version

=item B<2.00 Mon Apr 29 10:36:06 MSK 2019>

New edition of the library

=back

See C file

=head1 DEPENDENCIES

L,
L, L,
L,
L,
L,
L,
L,
L,
L,
L,
L,
L,
L, L

=head1 TO DO

See C file

=head1 BUGS

* none noted

=head1 SEE ALSO

C

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L [e-mail]

=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 file and L

=cut

use vars qw/ $VERSION %PLUGIN_ALIAS_MAP %EXPORT_TAGS @EXPORT_OK /;
$VERSION = '2.08';

use base qw/Exporter/;

use Carp;
use Time::HiRes qw(gettimeofday);
use FindBin qw($RealBin $Script);
use Cwd qw/getcwd/;
use File::Spec ();
use CTK::Util qw/ sysconfdir syslogdir isTrueFlag /;

my @exp_constants = qw(
        WIN NULL TONULL ERR2OUT PREFIX
    );

my @exp_variables = qw(
        %PLUGIN_ALIAS_MAP
    );

@EXPORT_OK = (
    @exp_constants,
    @exp_variables,
);

%EXPORT_TAGS = (
        constants => [@exp_constants],
        variables => [@exp_variables],
    );

%PLUGIN_ALIAS_MAP = (
        cli             => "CTK::Plugin::CLI",
        configuration   => "CTK::Plugin::Config",
        files           => "CTK::Plugin::File",
        arc             => "CTK::Plugin::Archive",
        compress        => "CTK::Plugin::Archive",
        ftp             => "CTK::Plugin::FTP",
        sftp            => "CTK::Plugin::SFTP",
    );

use constant {
    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',
    PREFIX    => "ctk",
    PLUGIN_FORMAT => "CTK::Plugin::%s",
    ALOWED_MODES => [qw/debug log test verbose/],
};

sub new {
    my $class = shift;
    my %args = @_;
    my $options = $args{options} // {};
    croak("Can't use \"non hash\" struct for the \"options\" param") unless ref($options) eq "HASH";
    my $project = $args{project} // $args{name} // ($Script =~ /^(.+?)\.(pl|t|pm|cgi)$/ ? $1 : $Script);
    my $prefix = $args{prefix} // _prj2pfx($project) // PREFIX;
    my $plugins = $args{plugins} // [];
    $plugins = [$plugins] unless ref($plugins);
    croak("Can't use \"non array\" for the \"plugins\" param") unless ref($plugins) eq "ARRAY";

    # Create CTK object
    my $self = bless {
        status  => 0,
        error   => "",

        # General
        invocant    => scalar(caller(0)),
        origin      => {%args},
        created     => time(),
        hitime      => gettimeofday() * 1,
        revision    => q/$Revision: 310 $/,
        options     => $options,
        plugins     => {},

        # Modes (defaults)
        debugmode   => 0,
        logmode     => 0,
        testmode    => 0,
        verbosemode => 0,

        # Information
        ident       => $args{ident}, # For logs and debugging
        script      => $Script,
        project     => $project,
        prefix      => $prefix,
        suffix      => $args{suffix} // "",

        # Dirs
        exedir      => $RealBin, # Script dir
        datadir     => $args{datadir} // getcwd(), # Data dir of project. Defaut: current dir
        tempdir     => $args{tempdir}, # Temp dir of project. Default: /tmp/prefix
        logdir      => $args{logdir}, # Log dir of project. Default: /var/log/prefix
        root        => $args{root}, # Root dir of project. Default: /etc/prefix

        # Files
        tempfile    => $args{tempfile}, # Temp file of project. Default: /tmp/prefix/prefix.tmp
        logfile     => $args{logfile}, # Log file of project. Default: /var/log/prefix/prefix.log
        configfile  => $args{configfile}, # Config file of project. Default: /etc/prefix/prefix.conf

    }, $class;

    # Modes
    foreach my $mode ( @{(ALOWED_MODES)}) {
        $self->{$mode."mode"} = 1 if isTrueFlag($args{$mode});
    }

    # Root dir
    my $root = $self->{root};
    unless (defined($root) && length($root)) {
        $self->{root} = File::Spec->catdir(sysconfdir(), $prefix);
    }

    # Config file
    my $configfile = $self->{configfile};
    unless (defined($configfile) && length($configfile)) {
        $self->{configfile} = File::Spec->catfile(sysconfdir(), $prefix, sprintf("%s.conf", $prefix));
    }

    # Temp dir
    my $temp = $self->{tempdir};
    unless (defined($temp) && length($temp)) {
        $self->{tempdir} = File::Spec->catdir(File::Spec->tmpdir(), $prefix);
    }

    # Temp file
    my $tempfile = $self->{tempfile};
    unless (defined($tempfile) && length($tempfile)) {
        $self->{tempfile} = File::Spec->catfile(File::Spec->tmpdir(), $prefix, sprintf("%s.tmp", $prefix));
    }

    # Log dir
    my $ldir = $self->{logdir};
    unless (defined($ldir) && length($ldir)) {
        $self->{logdir} = File::Spec->catdir(syslogdir(), $prefix);
    }

    # Log file
    my $logfile = $self->{logfile};
    unless (defined($logfile) && length($logfile)) {
        $self->{logfile} = File::Spec->catfile(syslogdir(), $prefix, sprintf("%s.log", $prefix));
    }

    # Loading plugins and set status!
    $self->{status} = $self->load_plugins(@$plugins);

    return $self->again;
}
sub again {
    my $self = shift;
    return $self;
}

########################
## Base methods
########################
sub debug {
    my $self = shift;
    my @dbg = @_;
    return unless @dbg;
    my $ident = $self->{ident} // "";
    my $msg = join("", @dbg);
    return unless length($msg);
    $self->log_debug("%s", $msg) if $self->logmode && $self->can("log_debug"); # To log
    if ($self->debugmode) { # To STDOUT
        unshift(@dbg, sprintf("%s ", $ident)) if length($ident);
        print STDOUT @dbg, "\n";
    }
    return 1;
}
sub tms {
    my $self = shift;
    my $no_format = shift;
    my $v = gettimeofday()*1 - $self->{hitime}*1;
    return $v if $no_format;
    return sprintf("%+.*f sec", 4, $v);
}
sub error {
    my $self = shift;
    my @err = @_;
    if (@err) {
        $self->{error} = join("", @err);
        my $ident = $self->{ident} // "";
        if (length($self->{error})) {
            $self->log_error("%s", $self->{error}) if $self->logmode && $self->can("log_error"); # To log
            if ($self->debugmode) { # To STDERR
                unshift(@err, sprintf("%s ", $ident)) if length($ident);
                printf STDERR "%s\n", join("", @err);
            }
        }
    }
    return $self->{error};
}
sub status {
    my $self = shift;
    my $s = shift;
    $self->{status} = $s if defined $s;
    return $self->{status} ? 1 : 0;
}

# Modes
sub testmode { shift->{testmode} }
sub debugmode { shift->{debugmode} }
sub logmode { shift->{logmode} }
sub verbosemode { shift->{verbosemode} }
sub silentmode { !shift->{verbosemode} }

# Information
sub revision { # lasy
    my $self = shift;
    my $rev = $self->{revision};
    return $rev =~ /(\d+\.?\d*)/ ? $1 : '0';
}
sub option {
    my $self = shift;
    my $key  = shift;
    my $opts = $self->{options};
    return undef unless $opts;
    return $opts unless defined $key;
    return $opts->{$key};
}
sub project { shift->{project} }
sub prefix { shift->{prefix} }
sub suffix { shift->{suffix} }
sub origin { shift->{origin} }

# Dirs
sub exedir { shift->{exedir} }
sub root { shift->{root} }
sub datadir {
    my $self = shift;
    my $dir = shift;
    $self->{datadir} = $dir if defined $dir;
    return $self->{datadir};
}
sub logdir {
    my $self = shift;
    my $dir = shift;
    $self->{logdir} = $dir if defined $dir;
    return $self->{logdir};
}
sub tempdir {
    my $self = shift;
    my $dir = shift;
    $self->{tempdir} = $dir if defined $dir;
    return $self->{tempdir};
}

# Files
sub tempfile {
    my $self = shift;
    my $file = shift;
    $self->{tempfile} = $file if defined $file;
    return $self->{tempfile};
}
sub logfile {
    my $self = shift;
    my $file = shift;
    $self->{logfile} = $file if defined $file;
    return $self->{logfile};
}
sub configfile {
    my $self = shift;
    my $file = shift;
    $self->{configfile} = $file if defined $file;
    return $self->{configfile};
}

# Loading plugin's module
sub load_plugins {
    my $self = shift;
    my @plugins = @_;
    my $in = $self->{plugins};
    my $ret = 1;
    my %seen = ();
    for (@plugins) {$seen{lc($_)} = 1}
    foreach my $plugin (keys %seen) {
        next if $in->{$plugin}->{inited};
        my $module = exists($PLUGIN_ALIAS_MAP{$plugin})
            ? $PLUGIN_ALIAS_MAP{$plugin}
            : sprintf(PLUGIN_FORMAT, ucfirst($plugin));
        my $loading_status = $self->load($module);
        my $inited = 0;
        if ($loading_status) {
            if (my $init = $module->can("init")) {
                $inited = $init->($self);
            }
        } else {
            $ret = 0;
        }
        $in->{$plugin} = {
            module => $module,
            loaded => $loading_status,
            inited => $inited,
        };
    };
    return $ret;
}
sub load {
    my $self = shift;
    my $module = shift;
    my $file = sprintf("%s.pm", join('/', split('::', $module)));
    return 1 if exists $INC{$file};
    eval { require $file; };
    if ($@) {
        $self->error("Failed to load $file: $@");
        return 0;
    }
    return 1;
}

sub _prj2pfx {
    my $prj = shift;
    return unless defined($prj);
    $prj =~ s/[^a-z0-9_\-.]/_/ig;
    $prj =~ s/_{2,}/_/g;
    return unless length($prj);
    return lc($prj);
}

1;

__END__