File Coverage

blib/lib/Config/Properties/Commons.pm
Criterion Covered Total %
statement 313 383 81.7
branch 85 140 60.7
condition 12 24 50.0
subroutine 42 65 64.6
pod 15 36 41.6
total 467 648 72.0


line stmt bran cond sub pod time code
1             package Config::Properties::Commons;
2              
3             #######################
4             # LOAD MODULES
5             #######################
6 6     6   257852 use strict;
  6         14  
  6         268  
7 6     6   36 use warnings FATAL => 'all';
  6         11  
  6         344  
8 6     6   45 use Carp qw(croak carp);
  6         9  
  6         415  
9              
10 6     6   152 use 5.008_001;
  6         22  
  6         245  
11 6     6   6066 use Encode qw();
  6         78130  
  6         158  
12 6     6   52 use File::Spec qw();
  6         11  
  6         100  
13 6     6   8269 use Text::Wrap qw();
  6         31256  
  6         309  
14 6     6   54 use Cwd qw(abs_path);
  6         14  
  6         358  
15 6     6   37 use List::Util qw(max);
  6         15  
  6         666  
16 6     6   96 use File::Basename qw(dirname);
  6         13  
  6         507  
17 6     6   7058 use File::Slurp qw(read_file write_file);
  6         143721  
  6         552  
18 6     6   6419 use String::Util qw(no_space fullchomp hascontent trim);
  6         24994  
  6         698  
19 6     6   6328 use Params::Validate qw(validate_with validate_pos :types);
  6         78046  
  6         45569  
