File Coverage

blib/lib/File/Create/Layout.pm
Criterion Covered Total %
statement 90 144 62.5
branch 55 104 52.8
condition 0 8 0.0
subroutine 7 10 70.0
pod 3 3 100.0
total 155 269 57.6


line stmt bran cond sub pod time code
1             package File::Create::Layout;
2              
3             our $DATE = '2015-09-11'; # DATE
4             our $VERSION = '0.03'; # VERSION
5              
6 1     1   1542 use 5.010001;
  1         6  
7 1     1   7 use strict;
  1         2  
  1         33  
8 1     1   8 use warnings;
  1         3  
  1         139  
9 1     1   2151 use Log::Any::IfLOG '$log';
  1         21  
  1         9  
10              
11 1     1   1761 use File::chdir;
  1         6140  
  1         3098  
12              
13             require Exporter;
14             our @ISA = qw(Exporter);
15             our @EXPORT_OK = qw(
16             create_files_using_layout
17             );
18              
19             our %SPEC;
20              
21             my %arg_layout = (
22             layout => {
23             summary => 'Layout',
24             description => <<'_',
25              
26             See the module documentation for the format/specification of layout.
27              
28             _
29             schema => 'str*',
30             req => 1,
31             pos => 0,
32             },
33             );
34              
35             sub _decode_json {
36 7     7   9 state $json = do {
37 1         5 require JSON;
38 1         16 JSON->new->allow_nonref;
39             };
40 7         40 $json->decode(shift);
41             }
42              
43             sub _parse_layout {
44 29     29   11866 my $layout = shift;
45              
46 29         34 my @indents;
47             my @res;
48 29         33 my $linum = 0;
49 29         28 my $prev_is_dir = 0;
50 29         66 for my $line (split /^/, $layout) {
51 38         55 chomp $line;
52 38         50 my $orig_line = $line;
53              
54 38         35 $linum++;
55 38 100       131 next if $line =~ /\A\s*\z/;
56 37 100       72 next if $line =~ /\A\s*#/;
57              
58 35         173 $line =~ s/\A(\s*)//;
59 35         67 my $cur_indent = $1;
60 35 50       64 die "(layout):$linum: Tabs are not allowed: $orig_line"
61             if $cur_indent =~ /\t/;
62              
63 35         37 $cur_indent = length($cur_indent);
64              
65 35 100       69 if (!@indents) {
66 27         42 push @indents, $cur_indent;
67             }
68              
69 35 100       94 if ($cur_indent > $indents[-1]) {
    100          
70             # indent is deeper than previous spec-line, we require that the
71             # previous spec-line is directory
72 5 100       24 die "(layout):$linum: More indented than previous spec-line, but ".
73             "previous spec-line is not a directory: $orig_line"
74             unless $prev_is_dir;
75 4         5 push @indents, $cur_indent;
76             } elsif ($cur_indent < $indents[-1]) {
77             # indent is shallower than previous spec-line, find previous level
78 3         4 my $found;
79 3         7 for my $i (reverse 0..$#indents) {
80 5 100       12 if ($cur_indent == $indents[$i]) {
81 1         2 $found++;
82 1         2 splice @indents, $i;
83 1         2 last;
84             }
85             }
86 3 100       27 die "(layout):$linum: Invalid indent, must return to one of ".
87             "previous levels' indent: $orig_line" unless $found;
88             }
89              
90             # parse filename
91 32         35 my $name;
92 32 100       64 if ($line =~ /\A"/) {
93 5 100       39 $line =~ s#\A(".*?(?
94             or die "(layout):$linum: Invalid quoted filename: $orig_line";
95 3         6 $name = $1;
96 3         4 eval { $name = _decode_json($name) };
  3         7  
97 3 50       9 die "(layout):$linum: Invalid JSON string in filename: $@: $1"
98             if $@;
99             } else {
100 27         67 $line =~ s!\A([^\s\(/]*)!!;
101 27         43 $name = $1;
102             }
103 30 100       66 die "(layout):$linum: Filename cannot be empty: $orig_line"
104             unless length($name);
105 29 100       61 die "(layout):$linum: Filename cannot contain slashes: $orig_line"
106             if $name =~ m!/!;
107 28 100       68 die "(layout):$linum: Filename cannot be . or ..: $orig_line"
108             if $name =~ m!\A\.\.?\z!;
109              
110 26         22 my $is_dir;
111 26 100       51 if ($line =~ s!\A/!!) {
112 7         10 $is_dir = 1;
113             } else {
114 19         25 $is_dir = 0;
115             }
116              
117 26         31 my ($orig_perm, $perm, $user, $group);
118 26 100       49 if ($line =~ /\A\(/) {
119 6 100       57 $line =~ s/\A\((?:([^,]*),([^,]*),)?([0-7]{3,4})\)//
120             or die "(layout):$linum: Invalid syntax in permission/owner: $orig_line";
121 2         3 $user = $1;
122 2         4 $group = $2;
123 2         4 $orig_perm = $3;
124 2         5 $perm = oct($3);
125             }
126              
127 22         26 my $sym_target;
128 22 100       62 if ($line =~ s/\s+->\s*//) {
129 5 100       19 die "(layout):$linum: Symlink cannot be a directory: $orig_line"
130             if $is_dir;
131             # parse symlink target
132 4 100       12 if ($line =~ /\A"/) {
133 3 100       23 $line =~ s#\A(".*?(?
134             or die "(layout):$linum: Invalid quoted symlink target: $orig_line";
135 2         4 $sym_target = $1;
136 2         3 eval { $sym_target = _decode_json($sym_target) };
  2         4  
137 2 50       5 die "(layout):$linum: Invalid JSON string in symlink target: $@: $1"
138             if $@;
139             } else {
140 1         3 $line =~ s!\A([^\s]*)!!;
141 1         2 $sym_target = $1;
142             }
143 3 100       16 die "(layout):$linum: Symlink target cannot be empty: $orig_line"
144             unless length($sym_target);
145             }
146              
147 19         19 my $extras;
148 19 100       34 if ($line =~ s/\s+(\S.*)//) {
149 2         5 $extras = $1;
150 2         2 eval { $extras = _decode_json("{$extras}") };
  2         7  
151 2 50       5 die "(layout):$linum: Invalid unquoted JSON hash in extras: $@: $extras"
152             if $@;
153 2 50       7 if (defined $extras->{content}) {
154 2 100       15 die "(layout):$linum: Directory must not have 'content': $@: $orig_line"
155             if $is_dir;
156             }
157             }
158              
159             push @res, {
160             name => $name,
161             is_dir => $is_dir,
162             is_symlink => defined($sym_target) ? 1:0,
163             (symlink_target => $sym_target) x !!(defined $sym_target),
164             level => $#indents >= 0 ? $#indents : 0,
165             _linum => $linum,
166             perm => $perm,
167             perm_octal => $orig_perm,
168             user => $user,
169             group => $group,
170 18 100       141 (content => $extras->{content}) x !!(defined $extras->{content}),
    100          
171             };
172              
173 18         43 $prev_is_dir = $is_dir;
174             }
175              
176 12         44 \@res;
177             }
178              
179             $SPEC{create_files_using_layout} = {
180             v => 1.1,
181             summary => 'Create files/directories according to a layout',
182             description => <<'_',
183              
184             This routine can be used to quickly create several files/directories according
185             to a layout which you specify. The layout uses a few simple rules and common
186             conventions usually found in Linux/Unix environment.
187              
188             You can use this routine e.g. in a test script.
189              
190             _
191             args => {
192             %arg_layout,
193             prefix => {
194             summary => 'Root directory to create the files/directories in',
195             description => <<'_',
196              
197             Directory must already exist.
198              
199             If unspecified, will simply create starting from current directory.
200              
201             _
202             schema => 'str*',
203             },
204             },
205             };
206             sub create_files_using_layout {
207 0     0 1   require File::chown;
208              
209 0           my %args = @_;
210              
211 0           my $parse_res;
212 0           eval { $parse_res = _parse_layout($args{layout}) };
  0            
213 0 0         return [400, "Syntax error in layout: $@"] if $@;
214              
215 0           my $prefix = $args{prefix};
216 0   0       local $CWD = $prefix // $CWD;
217 0   0       $prefix //= ".";
218              
219 0           my $prev_level;
220             my @dirs;
221 0           for my $e (@$parse_res) {
222 0           my $p = $prefix . join("", map {"/$_"} @dirs);
  0            
223              
224 0 0         if (defined $prev_level) {
225 0 0         if ($e->{level} > $prev_level) {
    0          
226 0           $log->tracef("chdir %s ...", $dirs[-1]);
227 0           eval { $CWD = $dirs[-1] };
  0            
228 0 0         return [500, "Can't chdir to $p/$e->{name}: $!"] if $@;
229             } elsif ($e->{level} < $prev_level) {
230 0           my $dir = join("/", (("..") x ($prev_level - $e->{level})));
231 0           $log->tracef("chdir %s ...", $dir);
232 0           eval { $CWD = $dir };
  0            
233 0 0         return [500, "Can't chdir back to $dir: $!"]
234             if $@;
235             }
236             }
237              
238             $log->tracef("Creating %s/%s%s ...",
239 0 0         $p, $e->{name}, $e->{is_dir} ? "/":"");
240 0 0         if ($e->{is_dir}) {
    0          
241 0 0         do {
242 0 0         if (defined $e->{perm}) {
243 0           mkdir($e->{name}, $e->{perm});
244             } else {
245 0           mkdir($e->{name});
246             }
247             } or return [500, "Can't create directory $p/$e->{name}: $!"];
248 0           $dirs[$e->{level}] = $e->{name};
249             } elsif ($e->{is_symlink}) {
250             symlink($e->{symlink_target}, $e->{name})
251 0 0         or return [500, "Can't create symlink $p/$e->{name} -> ".
252             "$e->{symlink_target}: $!"];
253             } else {
254             open my($fh), ">", $e->{name}
255 0 0         or return [500, "Can't create file $p/$e->{name}: $!"];
256 0 0         if (defined $e->{content}) {
257             print $fh $e->{content}
258 0 0         or return [500, "Can't write content to file ".
259             "$p/$e->{name}: $!"];
260             }
261 0 0         if (defined $e->{perm}) {
262             chmod($e->{perm}, $e->{name})
263 0 0         or return [500, "Can't chmod file $p/$e->{name}: $!"];
264             }
265             }
266              
267 0 0 0       if (defined($e->{user}) || defined($e->{group})) {
268 0           my %opts;
269 0 0         $opts{deref} = 0 if $e->{is_symlink};
270             File::chown::chown(\%opts, $e->{user}, $e->{group}, $e->{name})
271 0 0         or return [500, "Can't chown file $p/$e->{name}: $!"];
272             }
273              
274 0           $prev_level = $e->{level};
275             }
276              
277 0           [200, "OK"];
278             }
279              
280             $SPEC{check_layout} = {
281             v => 1.1,
282             summary => 'Check whether layout has syntax errors',
283             args => {
284             %arg_layout,
285             },
286             };
287             sub check_layout {
288 0     0 1   my %args = @_;
289              
290 0           eval { _parse_layout($args{layout}) };
  0            
291 0           my $err = $@;
292 0 0         [200, "OK", $err ? 0:1, {'func.error' => $err}];
293             }
294              
295             $SPEC{parse_layout} = {
296             v => 1.1,
297             summary => 'Parse layout string into a data structure '.
298             'suitable for processing',
299             args => {
300             %arg_layout,
301             },
302             };
303             sub parse_layout {
304 0     0 1   my %args = @_;
305              
306 0           my $res;
307 0           eval { $res = _parse_layout($args{layout}) };
  0            
308 0 0         return [400, "Layout has error(s): $@"] if $@;
309 0           [200, "OK", $res];
310             }
311              
312             1;
313             # ABSTRACT: Quickly create files/directories according to a layout
314              
315             __END__