File Coverage

blib/lib/CTK/Skel.pm
Criterion Covered Total %
statement 42 171 24.5
branch 0 72 0.0
condition 0 42 0.0
subroutine 14 26 53.8
pod 5 5 100.0
total 61 316 19.3


line stmt bran cond sub pod time code
1             package CTK::Skel;
2 1     1   6 use strict;
  1         2  
  1         33  
3 1     1   4 use utf8;
  1         1  
  1         4  
4              
5             =encoding utf8
6              
7             =head1 NAME
8              
9             CTK::Skel - Helper for building project's skeletons
10              
11             =head1 VIRSION
12              
13             Version 1.01
14              
15             =head1 SYNOPSIS
16              
17             use CTK::Skel;
18              
19             my $skel = CTK::Skel->new(
20             -dir => "/destination/directory/for/project",
21             );
22              
23             my $skel = CTK::Skel->new(
24             -name => "ProjectName",
25             -root => "/path/to/project/dir",
26             -skels => {
27             foo => 'My::Foo::Module',
28             # ...
29             },
30             -vars => {
31             VAR1 => "abc",
32             VAR2 => "def",
33             # ...
34             },
35             -debug => 1,
36             );
37              
38             my $status = $skel->build( "foo", "/path/to/project/dir", {
39             VAR3 => 'my value',
40             # ...
41             });
42              
43             =head1 DESCRIPTION
44              
45             Helper for building project's skeletons
46              
47             =head2 new
48              
49             my $skel = CTK::Skel->new(
50             -name => "ProjectName",
51             -root => "/path/to/project/dir",
52             -skels => {
53             foo => 'My::Foo::Module',
54             # ...
55             },
56             -vars => {
57             VAR1 => "abc",
58             VAR2 => "def",
59             # ...
60             },
61             -debug => 1,
62             );
63              
64             Returns skeletons helper's object
65              
66             =head2 build
67              
68             my $status = $skel->build( "foo", "/path/to/project/dir", {
69             VAR1 => 'foo',
70             VAR2 => 'bar',
71             # ...
72             });
73              
74             Building "foo" files and directories to "/path/to/project/dir" directory
75              
76             my $status = $skel->build( "foo", {
77             VAR1 => 'foo',
78             VAR2 => 'bar',
79             # ...
80             });
81              
82             Building "foo" files and directories to default directory (see L)
83              
84             =head2 dirs, pool
85              
86             Base methods. For internal use only
87              
88             =head2 skels
89              
90             my @available_skels = $skel->skels();
91              
92             Returns list of registered skeletons
93              
94             =head1 HISTORY
95              
96             See C file
97              
98             =head1 SEE ALSO
99              
100             L
101              
102             =head1 AUTHOR
103              
104             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
105              
106             =head1 COPYRIGHT
107              
108             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
109              
110             =head1 LICENSE
111              
112             This program is free software; you can redistribute it and/or
113             modify it under the same terms as Perl itself.
114              
115             See C file and L
116              
117             =cut
118              
119 1     1   42 use vars qw/$VERSION/;
  1         12  
  1         40  
120             $VERSION = '1.01';
121              
122 1     1   14 use Carp;
  1         12  
  1         60  
123 1     1   5 use File::Spec;
  1         2  
  1         23  
124 1     1   646 use File::Temp qw();
  1         8086  
  1         28  
125 1     1   7 use MIME::Base64 qw/decode_base64/;
  1         1  
  1         42  
126 1     1   1169 use Term::ANSIColor qw/colored/;
  1         7255  
  1         826  
127 1     1   12 use CTK::Util qw/ :BASE /;
  1         2  
  1         773  
128 1     1   6 use CTK::ConfGenUtil;
  1         1  
  1         72  
129 1     1   577 use CTK::TFVals qw/ :ALL /;
  1         3  
  1         289  
130              
131 1     1   8 use Cwd qw/getcwd/;
  1         2  
  1         47  
132              
133 1     1   4 use mro; # See also Class::C3::Adopt::NEXT and MRO::Compat
  1         2  
  1         8  
134              
135             use constant {
136 1         1779 PROJECT => "Foo",
137             EXEMODE => 0755,
138             DIRMODE => 0777,
139             ROOTDIR => getcwd(),
140             BOUNDARY => qr/\-{5}BEGIN\s+FILE\-{5}(.*?)\-{5}END\s+FILE\-{5}/is,
141             STDRPLC => {
142             PODSIG => '=',
143             DOLLAR => '$',
144             GMT => sprintf("%s GMT", scalar(gmtime)),
145             YEAR => (gmtime)[5]+1900,
146             },
147 1     1   113 };
  1         1  