20              
21             #######################
22             # VERSION
23             #######################
24             our $VERSION = '0.04';
25              
26             #######################
27             # CONSTRUCTOR
28             #######################
29             sub new {
30 6     6 1 143 my ( $class, @args ) = @_;
31              
32             # Bless object
33 6         67 my $self = {
34             _options => {},
35             _seen_files => {},
36             _current_file => {
37             name => '',
38             base => '',
39             },
40             _properties => {},
41             };
42 6         25 bless $self, $class;
43              
44             # Process Options
45 6         16 my %options = %{ $self->_set_options(@args) };
  6         38  
46 6         82 $self->{_options} = {%options};
47              
48             # Get default properties
49 6         26 $self->{_properties} = $options{defaults};
50              
51             # Short-circuit _load_ if a filename is defined
52 6 100       28 if ( defined $options{load_file} ) {
53 1         35 $self->load( $options{load_file} );
54             }
55              
56             # Return object
57 6         37 return $self;
58             } ## end sub new
59              
60             #######################
61             # PUBLIC METHODS
62             #######################
63              
64             # =====================
65             # LOAD
66             # =====================
67             sub load {
68 6     6 1 23152 my ( $self, $from, @args ) = @_;
69 6 50       24 croak "File name/handle to load from is not provided"
70             unless defined $from;
71              
72             # Process Options
73 6         11 my %options = %{ $self->_set_options(@args) };
  6         19  
74              
75 6 100       49 unless ( ref $from ) {
76              
77             # Not a reference. _should_ be a file
78              
79 5         9 my $file = $from;
80              
81             # Check file
82 5         555 $file = abs_path($file);
83 5 50 33     128 croak "File $file does not exist!" unless ( $file and -f $file );
84              
85             # Set current file
86 5         17 $self->{_current_file}->{name} = $file;
87 5         269 $self->{_current_file}->{base} = dirname($file);
88              
89             # Process file?
90 5 50 33     35 return 1
91             if ( $options{cache_files} and $self->{_seen_files}->{$file} );
92              
93             # Mark as seen
94 5         19 $self->{_seen_files}->{$file} = 1;
95             } ## end unless ( ref $from )
96              
97             # Read file
98 6         30 my @lines = read_file(
99             $from,
100             binmode => ':utf8',
101             chomp => 1,
102             );
103              
104             # Load properties
105 6         1270 $self->_load(
106             {
107             lines => \@lines,
108             options => \%options,
109             }
110             );
111              
112 6         36 return 1;
113             } ## end sub load
114              
115             # =====================
116             # GET/SET PROPERTY
117             # =====================
118             sub get_property {
119 30     30 1 42 my ( $self, $key ) = @_;
120 30 100       110 return unless exists $self->{_properties}->{$key};
121 4         15 return $self->{_properties}->{$key};
122             } ## end sub get_property
123              
124              
125             sub require_property {
126 0     0 1 0 my ( $self, $key ) = @_;
127 0 0       0 croak "Property for $key is not set"
128             unless exists $self->{_properties}->{$key};
129 0         0 return $self->get_property($key);
130             } ## end sub require_property
131              
132              
133             sub add_property {
134 30     30 0 75 my ( $self, @args ) = @_;
135 30         522 my ( $key, $values ) = validate_pos(
136             @args, {
137             type => SCALAR,
138             }, {
139             type => SCALAR | ARRAYREF,
140             },
141             );
142              
143 30         104 my @new_values;
144 30         33 my $save = undef;
145 30         70 my $old_value = $self->get_property($key);
146 30 100       71 @new_values = ref($values) ? @{$values} : ($values);
  23         259  
147              
148 30 100       63 if ( defined $old_value ) {
149 0         0 $save
150 4 50       20 = [ ( ref($old_value) ? @{$old_value} : $old_value ), @new_values ];
151             } ## end if ( defined $old_value)
152             else {
153 26 100       56 if ( $self->{_options}->{force_value_arrayref} ) {
154 1         2 $save = [@new_values];
155             }
156             else {
157 25 100       62 if ( scalar(@new_values) > 1 ) { $save = [@new_values]; }
  3         11  
158 22         35 else { $save = $new_values[0]; }
159             } ## end else [ if ( $self->{_options}...)]
160             } ## end else [ if ( defined $old_value)]
161              
162 30 50       68 return unless defined $save;
163 30         497 $self->{_properties}->{$key} = $save;
164 30         84 return 1;
165             } ## end sub add_property
166              
167             # =====================
168             # QUERY PROPERTIES
169             # =====================
170             sub properties {
171 9     9 1 44 my ( $self, $prefix, $sep ) = @_;
172              
173 9         14 my %props;
174 9         13 my %_props = %{ $self->{_properties} };
  9         67  
175              
176 9 50       24 if ( defined $prefix ) {
177 0 0       0 $sep = '.' unless defined $sep;
178 0         0 $prefix .= ${sep};
179 0         0 foreach my $_prop ( grep { /^${prefix}/x } keys %_props ) {
  0         0  
180 0         0 my $_p = $_prop;
181 0         0 $_p =~ s{^${prefix}}{}gx;
182 0         0 $props{$_p} = $_props{$_prop};
183             } ## end foreach my $_prop ( grep { ...})
184             } ## end if ( defined $prefix )
185             else {
186 9         49 %props = %_props;
187             }
188              
189 9 50       128 return %props if wantarray;
190 0         0 return {%props};
191             } ## end sub properties
192              
193              
194             sub property_names {
195 0     0 1 0 my ( $self, $prefix ) = @_;
196 0         0 my %props = $self->properties();
197 0         0 my $_sorter = $self->{_options}->{save_sorter};
198 0         0 my @names = sort $_sorter keys %props;
199 0 0       0 if ( defined $prefix ) {
200 0         0 @names = grep { /^${prefix}/x } @names;
  0         0  
201             }
202 0         0 return @names;
203             } ## end sub property_names
204              
205              
206             sub is_empty {
207 0     0 1 0 my ($self) = @_;
208 0         0 my @keys = $self->property_names();
209 0 0       0 return if scalar(@keys);
210 0         0 return 1;
211             } ## end sub is_empty
212              
213              
214             sub has_property {
215 0     0 1 0 my ( $self, @args ) = @_;
216 0         0 my $val = $self->get_property(@args);
217 0 0       0 return 1 if defined $val;
218 0         0 return;
219             } ## end sub has_property
220              
221             # =====================
222             # CLEAR/DELETE PROPERTY
223             # =====================
224             sub delete_property {
225 7     7 1 10 my ( $self, $key ) = @_;
226 7 50 33     43 return unless ( defined $key and hascontent($key) );
227              
228 7 50       105 return 1 unless exists $self->{_properties}->{$key};
229 0         0 delete $self->{_properties}->{$key};
230 0         0 return 1;
231             } ## end sub delete_property
232              
233              
234             sub clear_properties {
235 1     1 1 4098 my ($self) = @_;
236 1         2 $self->{_properties} = {};
237 1         5 $self->{_seen_files} = {};
238 1         3 return 1;
239             } ## end sub clear_properties
240              
241              
242             sub reset_property {
243 7     7 1 17 my ( $self, @args ) = @_;
244 7 50       24 $self->delete_property(@args) or return;
245 7 50       20 $self->add_property(@args) or return;
246 7         20 return 1;
247             } ## end sub reset_property
248              
249             # =====================
250             # SAVE PROPERTIES
251             # =====================
252             sub save_to_string {
253 3     3 1 17 my ( $self, @args ) = @_;
254              
255             # Process Options
256 3         6 my %options = %{ $self->_set_options(@args) };
  3         14  
257              
258             # Get string to save
259 3         28 my $save_string = $self->_save(
260             {
261             options => \%options,
262             }
263             );
264              
265 3         63 return $save_string;
266             } ## end sub save_to_string
267              
268              
269             sub save {
270 1     1 1 864 my ( $self, $to, @args ) = @_;
271 1 50       5 return unless defined $to;
272              
273             # Get a string dump
274 1         8 my $str = $self->save_to_string(@args);
275              
276             # Write to file/handle
277 1         7 write_file(
278             $to, {
279             binmode => ':utf8',
280             },
281             Encode::encode_utf8($str)
282             );
283              
284             # Done
285 1         235 return 1;
286             } ## end sub save
287              
288             # =====================
289             # FILES PROCESSED
290             # =====================
291             sub get_files_loaded {
292 3     3 1 20 my ($self) = @_;
293 3         4 my @files = sort { lc $a cmp lc $b } keys %{ $self->{_seen_files} };
  4         13  
  3         16  
294 3         11 return @files;
295             } ## end sub get_files_loaded
296              
297             #######################
298             # METHOD ALIASES
299             #######################
300              
301             ## no critic (ArgUnpacking)
302              
303 0     0 0 0 sub load_fh { return shift->load(@_); }
304 2     2 1 11 sub load_file { return shift->load(@_); }
305 0     0 0 0 sub store { return shift->save(@_); }
306 0     0 0 0 sub save_as_string { return shift->save_to_string(@_); }
307 0     0 0 0 sub saveToString { return shift->save_to_string(@_); }
308 0     0 0 0 sub getProperty { return shift->get_property(@_); }
309 0     0 0 0 sub addProperty { return shift->add_property(@_); }
310 0     0 0 0 sub requireProperty { return shift->require_property(@_); }
311 7     7 0 51 sub set_property { return shift->reset_property(@_); }
312 0     0 0 0 sub setProperty { return shift->reset_property(@_); }
313 0     0 0 0 sub changeProperty { return shift->reset_property(@_); }
314 0     0 0 0 sub clear { return shift->clear_properties(@_); }
315 0     0 0 0 sub clearProperty { return shift->delete_property(@_); }
316 0     0 0 0 sub deleteProperty { return shift->delete_property(@_); }
317 0     0 0 0 sub containsKey { return shift->has_property(@_); }
318 0     0 0 0 sub getProperties { return shift->properties(@_); }
319 0     0 0 0 sub subset { return shift->properties(@_); }
320 0     0 0 0 sub getKeys { return shift->property_names(@_); }
321 0     0 0 0 sub propertyNames { return shift->property_names(@_); }
322 0     0 0 0 sub getFileNames { return shift->get_files_loaded(@_); }
323 0     0 0 0 sub isEmpty { return shift->is_empty(@_); }
324              
325             ## use critic
326              
327             #######################
328             # INTERNAL METHODS
329             #######################
330              
331             # =====================
332             # Process options
333             # =====================
334             sub _set_options {
335 16     16   53 my ( $self, @args ) = @_;
336              
337             # Read Options
338 16         31 my $in_options = {};
339 16 100       50 if (@args) {
340 8 100       30 if ( ref $args[0] eq 'HASH' ) {
341 3         4 $in_options = $args[0];
342             }
343             else {
344 5         24 $in_options = {@args};
345             }
346             } ## end if (@args)
347              
348             # ---------------------
349             # PARAM SPEC
350             # ---------------------
351              
352             # Load spec
353             my %pv_load_spec = (
354              
355             # List delimiter - this identifies multi-token values
356             token_delimiter => {
357             optional => 1,
358             type => SCALAR | UNDEF,
359             default => ',',
360             },
361              
362             # Include keyword
363             include_keyword => {
364             optional => 1,
365             type => SCALAR,
366             regex => qr{^[^\s]+$}x,
367             default => 'include',
368             },
369              
370             # Include basedir
371             includes_basepath => {
372             optional => 1,
373             type => SCALAR | UNDEF,
374             default => undef,
375             },
376              
377             # Process Includes?
378             process_includes => {
379             optional => 1,
380             type => SCALAR,
381             regex => qr{^[01]$}x,
382             default => 1,
383             },
384              
385             # Allow recursive includes?
386             cache_files => {
387             optional => 1,
388             type => SCALAR,
389             regex => qr{^[01]$}x,
390             default => 1,
391             },
392              
393             # Process property interpolation?
394             interpolation => {
395             optional => 1,
396             type => SCALAR,
397             regex => qr{^[01]$}x,
398             default => 1,
399             },
400              
401             # Force values to be array-refs
402             force_value_arrayref => {
403             optional => 1,
404             type => SCALAR,
405             regex => qr{^[01]$}x,
406             default => 0,
407             },
408              
409             # Allow callback
410             callback => {
411             optinal => 1,
412             type => CODEREF,
413 23     23   57 default => sub { return @_; },
414             },
415              
416             # Allow defaults
417 16         757 defaults => {
418             optional => 1,
419             type => HASHREF,
420             default => {},
421             },
422              
423             # Allow filename for auto-load
424             load_file => {
425             optional => 1,
426             type => SCALAR | HANDLE | UNDEF,
427             default => undef,
428             },
429             );
430              
431             # Save Spec
432             my %pv_save_spec = (
433              
434             # Save properties with multiple value tokens on a single line
435             save_combine_tokens => {
436             optional => 1,
437             type => SCALAR,
438             regex => qr{^[01]$}x,
439             default => 0,
440             },
441              
442             # Wrap and save
443             save_wrapped => {
444             optional => 1,
445             type => SCALAR,
446             regex => qr{^[01]$}x,
447             default => 1,
448             },
449              
450             # Wrap length
451             save_wrapped_len => {
452             optional => 1,
453             type => SCALAR,
454             regex => qr{^\d+$}x,
455             default => 76,
456             },
457              
458             # key=value separator
459             save_separator => {
460             optional => 1,
461             type => SCALAR,
462             regex => qr{^\s*[=:\s]\s*$}x,
463             default => ' = ',
464             },
465              
466             # Save sorting routine
467             save_sorter => {
468             optional => 1,
469             type => CODEREF,
470 17     17   30 default => sub ($$) { lc( $_[0] ) cmp lc( $_[1] ); },
471             },
472              
473             # Save Header
474 16         446 save_header => {
475             optional => 1,
476             type => SCALAR,
477             default => '#' x 15,
478             },
479              
480             # Save footer
481             save_footer => {
482             optional => 1,
483             type => SCALAR,
484             default => '#' x 15,
485             },
486             );
487              
488             # Option aliases
489 16         254 my %option_aliases = (
490              
491             # __PACKAGE__
492             delimiter => 'token_delimiter',
493             include => 'include_keyword',
494             basepath => 'includes_basepath',
495             includes_allow => 'process_includes',
496             cache => 'cache_files',
497             interpolate => 'interpolation',
498             force_arrayref => 'force_value_arrayref',
499             validate => 'callback',
500             filename => 'load_file',
501             single_line => 'save_combine_tokens',
502             wrap => 'save_wrapped',
503             columns => 'save_wrapped_len',
504             separator => 'save_separator',
505             header => 'save_header',
506             footer => 'save_footer',
507              
508             # Java Style
509             setListDelimiter => 'token_delimiter',
510             setInclude => 'include_keyword',
511             setIncludesAllowed => 'process_includes',
512             setBasePath => 'includes_basepath',
513             );
514              
515             # Normalizer
516             # Allow leading '-' and make case-insensitive
517             my $pv_key_normalizer = sub {
518 502     502   706 my ($_key) = @_;
519 502         1149 $_key = no_space($_key);
520 502         2863 $_key =~ s{^\-+}{}x;
521 502         703 $_key = lc($_key);
522 502         2028 return $_key;
523 16         91 };
524              
525             # ---------------------
526              
527             # Merge Options
528 16         59 my $merged_options = $self->{_options};
529 16         27 foreach my $_opt ( keys %{$in_options} ) {
  16         72  
530              
531             # Normalize
532 58         117 $_opt = $pv_key_normalizer->($_opt);
533              
534             # Resolve Aliases
535 58 100       126 if ( exists $option_aliases{$_opt} ) {
536 17         33 $merged_options->{ $option_aliases{$_opt} }
537             = $in_options->{$_opt};
538             } ## end if ( exists $option_aliases...)
539             else {
540 41         97 $merged_options->{$_opt} = $in_options->{$_opt};
541             }
542             } ## end foreach my $_opt ( keys %{$in_options...})
543              
544 16         610 my %valid_options = validate_with(
545              
546             # Name used in validation errors
547             called => __PACKAGE__ . '::_set_options',
548              
549             # Options to process
550             params => [$merged_options],
551              
552             # Normalize key names.
553             normalize_keys => $pv_key_normalizer,
554              
555             # Do not Allow extra options
556             allow_extra => 0,
557              
558             # Option Spec
559             spec => { %pv_load_spec, %pv_save_spec, },
560              
561             );
562              
563 16         7868 return {%valid_options};
564             } ## end sub _set_options
565              
566             # =====================
567             # Load Properties
568             # =====================
569             sub _load {
570 6     6   12 my ( $self, $in ) = @_;
571 6 50       22 my @lines = $in->{lines} ? @{ $in->{lines} } : ();
  6         21  
572 6 50       19 my %options = $in->{options} ? %{ $in->{options} } : ();
  6         66  
573              
574             # Check for empty file
575 6 50       27 return 1 unless @lines;
576              
577             # Check and remote byte order mark
578 6 50       22 if ( $lines[0] =~ m{^\x{FEFF}}x ) { shift @lines; }
  0         0  
579              
580             # Process lines
581 6         23 while (@lines) {
582              
583             # Get line
584 50         140 my $line = shift @lines;
585              
586             # Remove EOL
587 50         120 $line = fullchomp($line);
588              
589             # Skip Blank
590 50 100       368 next unless hascontent($line);
591              
592             # Skip Comments
593 36 100       378 next if ( $line =~ m{^\s*(?:\#|\!)}x );
594              
595             # Trim leading whitespace
596 23         60 $line = trim(
597             $line,
598             right => 0,
599             );
600              
601             # Check for wrapped lines
602 23 100       356 if ( $line =~ m{(?
603              
604             # This is a wrapped line. Unwrap
605 2         5 push( my @wrapped_lines, $line );
606 2         9 while (@lines) {
607 2         5 my $_wline = shift @lines;
608 2         8 $_wline = fullchomp($_wline);
609 2 50       19 next unless hascontent($_wline);
610              
611 2         17 push @wrapped_lines, $_wline;
612 2 50       14 last unless ( $_wline =~ m{(?
613             } ## end while (@lines)
614              
615             # Join them
616 2         4 my @unwrapped;
617 2         5 foreach my $_wline (@wrapped_lines) {
618              
619             # Remove Trailing '\'
620 4         28 $_wline =~ s{\\\s*$}{}x;
621              
622             # Remove leading whitespace
623 4         11 $_wline = trim(
624             $_wline,
625             right => 0,
626             );
627              
628             # Save
629 4         55 push @unwrapped, $_wline;
630             } ## end foreach my $_wline (@wrapped_lines)
631              
632 2         9 $line = join( '', @unwrapped );
633             } ## end if ( $line =~ m{(?
634              
635             # Split key/value
636 23         46 my ( $key, $value ) = split( _sep_regex(), $line, 2 );
637              
638             # Verify key/value
639             # Key is required. Value can be empty
640 23 50 33     105 if ( not( defined $key and hascontent($key) ) ) {
641 0         0 croak "Invalid key/value format! : $line \n";
642             }
643 23 100 100     238 $value = '' unless ( defined $value and hascontent($value) );
644              
645             # Unescape
646 23         180 $key = _unesc_key($key);
647 23         43 $value = _unesc_val($value);
648              
649             # Perform callback
650 23         60 ( $key, $value ) = $options{callback}->( $key, $value );
651             next
652 23 50 33     145 unless ( ( defined $key and defined $value ) and hascontent($key) );
      33        
653              
654             # Process tokens
655 23         183 my @tokens;
656 23 100       46 if ( hascontent($value) ) {
657 21 50       151 if ( defined $options{token_delimiter} ) {
658 21         30 my $_delim = $options{token_delimiter};
659 21         39 foreach my $_token ( _split_tokens( $value, $_delim ) ) {
660 24         48 push( @tokens, _unesc_delim( $_token, $_delim ) );
661             }
662             } ## end if ( defined $options{...})
663             else {
664 0         0 push( @tokens, $value );
665             }
666             } ## end if ( hascontent($value...))
667             else {
668 2         14 push( @tokens, $value );
669             }
670              
671             # Interpolate tokens
672 23         41 my @interpolated_tokens;
673 23 50       46 if ( $options{interpolation} ) {
674 23         72 foreach my $token (@tokens) {
675 26         46 $token
676 2         10 =~ s/(?_interpolate({key => $1, options => \%options,}) /gex;
677 26         63 push( @interpolated_tokens, $token );
678             } ## end foreach my $token (@tokens)
679             } ## end if ( $options{interpolation...})
680             else {
681 0         0 push( @interpolated_tokens, @tokens );
682             }
683              
684             # Process includes
685 23 100 100     133 if ( $options{process_includes}
686             and ( $key eq $options{include_keyword} ) )
687             {
688              
689 2         6 my $_basedir = $self->{_current_file}->{base};
690 2 50       7 $_basedir = File::Spec->curdir() if not $_basedir;
691 2 100       7 $_basedir = $options{includes_basepath}
692             if defined $options{includes_basepath};
693              
694 2         6 foreach my $_file (@interpolated_tokens) {
695              
696             # Determine if filename is absolute or relative
697 2 50       28 if ( File::Spec->file_name_is_absolute($_file) ) {
698 0         0 $_file = abs_path($_file);
699             }
700             else {
701 2         277 $_file
702             = abs_path( File::Spec->catfile( $_basedir, $_file ) );
703             } ## end else [ if ( File::Spec->file_name_is_absolute...)]
704              
705             # Check if this is the current file being processed
706 2 50       10 if ( $_file eq $self->{_current_file}->{name} ) {
707              
708             # Skip it. Otherwise this is an infinite loop
709 0         0 next;
710             } ## end if ( $_file eq $self->...)
711              
712             # Load file
713 2         4 my %tmp_cf = %{ $self->{_current_file} };
  2         9  
714 2         9 $self->load_file( $_file, \%options );
715 2         13 $self->{_current_file} = {%tmp_cf};
716             } ## end foreach my $_file (@interpolated_tokens)
717              
718             # Move onto next line
719             # i.e., do not save an 'include'
720 2         8 next;
721             } ## end if ( $options{process_includes...})
722              
723             # Save key/value
724 21         42 my $tmp_fvaf = $self->{_options}->{force_value_arrayref};
725 21         36 $self->{_options}->{force_value_arrayref}
726             = $options{force_value_arrayref};
727 21         64 $self->add_property( $key, [@interpolated_tokens] );
728 21         83 $self->{_options}->{force_value_arrayref} = $tmp_fvaf;
729             } ## end while (@lines)
730              
731 6         31 return 1;
732             } ## end sub _load
733              
734             # =====================
735             # Interpolate tokens
736             # =====================
737             sub _interpolate {
738 2     2   3 my ( $self, $in ) = @_;
739 2         4 my $key = $in->{key};
740 2         2 my %options = %{ $in->{options} };
  2         50  
741              
742             # Defaults to original
743 2         7 my $int_key = '${' . $key . '}';
744              
745             # Return if key is not set
746 2 50       7 if ( not exists $self->{_properties}->{$key} ) {
747 0         0 return $int_key;
748             }
749              
750             # Get defined key
751 2         6 my $def_key = $self->{_properties}->{$key};
752              
753             # Check if defined key is a refernce
754 2 50       4 if ( ref $def_key ) {
755              
756             # Return if defined key has multiple values
757 0 0       0 return $int_key if ( scalar( @{$def_key} ) > 1 );
  0         0  
758              
759             # Do interpolation if we are forcing array refs
760 0 0       0 if ( $options{force_value_arrayref} ) {
761 0         0 $int_key = $def_key->[0];
762             }
763             } ## end if ( ref $def_key )
764             else {
765 2         3 $int_key = $def_key;
766             }
767              
768             # Return empty if undef
769 2 50       5 return '' unless defined $int_key;
770 2         10 return $int_key;
771             } ## end sub _interpolate
772              
773             # =====================
774             # Save Properties
775             # =====================
776             sub _save {
777 3     3   8 my ( $self, $in ) = @_;
778 3         4 my %options = %{ $in->{options} };
  3         29  
779              
780             # Output String
781 3         7 my $out_str;
782              
783             # Get flattened hash
784 3         12 my %props = $self->properties();
785              
786             # Write Header
787 3         16 $out_str = fullchomp( $options{save_header} ) . "\n\n";
788              
789             # Get max property length
790 3         31 my $max_prop_len = max map { length $_ } ( keys %props );
  14         41  
791              
792             # Get key/value separator
793 3         8 my $out_sep = $options{save_separator};
794              
795             # Get separator length
796 3         5 my $sep_len = length( $options{save_separator} );
797              
798             # Do wrap?
799 3         5 my $do_wrap = $options{save_wrapped};
800 3 50       13 $do_wrap = 0
801             if ( ( $max_prop_len + $sep_len + 4 ) >= $options{save_wrapped_len} );
802              
803             # Cycle thru' properties
804 3         6 my $_sorter = $options{save_sorter};
805 3         15 foreach my $key ( sort $_sorter keys %props ) {
806 14 50       35 next unless defined $props{$key};
807 14         20 my $value = $props{$key};
808 14 50       27 $value = '' if not defined $value;
809              
810             # Split value into tokens
811 14         22 my @raw_value_tokens;
812 14 100       27 if ( ref($value) ) {
813 5 50       15 croak "${key}'s value is an invalid reference!"
814             unless ( ref($value) eq 'ARRAY' );
815 5         6 @raw_value_tokens = @{$value};
  5         16  
816             } ## end if ( ref($value) )
817             else {
818 9         17 @raw_value_tokens = ($value);
819             }
820              
821             # Escape
822 14         29 $key = _esc_key($key);
823 14         15 my @value_tokens;
824 14         21 foreach my $_rvt (@raw_value_tokens) {
825 19 50       35 $_rvt = '' unless defined $_rvt;
826 19 50       42 if ( defined $options{token_delimiter} ) {
827 19         51 push @value_tokens,
828             _esc_delim( _esc_val( Encode::encode_utf8($_rvt) ),
829             $options{token_delimiter} );
830             } ## end if ( defined $options{...})
831             else {
832 0         0 push @value_tokens, _esc_val( Encode::encode_utf8($_rvt) );
833             }
834             } ## end foreach my $_rvt (@raw_value_tokens)
835              
836             # Save
837 14 100       47 if ( $options{save_combine_tokens} ) {
838 5 50       11 croak "Cannot combine tokens without a delimiter!"
839             unless defined $options{token_delimiter};
840              
841             # Get delimiter
842             # Append a whitespace to it for read-ability
843 5         9 my $_delim = $options{token_delimiter};
844 5 50       16 $_delim .= ' ' unless ( $_delim =~ m{\s+$}x );
845              
846             # Join
847 5         9 my $_val_str = join( $_delim, @value_tokens );
848              
849             # Wrap
850 5 50       11 if ($do_wrap) {
851 5         65 $_val_str = _wrap(
852             {
853             string => $_val_str,
854             options => {
855             %options,
856             key_len => length($key) + $sep_len,
857             },
858             }
859             );
860             } ## end if ($do_wrap)
861              
862             # Write
863 5         54 $out_str .= sprintf( "%s${out_sep}%s\n", $key, $_val_str );
864             } ## end if ( $options{save_combine_tokens...})
865             else {
866              
867             # Add surrounding blank lines for read-ability
868 9 100       28 if ( scalar(@value_tokens) > 1 ) {
869 3 50       30 $out_str .= "\n" unless ( $out_str =~ m{\n{2,}}mx );
870             }
871              
872 9         13 foreach my $token (@value_tokens) {
873 12         14 my $_val_str;
874              
875             # Wrap
876 12 50       18 if ($do_wrap) {
877 12         131 $_val_str = _wrap(
878             {
879             string => $token,
880             options => {
881             %options,
882             key_len => length($key) + $sep_len,
883             },
884             }
885             );
886             } ## end if ($do_wrap)
887 0         0 else { $_val_str = $token; }
888              
889             # Write
890 12         100 $out_str .= sprintf( "%s${out_sep}%s\n", $key, $_val_str );
891             } ## end foreach my $token (@value_tokens)
892              
893             # Add surrounding blank lines for read-ability
894 9 100       43 if ( scalar(@value_tokens) > 1 ) { $out_str .= "\n"; }
  3         9  
895             } ## end else [ if ( $options{save_combine_tokens...})]
896             } ## end foreach my $key ( sort $_sorter...)
897              
898             # Write footer
899 3         15 $out_str .= "\n" . fullchomp( $options{save_footer} ) . "\n\n";
900              
901             # Done
902 3         36 return $out_str;
903             } ## end sub _save
904              
905             #######################
906             # INTERNAL UTILS
907             #######################
908              
909             # =====================
910             # Seperator regex
911             # =====================
912             sub _sep_regex {
913              
914             # Split key-value that is seperated by:
915             # 1. '='
916             # 2. ':'
917             # 3. Whitespace
918             # Where neither of them are backslash escaped
919             # Also, any surrounding whitespace is ignored
920 23     23   292 return qr{\s*(?: (?: (?
921             } ## end sub _sep_regex
922              
923             # =====================
924             # Escape Routines
925             # =====================
926             sub _esc_key {
927 14     14   17 my ($key) = @_;
928              
929             # Escape unprintable
930 14         27 $key =~ s{([^\x20-\x7e])}{sprintf ("\\u%04x", ord $1)}gex;
  0         0  
931              
932             # Escape leading '#'
933 14         25 $key =~ s{^\#}{'\#'}gex;
  0         0  
934              
935             # Escape leading '!'
936 14         19 $key =~ s{^\!}{'\!'}gex;
  0         0  
937              
938             # Escape whitespace
939 14         18 $key =~ s{\s}{'\ '}gex;
  0         0  
940              
941 14         27 return $key;
942             } ## end sub _esc_key
943              
944              
945             sub _esc_val {
946 19     19   108 my ($val) = @_;
947              
948             # Escape unprintable
949 19         33 $val =~ s{([^\x20-\x7e])}{sprintf ("\\u%04x", ord $1)}gex;
  1         9  
950              
951 19         55 return $val;
952             } ## end sub _esc_val
953              
954              
955             sub _esc_delim {
956 19     19   25 my ( $val, $delim ) = @_;
957 19 50       42 return $val if not defined $delim;
958 19 50       44 return $val if not hascontent($delim);
959 19 100       159 return $val if not hascontent($val);
960 18         142 return join( "\\$delim ", _split_tokens( $val, $delim ) );
961             } ## end sub _esc_delim
962              
963             # =====================
964             # Unescape Routines
965             # =====================
966             sub _unesc_key {
967 23     23   31 my ($key) = @_;
968              
969             # Un-escape unprintable
970 23         53 $key =~ s{\\u([\da-fA-F]{4})}{chr(hex($1))}gex;
  0         0  
971              
972             # Un-escape leading '#'
973 23         33 $key =~ s{^\\\#}{'#'}gex;
  0         0  
974              
975             # Un-escape leading '!'
976 23         33 $key =~ s{^\\!}{'!'}gex;
  0         0  
977              
978             # Un-escape whitespace
979 23         31 $key =~ s{(?
  0         0  
980              
981 23         40 return $key;
982             } ## end sub _unesc_key
983              
984              
985             sub _unesc_val {
986 23     23   29 my ($val) = @_;
987              
988             # Un-escape unprintable
989 23         38 $val =~ s{\\u([\da-fA-F]{4})}{chr(hex($1))}gex;
  1         10  
990              
991 23         36 return $val;
992             } ## end sub _unesc_val
993              
994              
995             sub _unesc_delim {
996 24     24   33 my ( $val, $delim ) = @_;
997 24         76 $val =~ s{ \\ $delim }{$delim}gxi;
998 24         78 return $val;
999             } ## end sub _unesc_delim
1000              
1001             # =====================
1002             # VALUE WRAPPER
1003             # =====================
1004             sub _wrap {
1005 17     17   23 my ($in) = @_;
1006 17         34 my $text = $in->{string};
1007 17         21 my %options = %{ $in->{options} };
  17         144  
1008              
1009             # Wrap column width
1010 17         46 my $wrap_to = $options{save_wrapped_len} - $options{key_len};
1011              
1012             ## no critic (PackageVars)
1013              
1014             # Text::Wrap settings
1015 17         25 local $Text::Wrap::columns = $wrap_to; # Columns
1016 17         50 local $Text::Wrap::break = qr{(?
1017 17         21 local $Text::Wrap::unexpand = 0; # Don't mess with tabs
1018 17         23 local $Text::Wrap::separator = "\\\n"; # Use a '\' separator
1019 17         19 local $Text::Wrap::huge = 'overflow'; # Leave unbreakable lines alone
1020              
1021             ## use critic
1022              
1023             # Wrap
1024 17         75 my $wrapped = Text::Wrap::wrap(
1025             '', # Initial tab is empty
1026             ' ' x ( $options{key_len} + 1 ), # Subseq tab is aligned to end of key
1027             $text, # Text to wrap
1028             );
1029              
1030             # Remove EOL
1031 17         1746 $wrapped = fullchomp($wrapped);
1032              
1033             # Return
1034 17         214 return $wrapped;
1035             } ## end sub _wrap
1036              
1037             # =====================
1038             # TOKEN SPLITTER
1039             # =====================
1040             sub _split_tokens {
1041 39     39   56 my ( $val, $delim ) = @_;
1042 39         410 return split( qr/(?
1043             } ## end sub _split_tokens
1044              
1045             #######################
1046             1;
1047              
1048             __END__