File Coverage

blib/lib/Data/Printer/Config.pm
Criterion Covered Total %
statement 159 178 89.3
branch 82 114 71.9
condition 21 55 38.1
subroutine 15 16 93.7
pod 2 2 100.0
total 279 365 76.4


line stmt bran cond sub pod time code
1             package Data::Printer::Config;
2 12     12   680697 use strict;
  12         100  
  12         329  
3 12     12   55 use warnings;
  12         20  
  12         338  
4 12     12   4383 use Data::Printer::Common;
  12         29  
  12         26404  
5              
6             sub load_rc_file {
7 4     4 1 12125 my ($filename) = @_;
8 4 100       89 if (!$filename) {
9 3         11 $filename = _get_first_rc_file_available();
10             }
11 4 50 33     225 return unless $filename && -e $filename && !-d $filename;
      33        
12 4 50       215 if (open my $fh, '<', $filename) {
13              
14             # slurp the file:
15 4         11 my $rc_data;
16 4         5 { local $/ = undef; $rc_data = <$fh> }
  4         27  
  4         180  
17 4         54 close $fh;
18 4         22 return _str2data($filename, $rc_data);
19             }
20             else {
21 0           Data::Printer::Common::_warn(undef, "error opening '$filename': $!");
22 0           return;
23             }
24             }
25              
26             sub _get_first_rc_file_available {
27 3 100   3   13 return $ENV{DATAPRINTERRC} if exists $ENV{DATAPRINTERRC};
28              
29             # look for a .dataprinter file on the project home up until we reach '/'
30 2         6 my $dir = _project_home();
31 2         45 require File::Spec;
32 2         8 while (defined $dir) {
33 2         14 my $file = File::Spec->catfile($dir, '.dataprinter');
34 2 100       82 return $file if -f $file;
35 1         11 my @path = File::Spec->splitdir($dir);
36 1 50       4 last unless @path;
37 1         10 my $updir = File::Spec->catdir(@path[0..$#path-1]);
38 1 50 33     10 last if !defined $updir || $updir eq $dir;
39 1         4 $dir = $updir;
40             }
41             # still here? look for .dataprinter on the user's HOME:
42 1         4 return File::Spec->catfile( _my_home(), '.dataprinter');
43             }
44              
45             sub _my_cwd {
46 2     2   8 require Cwd;
47 2         20 my $cwd = Cwd::getcwd();
48             # try harder if we can't access the current dir.
49 2 50       20 $cwd = Cwd::cwd() unless defined $cwd;
50 2         25 return $cwd;
51             }
52              
53             sub _project_home {
54 2     2   15 require Cwd;
55 2         5 my $path;
56 2 100 66     15 if ($0 eq '-e' || $0 eq '-') {
57 1         4 my $cwd = _my_cwd();
58 1 50       39 $path = Cwd::abs_path($cwd) if defined $cwd;
59             }
60             else {
61 1         3 my $script = $0;
62 1 50       22 return unless -f $script;
63 1         6 require File::Spec;
64 1         4 require File::Basename;
65             # we need the full path if we have chdir'd:
66 1 50       16 $script = File::Spec->catfile(_my_cwd(), $script)
67             unless File::Spec->file_name_is_absolute($script);
68 1         41 my (undef, $maybe_path) = File::Basename::fileparse($script);
69 1 50       61 $path = Cwd::abs_path($maybe_path) if defined $maybe_path;
70             }
71 2         18 return $path;
72             }
73              
74             # adapted from File::HomeDir && File::HomeDir::Tiny
75             sub _my_home {
76 5     5   1068 my ($testing) = @_;
77 5 100 33     32 if ($testing) {
    50          
    50          
78 3         2119 require File::Temp;
79 3         45567 require File::Spec;
80 3         14 my $BASE = File::Temp::tempdir( CLEANUP => 1 );
81 3         1896 my $home = File::Spec->catdir( $BASE, 'my_home' );
82 3         22 $ENV{HOME} = $home;
83 3 50       174 mkdir($home, 0755) unless -d $home;
84 3         46 return $home;
85             }
86             elsif ($^O eq 'MSWin32' and "$]" < 5.016) {
87 0   0     0 return $ENV{HOME} || $ENV{USERPROFILE};
88             }
89             elsif ($^O eq 'MacOS') {
90 0     0   0 my $error = _tryme(sub { require Mac::SystemDirectory; 1 });
  0         0  
  0         0  
91 0 0       0 return Mac::SystemDirectory::HomeDirectory() unless $error;
92             }
93             # this is the most common case, for most breeds of unix, as well as
94             # MSWin32 in more recent perls.
95 2         919 my $home = (<~>)[0];
96 2 50       25 return $home if $home;
97              
98             # desperate measures that should never be needed.
99 0 0 0     0 if (exists $ENV{LOGDIR} and $ENV{LOGDIR}) {
100 0         0 $home = $ENV{LOGDIR};
101             }
102 0 0 0     0 if (not $home and exists $ENV{HOME} and $ENV{HOME}) {
      0        
103 0         0 $home = $ENV{HOME};
104             }
105             # Light desperation on any (Unixish) platform
106 0 0       0 SCOPE: { $home = (getpwuid($<))[7] if not defined $home }
  0         0  
107 0 0 0     0 if (defined $home and ! -d $home ) {
108 0         0 $home = undef;
109             }
110 0         0 return $home;
111             }
112              
113             sub _file_mode_is_restricted {
114 1     1   4 my ($filename) = @_;
115 1         36 my $mode_raw = (stat($filename))[2];
116 1 50       7 return 0 unless defined $mode_raw;
117 0         0 my $mode = sprintf('%04o', $mode_raw & 07777);
118 0 0 0     0 return (length($mode) == 4 && substr($mode, 2, 2) eq '00') ? 1 : 0;
119             }
120              
121             sub _str2data {
122 8     8   3843 my ($filename, $content) = @_;
123 8         28 my $config = { _ => {} };
124 8         20 my $counter = 0;
125 8         16 my $filter;
126             my $can_use_filters;
127 8         18 my $ns = '_';
128             # based on Config::Tiny
129 8         493 foreach ( split /(?:\015{1,2}\012|\015|\012)/, $content ) {
130 183         232 $counter++;
131 183 100       776 if (defined $filter) {
    100          
    100          
    100          
    100          
132 13 100       44 if ( /^end filter\s*$/ ) {
    100          
133 6 50       23 if (!defined $can_use_filters) {
134 6         37 $can_use_filters = _file_mode_is_restricted($filename);
135             }
136 6 100       24 if ($can_use_filters) {
137             my $sub_str = 'sub { my ($obj, $ddp) = @_; '
138             . $filter->{code_str}
139 5         21 . '}'
140             ;
141 5         13 push @{$config->{$ns}{filters}}, +{ $filter->{name} => eval $sub_str };
  5         764  
142             }
143             else {
144 1         7 Data::Printer::Common::_warn(undef, "ignored filter '$filter->{name}' from rc file '$filename': file is readable/writeable by others");
145             }
146 6         853 $filter = undef;
147             }
148             elsif ( /^begin\s+filter/ ) {
149 1         9 Data::Printer::Common::_warn(undef, "error reading rc file '$filename' line $counter: found 'begin filter' inside another filter definition ($filter->{name}). Are you missing an 'end filter' on line " . ($counter - 1) . '?');
150 1         550 return {};
151             }
152             else {
153 6         20 $filter->{code_str} .= $_;
154             }
155             }
156             elsif ( /^\s*(?:\#|\;|$)/ ) {
157             next # skip comments and empty lines
158 54         72 }
159             elsif ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) {
160             # Create the sub-hash if it doesn't exist.
161             # Without this, sections without keys will not
162             # appear at all in the completed struct.
163 18   50     81 $config->{$ns = $1} ||= {};
164             }
165             elsif ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) {
166             # Handle properties:
167 90         204 my ($path_str, $value) = ($1, $2);
168             # turn a.b.c.d into {a}{b}{c}{d}
169 90         167 my @subpath = split /\./, $path_str;
170 90         157 my $current = $config->{$ns};
171              
172             # remove single/double (enclosing) quotes
173 90         177 $value =~ s/\A(['"])(.*)\1\z/$2/;
174              
175             # the root "filters" key is a special case, because we want
176             # it to always be an arrayref. In other words:
177             # filters = abc,def --> filters => ['abc', 'def']
178             # filters = abc --> filters => ['abc']
179             # filters = --> filters => []
180 90 100 100     279 if (@subpath == 1 && $subpath[0] eq 'filters') {
181 18         54 $value = [ split /\s*,\s*/ => $value ];
182             }
183              
184 90         179 while (my $subpath = shift @subpath) {
185 144 100       218 if (@subpath > 0) {
186 54   100     145 $current->{$subpath} ||= {};
187 54         93 $current = $current->{$subpath};
188             }
189             else {
190 90         249 $current->{$subpath} = $value;
191             }
192             }
193             }
194             elsif ( /^begin\s+filter\s+([^\s]+)\s*$/ ) {
195 7         17 my $filter_name = $1;
196 7         26 $filter = { name => $filter_name, code_str => '' };
197             }
198             else {
199 1         6 Data::Printer::Common::_warn(undef, "error reading rc file '$filename': syntax error at line $counter: $_");
200 1 50 33     571 if ($counter == 1 && /\A\s*\{/s) {
201 1         8 Data::Printer::Common::_warn(
202             undef,
203             "\nRC file format changed in 1.00. Usually all it takes is:\n"
204             . " cp $filename $filename.old && perl -MData::Printer::Config -E 'say Data::Printer::Config::convert(q($filename.old))' > $filename\n"
205             . "Please visit https://metacpan.org/pod/Data::Printer::Config for details.\n"
206             );
207             }
208 1         478 return {};
209             }
210             }
211             # now that we have loaded the config, we must expand
212             # all existing 'rc_file' and 'profile' statements and
213             # merge them together.
214 6         38 foreach my $ns (keys %$config) {
215             $config->{$ns} = _expand_profile($config->{$ns})
216 24 50       50 if exists $config->{$ns}{profile};
217             }
218 6         36 return $config;
219             }
220              
221             sub _merge_options {
222 804     804   4491 my ($old, $new) = @_;
223 804 100       1796 if (ref $new eq 'HASH') {
    100          
224 206         268 my %merged;
225 206 100       375 my $to_merge = ref $old eq 'HASH' ? $old : {};
226 206         579 foreach my $k (keys %$new, keys %$to_merge) {
227             # if the key exists in $new, we recurse into it:
228 602 100       977 if (exists $new->{$k}) {
229 437         887 $merged{$k} = _merge_options($to_merge->{$k}, $new->{$k});
230             }
231             else {
232             # otherwise we keep the old version (recursing in case of refs)
233 165         239 $merged{$k} = _merge_options(undef, $to_merge->{$k});
234             }
235             }
236 206         701 return \%merged;
237             }
238             elsif (ref $new eq 'ARRAY') {
239             # we'll only use the array on $new, but we still need to recurse
240             # in case array elements contain other data structures.
241 35         50 my @merged;
242 35         56 foreach my $element (@$new) {
243 56         79 push @merged, _merge_options(undef, $element);
244             }
245 35         76 return \@merged;
246             }
247             else {
248 563         1295 return $new;
249             }
250             }
251              
252              
253             sub _expand_profile {
254 7     7   11745 my ($options, $ddp) = @_;
255 7         17 my $profile = delete $options->{profile};
256 7 100       39 if ($profile !~ /\A[a-zA-Z0-9:]+\z/) {
257 2         8 Data::Printer::Common::_warn($ddp,"invalid profile name '$profile'");
258             }
259             else {
260 5         13 my $class = 'Data::Printer::Profile::' . $profile;
261             my $error = Data::Printer::Common::_tryme(sub {
262 5     5   18 my $load_error = Data::Printer::Common::_tryme("use $class; 1;");
263 5 100       16 die $load_error if defined $load_error;
264 4         10 my $expanded = $class->profile();
265 4 50       15 die "profile $class did not return a HASH reference" unless ref $expanded eq 'HASH';
266 4         12 $options = Data::Printer::Config::_merge_options($expanded, $options);
267 5         33 });
268 5 100       30 if (defined $error) {
269 1         5 Data::Printer::Common::_warn($ddp, "unable to load profile '$profile': $error");
270             }
271             }
272 7         35 return $options;
273             }
274              
275              
276              
277              
278             # converts the old format to the new one
279             sub convert {
280 4     4 1 21 my ($filename) = @_;
281 4 100       18 Data::Printer::Common::_die("please provide a .dataprinter file path")
282             unless $filename;
283 3 100 66     106 Data::Printer::Common::_die("file '$filename' not found")
284             unless -e $filename && !-d $filename;
285 2 50       69 open my $fh, '<', $filename
286             or Data::Printer::Common::_die("error reading file '$filename': $!");
287              
288 2         7 my $rc_data;
289 2         2 { local $/; $rc_data = <$fh> }
  2         13  
  2         53  
290 2         20 close $fh;
291              
292 2         232 my $config = eval $rc_data;
293 2 50 66     17 if ( $@ ) {
    100          
294 0         0 Data::Printer::Common::_die("error loading file '$filename': $@");
295             }
296             elsif (!ref $config or ref $config ne 'HASH') {
297 1         8 Data::Printer::Common::_die("error loading file '$filename': config file must return a hash reference");
298             }
299             else {
300 1         6 return _convert('', $config);
301             }
302             }
303              
304             sub _convert {
305 13     13   25 my ($key_str, $value) = @_;
306 13 100       24 if (ref $value eq 'HASH') {
307 5 100       11 $key_str = 'colors' if $key_str eq 'color';
308 5         6 my $str = '';
309 5         20 foreach my $k (sort keys %$value) {
310 12 100       36 $str .= _convert(($key_str ? "$key_str.$k" : $k), $value->{$k});
311             }
312 5         23 return $str;
313             }
314 8 100 66     56 if ($key_str && $key_str eq 'filters.-external' && ref $value eq 'ARRAY') {
    100 66        
315 1         5 return 'filters = ' . join(', ' => @$value) . "\n";
316             }
317             elsif (ref $value) {
318 2         14 Data::Printer::Common::_warn(
319             undef,
320             " [*] path '$key_str': expected scalar, found " . ref($value)
321             . ". Filters must be in their own class now, loaded with 'filter'.\n"
322             . "If you absolutely must put custom filters in, use the 'begin filter'"
323             . " / 'end filter' options manually, as explained in the documentation,"
324             . " making sure your .dataprinter file is not readable nor writeable to"
325             . " anyone other than your user."
326             );
327 2         8 return '';
328             }
329             else {
330 5 100       14 $value = "'$value'" if $value =~ /\s/;
331 5         26 return "$key_str = $value\n";
332             }
333             }
334              
335             1;
336             __END__