148              
149             our @ISA;
150              
151             sub new {
152 0     0 1   my $class = shift;
153 0 0         my ($project_name, $project_dir, $modules, $newrplc, $debug) = read_attributes([
154             ['PROJECTNAME','PROJECT','NAME'],
155             ['PROJECTDIR','DIR','PROJECTROOT','ROOT'],
156             ['SKELS','LIST','MODULES'],
157             ['REPLACE','RPLC','VARS'],
158             ['DEBUG'],
159             ],@_) if defined $_[0];
160 0   0       $newrplc ||= {};
161 0           my %rplc = %{(STDRPLC)};
  0            
162 0   0       $rplc{"PROJECT"} = $project_name || PROJECT;
163 0 0         if (ref($newrplc) eq 'HASH') {
164 0           foreach my $k (keys %$newrplc) {
165 0           $rplc{$k} = $newrplc->{$k};
166             }
167             }
168              
169             my $self = bless {
170 0 0 0       project => $rplc{"PROJECT"},
171             boundary=> BOUNDARY,
172             rplc => { %rplc },
173             root => $project_dir || ROOTDIR,
174             subdirs => {},
175             pools => {},
176             skels => [], # Names of loaded modules
177             debug => $debug ? 1 : 0,
178             }, $class;
179              
180             # Register skels
181 0 0 0       if ($modules && ref($modules) eq 'HASH') {
182 0           my @skels;
183 0           foreach my $skel (keys %$modules) {
184 0 0         if ($self->_load($modules->{$skel})) {
185 0           push @skels, $skel;
186             } else {
187 0           carp(sprintf("Can't initialize %s skeleton", $skel));
188 0           last;
189             }
190             }
191 0           $self->{skels} = [@skels];
192             }
193              
194 0           return $self;
195             }
196             sub skels {
197 0     0 1   my $self = shift;
198 0           my $skels = $self->{skels};
199 0           return @$skels;
200             }
201             sub build {
202 0     0 1   my $self = shift;
203 0           my $name = shift;
204 0 0         my $dir = shift if $_[1];
205 0   0       my $rplc = shift || {};
206 0   0       my $root = $dir || $self->{root};
207              
208             # Get skels list
209 0           my @skels = $self->skels;
210 0 0 0       unless ($name && grep {$_ eq $name} @skels) {
  0            
211 0           carp("Incorrect scope name. Allowed: ".join(", ",@skels));
212 0           return 0;
213             }
214 0 0         $rplc = {} unless ref($rplc) eq 'HASH';
215              
216             # Directories normalize
217 0 0         $self->dirs() if $self->can('dirs');
218              
219             # Pools normalize
220 0 0         $self->pool() if $self->can('pool');
221              
222             # To next build() in modules
223 0           my $ret = $self->maybe::next::method();
224 0 0         return 0 unless $ret;
225              
226             #
227             # Building
228             #
229 0           my $_rplc = $self->{rplc};
230 0           for (keys %$_rplc) { $rplc->{$_} = $_rplc->{$_} }
  0            
231              
232             # Post-processing: directories
233 0   0       my $subdirs = $self->{subdirs} || {};
234 0           my $vd = $subdirs->{$name};
235 0           foreach my $d (@$vd) {
236 0           my @ds = split(/\//,_ff($d->{path}, $rplc));
237 0 0         my $path = $root ? File::Spec->catdir($root, @ds) : File::Spec->catdir(@ds);
238 0 0         my $mode = defined $d->{mode} ? $d->{mode} : DIRMODE;
239 0 0         if (preparedir($path, $mode)) {
240 0           $self->_debug(_yep("%s", $path));
241             } else {
242 0           $self->_debug(_nope("Can't create directory \"%s\" [%o]", $path, $mode));
243             }
244             }
245              
246             # Post-processing: files
247 0   0       my $pools = $self->{pools} || {};
248 0           my $vp = $pools->{$name};
249 0           foreach my $p (@$vp) {
250 0 0 0       next if $p->{type} && !isostype($p->{type}); # Type check
251 0 0 0       my $b64 = ($p->{encode} && $p->{encode} eq 'base64') ? 1 : 0;
252 0   0       my $fname = $p->{name} || 'noname';
253 0 0         unless ($p->{file}) {
254 0           $self->_debug(_skip("Skip %s file: path not defined!", $fname));
255 0           next;
256             }
257 0           my @ds = split(/\//,_ff($p->{file}, $rplc));
258 0           my $file = File::Spec->catfile($root, @ds);
259 0 0         if (-e $file) {
260 0           $self->_debug(_skip("%s", $file));
261 0           next;
262             }
263 0           my $mode = $p->{mode};
264 0           my $st = 0;
265 0 0         if ($b64) { $st = bsave($file, decode_base64( $p->{data} )) }
  0            
266 0           else { $st = bsave($file, CTK::Util::lf_normalize(_ff($p->{data}, $rplc)), 1) }
267 0 0 0       if ($st && -e $file) {
268 0 0         chmod($mode, $file) if defined($mode);
269 0           $self->_debug(_yep("%s", $file));
270             } else {
271 0   0       $self->_debug(_nope("Can't create file \"%s\" [%o]", $file, $mode // 0));
272 0           return 0;
273             }
274             }
275              
276 0           return 1;
277             }
278             sub dirs {
279 0     0 1   my $self = shift;
280 0           $self->maybe::next::method();
281 0   0       my $dirs = $self->{subdirs} || {};
282 0           foreach my $kd (keys %$dirs) {
283 0 0         if (ref($dirs->{$kd}) eq 'HASH') {
    0          
284 0           $dirs->{$kd} = [$dirs->{$kd}];
285             } elsif (ref($dirs->{$kd}) eq 'ARRAY') {
286             # OK;
287             } else {
288 0 0         carp "Directory incorrect. Array or hash expected!" if $dirs->{$kd};
289             }
290             }
291 0           return 1;
292             }
293             sub pool {
294 0     0 1   my $self = shift;
295 0           $self->maybe::next::method();
296 0           my $boundary = $self->{boundary};
297 0   0       my $pools = $self->{pools} || {};
298 0           foreach my $kd (keys %$pools) {
299 0           my $buff = $pools->{$kd};
300 0           my @pool;
301 0           $buff =~ s/$boundary/_bcut($1,\@pool)/ge;
  0            
302 0           foreach my $r (@pool) {
303 0 0         my $name = ($r =~ /^\s*name\s*\:\s*(.+?)\s*$/mi) ? $1 : '';
304 0 0         my $file = ($r =~ /^\s*file\s*\:\s*(.+?)\s*$/mi) ? $1 : '';
305 0 0         my $mode = ($r =~ /^\s*mode\s*\:\s*(.+?)\s*$/mi) ? $1 : '';
306 0 0         my $type = ($r =~ /^\s*type\s*\:\s*(.+?)\s*$/mi) ? $1 : '';
307 0 0         my $enc = ($r =~ /^\s*encode\s*\:\s*(.+?)\s*$/mi) ? $1 : '';
308 0 0         my $data = ($r =~ /\s*\r?\n\s*\r?\n(.+)/s) ? $1 : '';
309              
310 0 0         $mode = undef unless $mode =~ /^[0-9]{1,3}$/;
311 0 0         $r = {
312             name => $name,
313             file => $file,
314             data => lf_normalize($data), # CRLF correct
315             mode => defined($mode) ? oct($mode) : undef,
316             type => $type,
317             encode => $enc,
318             };
319             }
320 0           $pools->{$kd} = [@pool];
321             }
322 0           return 1;
323             }
324              
325             # Methods
326             sub _load {
327 0     0     my $self = shift;
328 0           my $module = shift;
329 0           my $file = sprintf("%s.pm", join('/', split('::', $module)));
330 0           utf8::encode($file); # from base.pm
331 0 0         return 1 if exists $INC{$file};
332 0           eval { require $file; };
  0            
333 0 0         if ($@) {
334 0           carp(sprintf("Can't load file: %s", $@));
335 0           return 0;
336             }
337 0           push @ISA, $module;
338 0           return 1;
339             }
340             sub _debug {
341 0     0     my $self = shift;
342 0 0         return unless $self->{debug};
343 0           print @_, "\n";
344             }
345              
346             # Functions
347             sub _yep {
348 0     0     return(colored(['green'], '[ OK ]'), ' ', sprintf(shift, @_));
349             }
350             sub _nope {
351 0     0     return(colored(['red'], '[ FAIL ]'), ' ', sprintf(shift, @_));
352             }
353             sub _skip {
354 0     0     return(colored(['yellow'], '[ SKIP ]'), ' ', sprintf(shift, @_));
355             }
356             sub _bcut {
357 0     0     my $s = shift;
358 0           my $a = shift;
359 0           push @$a, $s;
360 0           return '';
361             }
362             sub _ff {
363 0   0 0     my $d = shift || '';
364 0   0       my $h = shift || {};
365 0 0         $d =~ s/\%(\w+?)\%/(defined $h->{$1} ? $h->{$1} : '%'.$1.'%')/eg;
  0            
366 0           return $d
367             }
368              
369             1;