File Coverage

blib/lib/Config/Model/Backend/Any.pm
Criterion Covered Total %
statement 102 110 92.7
branch 34 38 89.4
condition n/a
subroutine 14 16 87.5
pod 6 8 75.0
total 156 172 90.7


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model
3             #
4             # This software is Copyright (c) 2005-2022 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10              
11             use v5.20;
12 9     9   1731  
  9         28  
13             use Carp;
14 9     9   40 use Config::Model::Exception;
  9         13  
  9         431  
15 9     9   49 use Mouse;
  9         14  
  9         175  
16 9     9   47  
  9         22  
  9         52  
17             use File::Path;
18 9     9   2369 use Log::Log4perl qw(get_logger :levels);
  9         19  
  9         481  
19 9     9   50  
  9         17  
  9         54  
20             use feature qw/postderef signatures/;
21 9     9   1056 no warnings qw/experimental::postderef experimental::signatures/;
  9         17  
  9         933  
22 9     9   64  
  9         20  
  9         11147  
23             my $logger = get_logger("Backend");
24              
25             has 'name' => ( is => 'ro', default => 'unknown', );
26             has [qw/annotation auto_create auto_delete/] => ( is => 'ro', isa => 'Bool', default => 0 );
27             has 'node' => (
28             is => 'ro',
29             isa => 'Config::Model::Node',
30             weak_ref => 1,
31             required => 1,
32             handles => [ qw/show_message instance get_element_names/],
33             );
34              
35              
36 208     208 0 883 my $self = shift;
37             my $err = "Internal error: read not defined in backend $self->{name}.";
38             $logger->error($err);
39 0     0 1 0 croak $err;
40 0         0 }
41 0         0  
42 0         0 my $self = shift;
43             my $err = "Internal error: write not defined in backend $self->{name}.";
44             $logger->error($err);
45             croak $err;
46 0     0 1 0 }
47 0         0  
48 0         0 my $self = shift;
49 0         0 my $lines = shift;
50             my $cc = shift; # comment character(s)
51              
52             my $cc_re = length $cc > 1 ? "[$cc]" : $cc;
53 54     54 1 127 my @global_comments;
54 54         95 my @global_comment_lines;
55 54         96  
56             while ( defined( my $l = shift @$lines ) ) {
57 54 100       203 next if $l =~ /^$cc_re{2}/; # remove comments added by Config::Model
58 54         124 unshift @$lines, $l;
59             last;
60             }
61 54         198 while ( defined( my $l = shift @$lines ) ) {
62 121 100       823 next if $l =~ /^\s*$/; # remove empty lines
63 54         150 unshift @$lines, $l;
64 54         133 last;
65             }
66 54         180  
67 76 100       397 while ( defined( my $l = shift @$lines ) ) {
68 54         112 chomp $l;
69 54         103  
70             my ( $data, $comment ) = split /\s*$cc_re\s?/, $l, 2;
71              
72 54         194 if (defined $comment) {
73 103         212 push @global_comment_lines, $l;
74             push @global_comments, $comment;
75 103         650 }
76              
77 103 100       239 if ( $l =~ /^\s*$/ ) {
78 50         102 # we indeed had global comments which are now finished by
79 50         83 # a blank line. Store them and bail out
80             if (@global_comments) {
81             $self->node->annotation(@global_comments);
82 103 100       341 $logger->debug("Setting global comment with @global_comments on ", $self->node->name);
83             }
84             # stop global comment at first blank line
85 23 50       84 last;
86 23         280 }
87 23         193 if ( $data ) {
88             # The comment found is not global, put back line and any captured comment
89             unshift @$lines, @global_comment_lines, $l;
90 23         238  
91             # stop global comment
92 80 100       230 last;
93             }
94 31         67 }
95             }
96              
97 31         90 my $self = shift;
98             my $lines = shift;
99             my $cc = shift; # comment character(s)
100              
101             my $cc_re = length $cc > 1 ? "[$cc]" : $cc;
102             my @result;
103 53     53 1 112 my @comments;
104 53         78 foreach my $l (@$lines) {
105 53         110 next if $l =~ /^$cc_re{2}/; # remove comments added by Config::Model
106             chomp $l;
107 53 100       140  
108 53         107 my ( $data, $comment ) = split /\s*$cc_re\s?/, $l, 2;
109             push @comments, $comment if defined $comment;
110 53         169  
111 688 100       1671 next unless defined $data;
112 685         867 $data =~ s/^\s+//g;
113             $data =~ s/\s+$//g;
114 685         1863  
115 685 100       1147 if ($data) {
116             my $note = '';
117 685 100       1039 $note = join( "\n", @comments ) if @comments;
118 570         899 $logger->trace("associates_comments_with_data: '$note' with '$data'");
119 570         1139 push @result, [ $data, $note ];
120             @comments = ();
121 570 100       912 }
122 402         501 }
123 402 100       795  
124 402         1417 return wantarray ? @result : \@result;
125 402         2771  
126 402         738 }
127              
128             goto &write_global_comments;
129             }
130 53 50       246  
131             croak "write_global_comments: no comment char specified" unless $cc;
132              
133             # no need to mention 'cme list' if current application is found
134             my $app = $self->node->instance->application ;
135 28     28 0 99 my $extra = '' ;
136             if (not $app) {
137             $extra = "$cc$cc Run 'cme list' to get the list of applications"
138 28     28 1 60 . " available on your system\n";
  28         45  
  28         64  
  28         40  
139 28 50       92 $app = '<application>';
140             }
141              
142 28         207 my $res = "$cc$cc This file was written by cme command.\n"
143 28         65 . "$cc$cc You can run 'cme edit $app' to modify this file.\n"
144 28 100       73 . $extra
145 13         35 . "$cc$cc You may also modify the content of this file with your favorite editor.\n\n";
146              
147 13         21 # write global comment
148             my $global_note = $self->node->annotation;
149             if ($global_note) {
150 28         151 for ( split /\n/, $global_note ) { $res .= "$cc $_\n" }
151             $res .= "\n";
152             }
153              
154             return $res;
155             }
156 28         123  
157 28 100       80 # $cc can be undef when writing a list on a single line
158 11         81 my $res = '';
  26         89  
