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


line stmt bran cond sub pod time code
1             package CTK;
2 12     12   599845 use strict;
  12         105  
  12         316  
3 12     12   5304 use utf8;
  12         130  
  12         51  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK - CTK ToolKit library (CTKlib)
10              
11             =head1 VERSION
12              
13             Version 2.09
14              
15             =head1 NOTE
16              
17             The 2.00+ versions of this library is not compatible with earlier versions
18              
19             =head1 SYNOPSIS
20              
21             use CTK;
22              
23             my $ctk = CTK->new;
24             my $ctk = CTK->new (
25             project => 'MyApp',
26             configfile => '/path/to/conf/file.conf',
27             logfile => '/path/to/log/file.log',
28             );
29              
30             =head1 DESCRIPTION
31              
32             CTKlib - is library that provides "extended-features" (utilities) for your robots written on Perl.
33             Most of the functions and methods this module written very simple language and easy to understand.
34             To work with CTKlib, you just need to start using it!
35              
36             =head2 new
37              
38             my $ctk = CTK->new;
39             my $ctk = CTK->new (
40             project => 'MyApp',
41             configfile => '/path/to/conf/file.conf',
42             logfile => '/path/to/log/file.log',
43             );
44              
45             Main constructor. All the params are optional
46              
47             =over 4
48              
49             =item B
50              
51             configfile => '/etc/myapp/myapp.conf'
52              
53             Path to the configuration file of the your project
54              
55             Default: /etc//.conf
56              
57             =item B
58              
59             datadir => '/path/to/your/data/dir'
60              
61             Directory for application data storing
62              
63             Default: (current directory)
64              
65             =item B
66              
67             debug => 1
68             debug => 'on'
69             debug => 'yes'
70              
71             Debug mode
72              
73             Default: 0
74              
75             =item B
76              
77             ident => "test"
78              
79             Ident string for logs and debugging
80              
81             Default: ""
82              
83             =item B
84              
85             log => 1
86             log => 'on'
87             log => 'yes'
88              
89             Log mode. For debug and error methods only!!
90              
91             Default: 0
92              
93             =item B
94              
95             logdir => '/var/log/myapp'
96              
97             Log directory of project
98              
99             Default: /var/log/
100              
101             =item B
102              
103             logfile => '/var/log/myapp/myapp.log'
104              
105             Full path to the log file
106              
107             Default: /var/log//.log
108              
109             =item B
110              
111             options => {foo => 'bar'}
112              
113             Command-line options, hash-ref structure. See L
114              
115             Default: {}
116              
117             =item B
118              
119             plugins => [qw/ test /]
120             plugins => "test"
121              
122             Array ref of plugin list or plugin name as scalar:
123              
124             Default: []
125              
126             =item B
127              
128             prefix => "myapp"
129              
130             Prefix of the Your project
131              
132             Default: lc()
133              
134             =item B
135              
136             project => "MyApp"
137             name => "MyApp"
138              
139             Project name
140              
141             Default: $FindBin::Script without file extension
142              
143             =item B
144              
145             root => "/etc/myapp"
146              
147             Root dir of project
148              
149             Default: /etc/
150              
151             =item B
152              
153             suffix => "devel"
154             suffix => "alpha"
155             suffix => "beta"
156             suffix => ".dev"
157              
158             Suffix of the your project. Can use in plugins
159              
160             Default: ""
161              
162             =item B
163              
164             tempdir => "/tmp/myapp"
165              
166             Temp directory of project
167              
168             Default: /tmp/
169              
170             =item B
171              
172             tempfile => "/tmp/myapp/myapp.tmp"
173              
174             Temp file of project
175              
176             Default: /tmp//.tmp
177              
178             =item B
179              
180             test => 1
181             test => 'on'
182             test => 'yes'
183              
184             Test mode
185              
186             Default: 0
187              
188             =item B
189              
190             verbose => 1
191             verbose => 'on'
192             verbose => 'yes'
193              
194             Verbose mode
195              
196             Default: 0
197              
198             =back
199              
200             =head2 again
201              
202             For internal use only (plugins). Please not call this method
203              
204             =head2 configfile
205              
206             my $configfile = $ctk->configfile;
207             $ctk->configfile("/path/to/config/file.conf");
208              
209             Gets and sets configfile value
210              
211             =head2 datadir
212              
213             my $datadir = $ctk->datadir;
214             $ctk->datadir("/path/to/data/dir");
215              
216             Gets and sets datadir value
217              
218             =head2 debug
219              
220             $ctk->debug( "Message" );
221              
222             Prints debug information on STDOUT if is set debug mode.
223             Also sends message to log if log mode is enabled
224              
225             =head2 debugmode
226              
227             $ctk->debugmode;
228              
229             Returns debug flag. 1 - on, 0 - off
230              
231             =head2 error
232              
233             my $error = $ctk->error;
234              
235             Returns error string if occurred any errors while creating the object
236              
237             $ctk->error("error text");
238              
239             Sets new error message and returns it. Also prints message on STDERR if is set debug mode
240             and sends message to log if log mode is enabled
241              
242             =head2 exedir
243              
244             my $exedir = $ctk->exedir;
245              
246             Gets exedir value
247              
248             =head2 load
249              
250             $ctk->load("My::Foo::Package");
251              
252             Internal method for loading modules.
253              
254             Returns loading status: 0 - was not loaded; 1 - was loaded
255              
256             =head2 load_plugins
257              
258             my $summary_status = $self->load_plugins( @plugins );
259              
260             Loads list of plugins and returns summary status
261              
262             =head2 logdir
263              
264             my $logdir = $ctk->logdir;
265             $ctk->logdir("/path/to/log/dir");
266              
267             Gets and sets logdir value
268              
269             =head2 logfile
270              
271             my $logfile = $ctk->logfile;
272             $ctk->logfile("/path/to/log/file.log");
273              
274             Gets and sets logfile value
275              
276             =head2 logmode
277              
278             $ctk->logmode;
279              
280             Returns log flag. 1 - on, 0 - off
281              
282             =head2 origin
283              
284             my $args = $ctk->origin();
285              
286             Returns hash-ref structure to all origin arguments
287              
288             =head2 option
289              
290             my $value = $ctk->option("key");
291              
292             Returns option value by key
293              
294             my $options = $ctk->option;
295              
296             Returns hash-ref structure to all options
297              
298             See L
299              
300             =head2 project, prefix, suffix
301              
302             my $project_name = $ctk->projtct;
303             my $prefix = $ctk->prefix;
304             my $suffix = $ctk->suffix;
305              
306             Returns project, prefix and suffix values
307              
308             =head2 revision
309              
310             my $revision = $ctk->revision;
311              
312             Returns SVN revision number. Please not use it for your projects
313              
314             =head2 root
315              
316             my $my_root = $ctk->root; # /etc/
317              
318             Gets my root dir value
319              
320             =head2 silentmode
321              
322             $ctk->silentmode;
323              
324             Returns the verbose flag in the opposite value. 0 - verbose, 1 - silent.
325              
326             See L
327              
328             =head2 status
329              
330             my $status = $ctk->status;
331              
332             Returns boolean status of creating and using the object
333              
334             my $status = $ctk->status( 1 );
335              
336             Sets new status and just returns it
337              
338             =head2 tempfile
339              
340             my $tempfile = $ctk->tempfile;
341             $ctk->tempfile("/path/to/temp/file.tmp");
342              
343             Gets and sets tempfile value
344              
345             =head2 tempdir
346              
347             my $tempdir = $ctk->tempdir;
348             $ctk->tempdir("/path/to/temp/dir");
349              
350             Gets and sets tempdir value
351              
352             =head2 testmode
353              
354             $ctk->testmode;
355              
356             Returns test flag. 1 - on, 0 - off
357              
358             =head2 tms
359              
360             print $ctk->tms; # +0.0080 sec
361              
362             Returns formatted timestamp
363              
364             print $ctk->tms(1); # 0.008000
365              
366             Returns NOT formatted timestamp
367              
368             =head2 verbosemode
369              
370             $ctk->verbosemode;
371              
372             Returns verbose flag. 1 - on, 0 - off
373              
374             See L
375              
376             =head1 VARIABLES
377              
378             use CTK qw/ WIN NULL TONULL ERR2OUT PREFIX /;
379             use CTK qw/ :constants /
380              
381             =over 4
382              
383             =item B
384              
385             Returns string:
386              
387             2>&1
388              
389             =item B
390              
391             Returns NULL device path or name for Windows platforms
392              
393             =item B<%PLUGIN_ALIAS_MAP>
394              
395             This hash is using for sets aliases of plugins, e.g.:
396              
397             use CTK qw/ %PLUGIN_ALIAS_MAP /;
398             $PLUGIN_ALIAS_MAP{myplugin} = "My::Custom::Plugin::Module";
399              
400             =item B
401              
402             Return default prefix: ctk
403              
404             =item B
405              
406             Returns string:
407              
408             >/dev/null 2>&1
409              
410             =item B
411              
412             Returns 1 if Windows platform
413              
414             =back
415              
416             =head1 TAGS
417              
418             =over 4
419              
420             =item B<:constants>
421              
422             Will be exported following variables:
423              
424             WIN, NULL, TONULL, ERR2OUT, PREFIX
425              
426             =item B<:variables>
427              
428             Will be exported following variables:
429              
430             %PLUGIN_ALIAS_MAP
431              
432             =back
433              
434             =head1 HISTORY
435              
436             =over 4
437              
438             =item B<1.00 / 18.06.2012>
439              
440             Init version
441              
442             =item B<2.00 Mon Apr 29 10:36:06 MSK 2019>
443              
444             New edition of the library
445              
446             =back
447              
448             See C file
449              
450             =head1 DEPENDENCIES
451              
452             L,
453             L, L,
454             L,
455             L,
456             L,
457             L,
458             L,
459             L,
460             L,
461             L,
462             L,
463             L,
464             L, L
465              
466             =head1 TO DO
467              
468             See C file
469              
470             =head1 BUGS
471              
472             * none noted
473              
474             =head1 SEE ALSO
475              
476             C
477              
478             =head1 AUTHOR
479              
480             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
481              
482             =head1 COPYRIGHT
483              
484             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
485              
486             =head1 LICENSE
487              
488             This program is free software; you can redistribute it and/or
489             modify it under the same terms as Perl itself.
490              
491             See C file and L
492              
493             =cut
494              
495 12     12   1199 use vars qw/ $VERSION %PLUGIN_ALIAS_MAP %EXPORT_TAGS @EXPORT_OK /;
  12         25  
  12         839  
