File Coverage

blib/lib/CTK/Helper.pm
Criterion Covered Total %
statement 42 48 87.5
branch n/a
condition n/a
subroutine 14 17 82.3
pod 3 3 100.0
total 59 68 86.7


line stmt bran cond sub pod time code
1             package CTK::Helper;
2 1     1   60558 use strict;
  1         11  
  1         28  
3 1     1   543 use utf8;
  1         13  
  1         5  
4              
5             =encoding utf8
6              
7             =head1 NAME
8              
9             CTK::Helper - Helper for building CTK scripts. CLI user interface
10              
11             =head1 VIRSION
12              
13             Version 2.71
14              
15             =head1 SYNOPSIS
16              
17             none
18              
19             =head1 DESCRIPTION
20              
21             Helper for building CTK scripts
22              
23             No public subroutines
24              
25             =head2 nope, skip, yep
26              
27             Internal use only!
28              
29             See C
30              
31             =head1 HISTORY
32              
33             See C file
34              
35             =head1 TO DO
36              
37             See C file
38              
39             =head1 BUGS
40              
41             Coming soon
42              
43             =head1 SEE ALSO
44              
45             L
46              
47             =head1 AUTHOR
48              
49             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
50              
51             =head1 COPYRIGHT
52              
53             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
54              
55             =head1 LICENSE
56              
57             This program is free software; you can redistribute it and/or
58             modify it under the same terms as Perl itself.
59              
60             See C file and L
61              
62             =cut
63              
64 1     1   40 use vars qw/$VERSION/;
  1         1  
  1         49  
65             $VERSION = '2.71';
66              
67 1     1   5 use feature qw/say/;
  1         2  
  1         106  
68              
69 1     1   6 use base qw/ CTK::App /;
  1         1  
  1         407  
70              
71 1     1   7 use CTK;
  1         2  
  1         35  
72 1     1   5 use CTK::Util;
  1         19  
  1         44  
73 1     1   430 use CTK::Skel;
  1         2  
  1         38  
74 1     1   6 use Term::ANSIColor qw/colored/;
  1         2  
  1         50  
75 1     1   6 use File::Spec;
  1         1  
  1         22  
76 1     1   3 use Cwd qw/getcwd/;
  1         2  
  1         32  
77 1     1   547 use Text::SimpleTable;
  1         2278  
  1         38  
78 1     1   516 use File::Copy::Recursive qw(dircopy dirmove);
  1         6026  
  1         130  
79              
80             use constant {
81 1         1531 PROJECT_NAME => "Foo",
82             PROJECT_TYPE_DEFAULT => "regular",
83             PROJECT_TYPES => {
84             regular => [qw/common extra regular/],
85             module => [qw/common module/],
86             tiny => [qw/tiny/],
87             daemon => [qw/common extra daemon/],
88             },
89             PROJECT_SKELS => {
90             common => "CTK::Skel::Common",
91             regular => "CTK::Skel::Regular",
92             module => "CTK::Skel::Module",
93             tiny => "CTK::Skel::Tiny",
94             daemon => "CTK::Skel::Daemon",
95             extra => "CTK::Skel::Extra",
96             },
97             PROJECT_VARS => [qw/
98             CTK_VERSION
99             PROJECT_NAME
100             PROJECT_NAMEL
101             PROJECT_TYPE
102             GMT
103             /],
104 1     1   10 };
  1         1  