159 11         29 while (@data_and_comments) {
160             my ( $d, $c ) = splice @data_and_comments, 0, 2;
161             if ($c) {
162 28         170 for (split /\n/, $c ) { $res .= "$cc $_\n" }
163             }
164             $res .= "$d\n" if defined $d;
165             }
166 157     157 1 237 return $res;
  157         199  
  157         212  
  157         251  
  157         193  
167 157         226 }
168 157         386  
169 157         370 __PACKAGE__->meta->make_immutable;
170 157 100       304  
171 61         214 1;
  67         206  
172              
173 157 50       548 # ABSTRACT: Virtual class for other backends
174              
175 157         544  
176             =pod
177              
178             =encoding UTF-8
179              
180             =head1 NAME
181              
182             Config::Model::Backend::Any - Virtual class for other backends
183              
184             =head1 VERSION
185              
186             version 2.151
187              
188             =head1 SYNOPSIS
189              
190             package Config::Model::Backend::Foo ;
191             use Mouse ;
192              
193             extends 'Config::Model::Backend::Any';
194              
195             # mandatory
196             sub read {
197             my $self = shift ;
198             my %args = @_ ;
199              
200             # args are:
201             # root => './my_test', # fake root directory, used for tests
202             # config_dir => /etc/foo', # absolute path
203             # file => 'foo.conf', # file name
204             # file_path => Path::Tiny object for './my_test/etc/foo/foo.conf'
205             # check => yes|no|skip
206              
207             return 0 unless $args{file_path}->exists ; # or die, your choice
208              
209             # read the file line by line
210             # we assume the file contain lines like 'key=value'
211             foreach ($args{file_path}->lines_utf8) {
212             chomp ; # remove trailing \n
213             s/#.*// ; # remove any comment
214             next unless /\S/; # skip blank line
215              
216             # $data is 'foo=bar' which is compatible with load
217             $self->node->load(steps => $_, check => $args{check} ) ;
218             }
219             return 1 ;
220             }
221              
222             # mandatory
223             sub write {
224             my $self = shift ;
225             my %args = @_ ;
226              
227             # args are:
228             # root => './my_test', # fake root directory, used for tests
229             # config_dir => /etc/foo', # absolute path
230             # file => 'foo.conf', # file name
231             # file_path => Path::Tiny object for './my_test/etc/foo/foo.conf'
232             # check => yes|no|skip
233              
234             # read the content of the configuration tree
235             my @lines;
236             foreach my $elt ($self->node->children) {
237             # read the value from element $elt
238             my $v = $self->node->grab_value($elt) ;
239              
240             # write value in file
241             push @lines,qq!$elt="$v"\n! if defined $v ;
242             }
243              
244             $args{file_path}->spew_utf8(@lines);
245             return 1;
246             }
247              
248             =head1 DESCRIPTION
249              
250             Some application have configuration files with a syntax which is not
251             supported by existing C<Config::Model::Backend::*> classes.
252              
253             In this case a new backend must be
254             written. C<Config::Model::Backend::Any> was created to facilitate this
255             task.
256              
257             The new backend class must use L<Mouse> and must extends (inherit)
258             C<Config::Model::Backend::Any>.
259              
260             =head1 How to write your own backend
261              
262             =head2 Declare the new backend in a node of the model
263              
264             As explained in L<Config::Model::BackendMgr/"Backend specification">, the
265             new backend must be declared as an attribute of a
266             L<Config::Model::Node> specification.
267              
268             Let's say your new backend is C<Config::Model::Backend::Foo>. This new backend
269             can be specified with:
270              
271             rw_config => {
272             backend => 'Foo' , # can also be 'foo'
273             config_dir => '/etc/cfg_dir'
274             file => 'foo.conf', # optional
275             }
276              
277             (The backend class name is constructed with C<ucfirst($backend_name)>)
278              
279             C<rw_config> can also have custom parameters that are passed
280             verbatim to C<Config::Model::Backend::Foo> methods:
281              
282             rw_config => {
283             backend => 'Foo' , # can also be 'foo'
284             config_dir => '/etc/cfg_dir'
285             file => 'foo.conf', # optional
286             my_param => 'my_value',
287             }
288              
289             C<Config::Model::Backend::Foo> class must inherit (extend)
290             L<Config::Model::Backend::Any> and is expected to provide the
291             following methods:
292              
293             =over
294              
295             =item read
296              
297             C<read> is called with the following parameters:
298              
299             %custom_parameters, # e.g. my_param => 'my_value' in the example above
300             object => $obj, # Config::Model::Node object
301             root => $root_dir, # fake root directory, used for tests
302             backend => $backend, # backend name
303             config_dir => $read_dir, # path below root
304             file => 'foo.conf', # file name
305             file_path => $full_name, # Path::Tiny object
306             check => [yes|no|skip]
307              
308             The L<IO::File> object is undef if the file cannot be read.
309              
310             This method must return 1 if the read was successful, 0 otherwise.
311              
312             Following the C<my_param> example above, C<%custom_parameters> contains
313             C< ( 'my_param' , 'my_value' ) >, so C<read()> is called with
314             C<root>, C<config_dir>, C<file_path> B<and>
315             C<< my_param => 'my_value' >>.
316              
317             =item write
318              
319             C<write> is called with the following parameters:
320              
321             %$custom_parameters, # e.g. my_param => 'my_value' in the example above
322             object => $obj, # Config::Model::Node object
323             root => $root_dir, # fake root directory, used for tests
324             auto_create => $auto_create, # boolean specified in backend declaration
325             auto_delete => $auto_delete, # boolean specified in backend declaration
326             backend => $backend, # backend name
327             config_dir => $write_dir, # override from instance
328             file => 'foo.conf', # file name
329             file_path => $full_name, # full file name (root+path+file)
330             write => 1, # always
331             check => [ yes|no|skip] ,
332             backup => [ undef || '' || suffix ] # backup strategy required by user
333              
334             The L<IO::File> object is undef if the file cannot be written to.
335              
336             This method must return 1 if the write was successful, 0 otherwise
337              
338             =back
339              
340             =head2 How to test your new backend
341              
342             Using L<Config::Model::Tester>, you can test your model with your
343             backend following the instructions given in L<Config::Model::Tester>.
344              
345             You can also test your backend with a minimal model (and
346             L<Config::Model::Tester>). In this case, you need to specify
347             a small model to test in a C<*-test-conf.pl> file.
348             See the
349             L<IniFile backend test|https://github.com/dod38fr/config-model/blob/master/t/model_tests.d/backend-ini-test-conf.pl>
350             for an example and its
351             L<examples files|https://github.com/dod38fr/config-model/tree/master/t/model_tests.d/backend-ini-examples>.
352              
353             =head1 CONSTRUCTOR
354              
355             =head2 new
356              
357             The constructor should be used only by L<Config::Model::Node>.
358              
359             Parameter:
360              
361             =over
362              
363             =item node
364              
365             Calling node object. Node ref is weakened,
366              
367             =item name
368              
369             Backend name
370              
371             =item auto_create
372              
373             Boolean. Set to true to create the configuration file if this one is
374             missing (default 0)
375              
376             =item auto_delete
377              
378             Boolean. Set to true to remove the configuration file if this one no
379             longer contain configuration information. (default 0)
380              
381             =back
382              
383             =head1 Methods to override
384              
385             =head2 annotation
386              
387             Whether the backend supports reading and writing annotation (a.k.a
388             comments). Default is 0. Override this method to return 1 if your
389             backend supports annotations.
390              
391             =head2 read
392              
393             Read the configuration file. This method must be overridden.
394              
395             =head2 write
396              
397             Write the configuration file. This method must be overridden.
398              
399             =head1 Methods
400              
401             =head2 node
402              
403             Return the node (a L<Config::Model::Node>) holding this backend.
404              
405             =head2 instance
406              
407             Return the instance (a L<Config::Model::Instance>) holding this configuration.
408              
409             =head2 show_message
410              
411             Parameters: C<( string )>
412              
413             Show a message to STDOUT (unless overridden).
414             Delegated to L<Config::Model::Instance/"show_message">.
415              
416             =head2 read_global_comments
417              
418             Parameters:
419              
420             =over
421              
422             =item *
423              
424             array ref of string containing the lines to be parsed
425              
426             =item *
427              
428             A string to specify how a comment is started. Each
429             character is recognized as a comment starter (e.g 'C<#;>' allow a
430             comment to begin with 'C<#>' or 'C<;>')
431              
432             =back
433              
434             Read the global comments (i.e. the first block of comments until the
435             first blank or non comment line) and store them as root node
436             annotation. Note that the global comment must be separated from the
437             first data line by a blank line.
438              
439             Example:
440              
441             $self->read_global_comments( \@lines, ';');
442             $self->read_global_comments( \@lines, '#;');
443              
444             =head2 associates_comments_with_data
445              
446             Parameters:
447              
448             =over
449              
450             =item *
451              
452             array ref of string containing the lines to be parsed
453              
454             =item *
455              
456             A string to specify how a comment is started. Each
457             character is recognized as a comment starter (e.g 'C<#;>' allow a
458             comment to begin with 'C<#>' or 'C<;>')
459              
460             =back
461              
462             This method extracts comments from the passed lines and associate
463             them with actual data found in the file lines. Data is associated with
464             comments preceding or on the same line as the data. Returns a list of
465             [ data, comment ].
466              
467             Example:
468              
469             my @lines = (
470             '# Foo comments',
471             'foo= 1',
472             'Baz = 0 # Baz comments'
473             );
474             my @res = $self->associates_comments_with_data( \@lines, '#')
475             # @res is:
476             # ( [ 'foo= 1', 'Foo comments' ] , [ 'Baz = 0' , 'Baz comments' ] )
477              
478             =head2 write_global_comments
479              
480             Return a string containing global comments using data from
481             configuration root annotation.
482              
483             Requires one parameter: comment_char (e.g "#" or '//' )
484              
485             Example:
486              
487             my $str = $self->write_global_comments('#')
488              
489             =head2 write_data_and_comments
490              
491             Returns a string containing comments (stored in annotation) and
492             corresponding data. Comments are written before the data. If a data is
493             undef, the comment is written on its own line.
494              
495             Positional parameters are C<( comment_char , data1, comment1, data2, comment2 ...)>
496              
497             Example:
498              
499             print $self->write_data_and_comments('#', 'foo', 'foo comment', undef, 'lone comment','bar')
500             # returns "# foo comment\nfoo\n#lon
501              
502             Use C<undef> as comment char if comments are not supported by the
503             syntax of the configuration file. Comments will then be dropped.
504              
505             =head1 Replacing a custom backend
506              
507             Custom backend are now deprecated and must be replaced with a class inheriting this module.
508              
509             Please:
510              
511             =over
512              
513             =item *
514              
515             Rename your class to begin with C<Config::Model::Backend::>
516              
517             =item *
518              
519             Add C<use Mouse ;> and C<extends 'Config::Model::Backend::Any';> in the header of your custom class.
520              
521             =item *
522              
523             Add C<my $self = shift;> as the beginning of C<read> and C<write> functions... well... methods.
524              
525             =back
526              
527             Here's an L<example of such a change|https://github.com/dod38fr/config-model/commit/c3b7007ad386cb2356c5ac1499fe51bdf492b19a>.
528              
529             =head1 AUTHOR
530              
531             Dominique Dumont, (ddumont at cpan dot org)
532              
533             =head1 SEE ALSO
534              
535             L<Config::Model>,
536             L<Config::Model::BackendMgr>,
537             L<Config::Model::Node>,
538              
539             =head1 AUTHOR
540              
541             Dominique Dumont
542              
543             =head1 COPYRIGHT AND LICENSE
544              
545             This software is Copyright (c) 2005-2022 by Dominique Dumont.
546              
547             This is free software, licensed under:
548              
549             The GNU Lesser General Public License, Version 2.1, February 1999
550              
551             =cut