496             $VERSION = '2.09';
497              
498 12     12   61 use base qw/Exporter/;
  12         20  
  12         1501  
499              
500 12     12   67 use Carp;
  12         20  
  12         687  
501 12     12   6300 use Time::HiRes qw(gettimeofday);
  12         15539  
  12         47  
502 12     12   7078 use FindBin qw($RealBin $Script);
  12         11805  
  12         1181  
503 12     12   76 use Cwd qw/getcwd/;
  12         21  
  12         354  
504 12     12   58 use File::Spec ();
  12         19  
  12         182  
505 12     12   6540 use CTK::Util qw/ sysconfdir syslogdir isTrueFlag /;
  12         38  
  12         7956  
506              
507             my @exp_constants = qw(
508             WIN NULL TONULL ERR2OUT PREFIX
509             );
510              
511             my @exp_variables = qw(
512             %PLUGIN_ALIAS_MAP
513             );
514              
515             @EXPORT_OK = (
516             @exp_constants,
517             @exp_variables,
518             );
519              
520             %EXPORT_TAGS = (
521             constants => [@exp_constants],
522             variables => [@exp_variables],
523             );
524              
525             %PLUGIN_ALIAS_MAP = (
526             cli => "CTK::Plugin::CLI",
527             configuration => "CTK::Plugin::Config",
528             files => "CTK::Plugin::File",
529             arc => "CTK::Plugin::Archive",
530             compress => "CTK::Plugin::Archive",
531             ftp => "CTK::Plugin::FTP",
532             sftp => "CTK::Plugin::SFTP",
533             );
534              
535             use constant {
536 12 50       22403 WIN => $^O =~ /mswin/i ? 1 : 0,
    50          
    50          
537             NULL => $^O =~ /mswin/i ? 'NUL' : '/dev/null',
538             TONULL => $^O =~ /mswin/i ? '>NUL 2>&1' : '>/dev/null 2>&1',
539             ERR2OUT => '2>&1',
540             PREFIX => "ctk",
541             PLUGIN_FORMAT => "CTK::Plugin::%s",
542             ALOWED_MODES => [qw/debug log test verbose/],
543 12     12   112 };
  12         19  