105              
106             __PACKAGE__->register_handler(
107             handler => "usage",
108             description => "Usage",
109             code => sub {
110             ### CODE:
111             my ($self, $meta, @params) = @_;
112             say(<
113             Usage:
114             ctklib [-dv] [-t regular|tiny|module|daemon] [-D /project/dir] create [PROJECTNAME]
115             ctklib create
116             ctklib create
117             ctklib test
118             ctklib -H
119             ctklib -V
120             USAGE
121             return 0;
122             });
123              
124             __PACKAGE__->register_handler(
125             handler => "version",
126             description => "CTK Version",
127             code => sub {
128             ### CODE:
129             my ($self, $meta, @params) = @_;
130             say sprintf("CTKlib/%s", CTK->VERSION);
131             return 1;
132             });
133              
134             __PACKAGE__->register_handler(
135             handler => "test",
136             description => "CTK Testing",
137             code => sub {
138             ### CODE:
139             my ($self, $meta, @params) = @_;
140             say("Testing CTK environment...");
141             my $summary = 1; # OK
142              
143             # CTK version
144             my $ver = CTK->VERSION;
145             if ($ver) {
146             yep("CTK version: %s", $ver);
147             } else {
148             $summary = nope("Can't get CTK version");
149             }
150              
151             # Handlers list
152             my @handlers = $self->list_handlers;
153             if (@handlers) {
154             yep("Handlers: %s", join(", ", @handlers));
155             } else {
156             $summary = nope("Can't get list of handlers");
157             }
158              
159             # Allowed skels
160             my $skel = CTK::Skel->new( -skels => PROJECT_SKELS );
161             if (my @skels = $skel->skels) {
162             yep("Allowed skeletons: %s", join(", ", @skels));
163             } else {
164             $summary = nope("Can't get list of skeletons");
165             }
166              
167             # Summary
168             if ($summary) {
169             yep("All tests was passed");
170             } else {
171             nope("Testing failed");
172             }
173             print "\n";
174              
175             return 1;
176             });
177              
178             __PACKAGE__->register_handler(
179             handler => "create",
180             description => "Project making",
181             code => sub {
182             ### CODE:
183             my ($self, $meta, @params) = @_;
184             my $projectname = @params ? shift @params : '';
185             my $tty = $self->option("tty");
186             my $yes = $self->option("yes") ? 1 : 0;
187             my $type = $self->option("type");
188             my $dir = $self->option("dir");
189             my %vars = (
190             CTK_VERSION => CTK->VERSION,
191             GMT => CTK::Util::dtf("%w %MON %_D %hh:%mm:%ss %YYYY %Z", time(), 'GMT'), # scalar(gmtime)." GMT"
192             );
193              
194             # Project name
195             {
196             unless ($projectname) {
197             $projectname = ($tty && !$yes)
198             ? $self->cli_prompt('Project Name:', PROJECT_NAME)
199             : PROJECT_NAME;
200             }
201             $projectname =~ s/[^a-z0-9_]/X/ig;
202             if ($tty && $projectname !~ /^[A-Z]/) {
203             printf "The selected name begins with a small letter: %s\n", $projectname;
204             if (!$yes) {
205             return skip('Operation aborted')
206             if $self->cli_prompt('Are you sure you want to continue?:','no') !~ /^\s*y/i;
207             }
208             }
209             $vars{PROJECT_NAME} = $projectname;
210             $vars{PROJECT_NAMEL} = lc($projectname);
211             }
212              
213             # Project type
214             {
215             my $atypes = PROJECT_TYPES;
216             unless ($type) {
217             $type = ($tty && !$yes)
218             ? lc($self->cli_prompt(
219             sprintf('Project type (%s):', join(", ", keys(%$atypes))),
220             PROJECT_TYPE_DEFAULT
221             ))
222             : PROJECT_TYPE_DEFAULT;
223             }
224             return nope('Incorrect type') unless $atypes->{$type};
225             $vars{PROJECT_TYPE} = $type;
226             }
227              
228             # Directory
229             $dir ||= ($tty && !$yes)
230             ? $self->cli_prompt('Please provide destination directory:', File::Spec->catdir(getcwd(), $projectname))
231             : File::Spec->catdir(getcwd(), $projectname);
232             if (-e $dir) {
233             if ($tty) {
234             if (!$yes) {
235             return skip('Operation aborted')
236             if $self->cli_prompt(sprintf('Directory "%s" already exists! Are you sure you want to continue?:', $dir),'no') !~ /^\s*y/i;
237             }
238             } else {
239             return skip('Directory "%s" already exists! Operation forced aborted because pipe mode is enabled', $dir);
240             }
241             }
242              
243             # Summary
244             if ($tty) {
245             my $tbl = Text::SimpleTable->new(
246             [ 25, 'PARAM' ],
247             [ 57, 'VALUE / MESSAGE' ],
248             );
249             $tbl->row( $_, $vars{$_} ) for @{(PROJECT_VARS)};
250             $tbl->hr;
251             $tbl->row( "DIRECTORY", $dir );
252             print("\n",colored(['cyan'], "SUMMARY TABLE:"),"\n", colored(['cyan'], $tbl->draw), "\n");
253             return skip('Operation aborted') if !$yes
254             && $self->cli_prompt('All right?:','yes') !~ /^\s*y/i;
255             }
256              
257             # Start building!
258             {
259             my $tmpdirobj = File::Temp->newdir(TEMPLATE => lc($projectname).'XXXXX', TMPDIR => 1);
260             my $tmpdir = $tmpdirobj->dirname;
261             my $skel = CTK::Skel->new(
262             -name => $projectname,
263             -root => $tmpdir,
264             -skels => PROJECT_SKELS,
265             -debug => $tty,
266             -vars => {
267             CTKVERSION => CTK->VERSION,
268             PROJECT_VERSION => "1.00",
269             AUTHOR => "Mr. Anonymous",
270             ADMIN => "root\@example.com",
271             HOMEPAGE => "https://www.example.com",
272             },
273             );
274              
275             #$tmpdir = File::Spec->catdir($self->tempdir, lc($projectname));
276             printf("Creating %s project %s to %s...\n\n", $type, $projectname, $tmpdir);
277              
278             my $skels = PROJECT_TYPES()->{$type} || [];
279             foreach my $s (@$skels) {
280             if ($skel->build($s, $tmpdir, {%vars})) {
281             yep("The %s files have been successfully processed", $s);
282             } else {
283             return nope("Can't build the project to \"%s\" directory", $tmpdir);
284             }
285             }
286              
287             # Move to destination directory
288             if (dirmove($tmpdir, $dir)) {
289             yep("Project was successfully created!");
290             printf("\nAll the project files was located in %s directory\n", $dir);
291             } else {
292             return nope("Can't move directory from \"%s\" to \"%s\": %s", $tmpdir, $dir, $!);
293             }
294             }
295              
296             return 0;
297             });
298              
299             # Colored print
300             sub yep {
301 0     0 1   print(colored(['green'], '[ OK ]'), ' ', sprintf(shift, @_), "\n");
302 0           return 1;
303             }
304             sub nope {
305 0     0 1   print(colored(['red'], '[ FAIL ]'), ' ', sprintf(shift, @_), "\n");
306 0           return 0;
307             }
308             sub skip {
309 0     0 1   print(colored(['yellow'], '[ SKIP ]'), ' ', sprintf(shift, @_), "\n");
310 0           return 1;
311             }
312              
313             1;
314              
315             __END__