544              
545             sub new {
546 5     5 1 591 my $class = shift;
547 5         34 my %args = @_;
548 5   50     38 my $options = $args{options} // {};
549 5 50       29 croak("Can't use \"non hash\" struct for the \"options\" param") unless ref($options) eq "HASH";
550 5 50 66     78 my $project = $args{project} // $args{name} // ($Script =~ /^(.+?)\.(pl|t|pm|cgi)$/ ? $1 : $Script);
      66        
551 5   66     28 my $prefix = $args{prefix} // _prj2pfx($project) // PREFIX;
      50        
552 5   100     20 my $plugins = $args{plugins} // [];
553 5 50       18 $plugins = [$plugins] unless ref($plugins);
554 5 50       16 croak("Can't use \"non array\" for the \"plugins\" param") unless ref($plugins) eq "ARRAY";
555              
556             # Create CTK object
557             my $self = bless {
558             status => 0,
559             error => "",
560              
561             # General
562             invocant => scalar(caller(0)),
563             origin => {%args},
564             created => time(),
565             hitime => gettimeofday() * 1,
566             revision => q/$Revision: 310 $/,
567             options => $options,
568             plugins => {},
569              
570             # Modes (defaults)
571             debugmode => 0,
572             logmode => 0,
573             testmode => 0,
574             verbosemode => 0,
575              
576             # Information
577             ident => $args{ident}, # For logs and debugging
578             script => $Script,
579             project => $project,
580             prefix => $prefix,
581             suffix => $args{suffix} // "",
582              
583             # Dirs
584             exedir => $RealBin, # Script dir
585             datadir => $args{datadir} // getcwd(), # Data dir of project. Defaut: current dir
586             tempdir => $args{tempdir}, # Temp dir of project. Default: /tmp/prefix
587             logdir => $args{logdir}, # Log dir of project. Default: /var/log/prefix
588             root => $args{root}, # Root dir of project. Default: /etc/prefix
589              
590             # Files
591             tempfile => $args{tempfile}, # Temp file of project. Default: /tmp/prefix/prefix.tmp
592             logfile => $args{logfile}, # Log file of project. Default: /var/log/prefix/prefix.log
593             configfile => $args{configfile}, # Config file of project. Default: /etc/prefix/prefix.conf
594              
595 5   50     251 }, $class;
      33        
596              
597             # Modes
598 5         18 foreach my $mode ( @{(ALOWED_MODES)}) {
  5         87  
599 20 50       77 $self->{$mode."mode"} = 1 if isTrueFlag($args{$mode});
600             }
601              
602             # Root dir
603 5         41 my $root = $self->{root};
604 5 100 66     24 unless (defined($root) && length($root)) {
605 4         17 $self->{root} = File::Spec->catdir(sysconfdir(), $prefix);
606             }
607              
608             # Config file
609 5         11 my $configfile = $self->{configfile};
610 5 100 66     24 unless (defined($configfile) && length($configfile)) {
611 4         12 $self->{configfile} = File::Spec->catfile(sysconfdir(), $prefix, sprintf("%s.conf", $prefix));
612             }
613              
614             # Temp dir
615 5         16 my $temp = $self->{tempdir};
616 5 50 33     30 unless (defined($temp) && length($temp)) {
617 5         432 $self->{tempdir} = File::Spec->catdir(File::Spec->tmpdir(), $prefix);
618             }
619              
620             # Temp file
621 5         21 my $tempfile = $self->{tempfile};
622 5 50 33     25 unless (defined($tempfile) && length($tempfile)) {
623 5         79 $self->{tempfile} = File::Spec->catfile(File::Spec->tmpdir(), $prefix, sprintf("%s.tmp", $prefix));
624             }
625              
626             # Log dir
627 5         37 my $ldir = $self->{logdir};
628 5 50 33     22 unless (defined($ldir) && length($ldir)) {
629 5         24 $self->{logdir} = File::Spec->catdir(syslogdir(), $prefix);
630             }
631              
632             # Log file
633 5         15 my $logfile = $self->{logfile};
634 5 50 33     21 unless (defined($logfile) && length($logfile)) {
635 5         15 $self->{logfile} = File::Spec->catfile(syslogdir(), $prefix, sprintf("%s.log", $prefix));
636             }
637              
638             # Loading plugins and set status!
639 5         43 $self->{status} = $self->load_plugins(@$plugins);
640              
641 5         25 return $self->again;
642             }
643             sub again {
644 3     3 1 13 my $self = shift;
645 3         14 return $self;
646             }
647              
648             ########################
649             ## Base methods
650             ########################
651             sub debug {
652 0     0 1 0 my $self = shift;
653 0         0 my @dbg = @_;
654 0 0       0 return unless @dbg;
655 0   0     0 my $ident = $self->{ident} // "";
656 0         0 my $msg = join("", @dbg);
657 0 0       0 return unless length($msg);
658 0 0 0     0 $self->log_debug("%s", $msg) if $self->logmode && $self->can("log_debug"); # To log
659 0 0       0 if ($self->debugmode) { # To STDOUT
660 0 0       0 unshift(@dbg, sprintf("%s ", $ident)) if length($ident);
661 0         0 print STDOUT @dbg, "\n";
662             }
663 0         0 return 1;
664             }
665             sub tms {
666 2     2 1 5 my $self = shift;
667 2         3 my $no_format = shift;
668 2         16 my $v = gettimeofday()*1 - $self->{hitime}*1;
669 2 50       8 return $v if $no_format;
670 2         39 return sprintf("%+.*f sec", 4, $v);
671             }
672             sub error {
673 1     1 1 2 my $self = shift;
674 1         2 my @err = @_;
675 1 50       2 if (@err) {
676 0         0 $self->{error} = join("", @err);
677 0   0     0 my $ident = $self->{ident} // "";
678 0 0       0 if (length($self->{error})) {
679 0 0 0     0 $self->log_error("%s", $self->{error}) if $self->logmode && $self->can("log_error"); # To log
680 0 0       0 if ($self->debugmode) { # To STDERR
681 0 0       0 unshift(@err, sprintf("%s ", $ident)) if length($ident);
682 0         0 printf STDERR "%s\n", join("", @err);
683             }
684             }
685             }
686 1         3 return $self->{error};
687             }
688             sub status {
689 6     6 1 452 my $self = shift;
690 6         8 my $s = shift;
691 6 50       17 $self->{status} = $s if defined $s;
692 6 50       72 return $self->{status} ? 1 : 0;
693             }
694              
695             # Modes
696 0     0 1 0 sub testmode { shift->{testmode} }
697 1     1 1 11 sub debugmode { shift->{debugmode} }
698 0     0 1 0 sub logmode { shift->{logmode} }
699 0     0 1 0 sub verbosemode { shift->{verbosemode} }
700 0     0 1 0 sub silentmode { !shift->{verbosemode} }
701              
702             # Information
703             sub revision { # lasy
704 1     1 1 1 my $self = shift;
705 1         2 my $rev = $self->{revision};
706 1 50       9 return $rev =~ /(\d+\.?\d*)/ ? $1 : '0';
707             }
708             sub option {
709 0     0 1 0 my $self = shift;
710 0         0 my $key = shift;
711 0         0 my $opts = $self->{options};
712 0 0       0 return undef unless $opts;
713 0 0       0 return $opts unless defined $key;
714 0         0 return $opts->{$key};
715             }
716 1     1 1 6 sub project { shift->{project} }
717 0     0 1 0 sub prefix { shift->{prefix} }
718 0     0 1 0 sub suffix { shift->{suffix} }
719 4     4 1 12 sub origin { shift->{origin} }
720              
721             # Dirs
722 0     0 1 0 sub exedir { shift->{exedir} }
723 2     2 1 26 sub root { shift->{root} }
724             sub datadir {
725 0     0 1 0 my $self = shift;
726 0         0 my $dir = shift;
727 0 0       0 $self->{datadir} = $dir if defined $dir;
728 0         0 return $self->{datadir};
729             }
730             sub logdir {
731 0     0 1 0 my $self = shift;
732 0         0 my $dir = shift;
733 0 0       0 $self->{logdir} = $dir if defined $dir;
734 0         0 return $self->{logdir};
735             }
736             sub tempdir {
737 0     0 1 0 my $self = shift;
738 0         0 my $dir = shift;
739 0 0       0 $self->{tempdir} = $dir if defined $dir;
740 0         0 return $self->{tempdir};
741             }
742              
743             # Files
744             sub tempfile {
745 0     0 1 0 my $self = shift;
746 0         0 my $file = shift;
747 0 0       0 $self->{tempfile} = $file if defined $file;
748 0         0 return $self->{tempfile};
749             }
750             sub logfile {
751 0     0 1 0 my $self = shift;
752 0         0 my $file = shift;
753 0 0       0 $self->{logfile} = $file if defined $file;
754 0         0 return $self->{logfile};
755             }
756             sub configfile {
757 2     2 1 5 my $self = shift;
758 2         2 my $file = shift;
759 2 50       9 $self->{configfile} = $file if defined $file;
760 2         12 return $self->{configfile};
761             }
762              
763             # Loading plugin's module
764             sub load_plugins {
765 7     7 1 16 my $self = shift;
766 7         16 my @plugins = @_;
767 7         21 my $in = $self->{plugins};
768 7         14 my $ret = 1;
769 7         13 my %seen = ();
770 7         13 for (@plugins) {$seen{lc($_)} = 1}
  8         22  
771 7         20 foreach my $plugin (keys %seen) {
772 8 50       32 next if $in->{$plugin}->{inited};
773             my $module = exists($PLUGIN_ALIAS_MAP{$plugin})
774 8 100       44 ? $PLUGIN_ALIAS_MAP{$plugin}
775             : sprintf(PLUGIN_FORMAT, ucfirst($plugin));
776 8         60 my $loading_status = $self->load($module);
777 8         13 my $inited = 0;
778 8 50       26 if ($loading_status) {
779 8 50       87 if (my $init = $module->can("init")) {
780 8         23 $inited = $init->($self);
781             }
782             } else {
783 0         0 $ret = 0;
784             }
785 8         58 $in->{$plugin} = {
786             module => $module,
787             loaded => $loading_status,
788             inited => $inited,
789             };
790             };
791 7         32 return $ret;
792             }
793             sub load {
794 8     8 1 14 my $self = shift;
795 8         13 my $module = shift;
796 8         53 my $file = sprintf("%s.pm", join('/', split('::', $module)));
797 8 50       30 return 1 if exists $INC{$file};
798 8         16 eval { require $file; };
  8         3656  
799 8 50       37 if ($@) {
800 0         0 $self->error("Failed to load $file: $@");
801 0         0 return 0;
802             }
803 8         27 return 1;
804             }
805              
806             sub _prj2pfx {
807 4     4   6 my $prj = shift;
808 4 50       15 return unless defined($prj);
809 4         12 $prj =~ s/[^a-z0-9_\-.]/_/ig;
810 4         8 $prj =~ s/_{2,}/_/g;
811 4 50       13 return unless length($prj);
812 4         23 return lc($prj);
813             }
814              
815             1;
816              
817             __END__