File Coverage

blib/lib/Sphinx/Config.pm
Criterion Covered Total %
statement 326 366 89.0
branch 129 184 70.1
condition 29 53 54.7
subroutine 29 30 96.6
pod 10 10 100.0
total 523 643 81.3


line stmt bran cond sub pod time code
1             package Sphinx::Config;
2              
3 5     5   70180 use warnings;
  5         8  
  5         124  
4 5     5   17 use strict;
  5         5  
  5         121  
5 5     5   20 use Carp qw/croak/;
  5         15  
  5         216  
6 5     5   2456 use Storable qw/dclone/;
  5         10619  
  5         236  
7 5     5   2110 use List::MoreUtils qw/firstidx/;
  5         35770  
  5         29  
8              
9             =head1 NAME
10              
11             Sphinx::Config - Sphinx search engine configuration file read/modify/write
12              
13             =cut
14              
15             our $VERSION = '0.10';
16              
17             =head1 SYNOPSIS
18              
19             use Sphinx::Config;
20              
21             my $c = Sphinx::Config->new();
22             $c->parse($filename);
23             $path = $c->get('index', 'test1', 'path');
24             $c->set('index', 'test1', 'path', $path);
25             $c->save($filename);
26             ...
27              
28             =head1 CONSTRUCTOR
29              
30             =head2 new
31              
32             $c = Sphinx::Config->new;
33              
34             =cut
35              
36             sub new {
37 5     5 1 32 my $class = shift;
38              
39 5   33     36 bless { _bestow => 1 }, ref($class) || $class;
40             }
41              
42             =head2 preserve_inheritance
43              
44             $c->preserve_inheritance(0);
45             $c->preserve_inheritance(1);
46             $pi = $c->preserve_inheritance(1);
47              
48             Set/get the current behaviour for preserving inherited values. When
49             set to a non-zero value (the default), if a value is set in a parent
50             section, then it is automatically inherited by any child sections, and
51             when the configuration file is saved, values that are implicit through
52             inheritance are not shown. When set to zero, each section is
53             considered standalone and a complete set of values is shown in the
54             saved file.
55              
56             This flag may be enabled and disabled selectively for calls to set() and
57             save().
58              
59             =cut
60              
61             sub preserve_inheritance {
62 2     2 1 3 my $self = shift;
63 2 50       8 $self->{_bestow} = shift if @_;
64              
65 2         3 return $self->{_bestow};
66             }
67              
68             =head1 METHODS
69              
70             =head2 parse
71              
72             $c->parse($filename)
73              
74             Parse the given Sphinx configuration file.
75              
76             Dies on errors.
77              
78             =cut
79              
80             sub parse {
81 7     7 1 1727 my ($self, $filename) = @_;
82              
83 7 50       107 die "Sphinx::Config: $filename does not exist" unless -f $filename;
84              
85 7         12 my $fh;
86 7 50       156 open($fh, "<$filename") or die "Sphinx::Config: cannot open $filename: $!";
87 7         1192 $self->{_file} = [ <$fh> ];
88 7         253 close( $fh );
89 7         24 $self->{_filename} = $filename;
90 7         21 $self->_parse_file;
91 7         28 return;
92             }
93              
94             =head2 parse_string
95              
96             $c->parse_string( $string );
97              
98             Parse the Sphinx configuration in the given string.
99              
100             Dies on errors.
101              
102             =cut
103              
104             sub parse_string {
105 3     3 1 2861 my( $self, $string ) = @_;
106             # split string on newlines, keeping the newlines in-place
107 3         27 $self->{_file} = [ split /^/m, $string ];
108 3         14 delete $self->{_filename};
109             # _filename is used by _parse_file in its error messages
110 3         6 local $self->{_filename} = "STRING";
111 3         5 $self->_parse_file;
112 3         9 return;
113             }
114              
115             sub _parse_file
116             {
117 10     10   13 my( $self ) = @_;
118              
119 10         7 my $state = 'outer';
120 10         11 my $seq = "section";
121 10         9 my $max = @{ $self->{_file} };
  10         17  
122 10         8 my $current;
123             my @config;
124              
125 10         26 foreach( my $line = 0; $line < $max ; $line++ ) {
126 2938         1728 my $first = $line;
127 2938         2459 my $input = $self->{_file}[ $line ];
128 2938         1954 chomp $input;
129             # discard comments
130 2938         3564 $input =~ s/\s*\#.*//o;
131             # merge continued lines
132 2938   66     4341 while ($input =~ s!\\\s*$!!s and $line < $max ) {
133 15         11 $line++;
134 15         18 my $new = $self->{_file}[ $line ];
135 15         13 chomp( $new );
136             # We are folding all space up. XXX- How does Sphinx handle this?
137 15 50       31 if( $input =~ / $/ ) {
138 15         31 $new =~ s/^\s+//;
139             } else {
140 0         0 $new =~ s/^\s+/ /;
141             }
142 15         40 $input .= $new;
143             }
144             # handling this virtual line
145 2938         4820 while ($input) {
146 405 100       588 if ($state eq 'outer') {
    50          
147             # split into tokens, fully consuming input line
148 103         170 my @tokens = split(/\s+/, $input);
149 103         81 $input = "";
150 103         125 while( @tokens ) {
151 219         171 my $tok = shift @tokens;
152 219 100       280 next unless length $tok;
153 211 100       387 if ($seq eq "section") {
    100          
    100          
    100          
    50          
154 54 100       152 if ($tok =~ m/^(?:source|index)$/o) {
    50          
155 43         86 $current = { _type => $tok, _lines => [ $first ] };
156 43         44 push(@config, $current);
157 43         71 $seq = "name";
158             }
159             elsif ($tok =~ m/^(?:indexer|searchd|search|common)$/o) {
160 11         25 $current = { _type => $tok, _lines => [ $first ] };
161 11         14 push(@config, $current);
162 11         33 $seq = "openblock";
163             }
164             else {
165 0         0 die "Sphinx::Config: $self->{_filename}:$first: Expected section type, got '$tok'";
166             }
167             }
168             elsif ($seq eq "name") {
169 43         49 $current->{_name} = $tok;
170 43         94 $seq = "openorinherit";
171             }
172             elsif ($seq eq "openorinherit") {
173 43 100       44 if ($tok eq ':') {
174 17         37 $seq = "inherit";
175             }
176             else {
177 26         29 unshift(@tokens, $tok);
178 26         38 $seq = "openblock";
179             }
180             }
181             elsif ($seq eq "inherit") {
182 17 50       27 die "Sphinx::Config:: $self->{_filename}:$line: a section may not inherit from itself"
183             if $tok eq $current->{_name};
184 17 50       41 unless( $self->_setup_inherit( $current, $tok, \@config ) ) {
185 0         0 die "Sphinx::Config: $self->{_filename}:$first: Base section '$tok' does not exist";
186             }
187 17         62 $seq = "openblock";
188             }
189             elsif ($seq eq "openblock") {
190 54 50       70 die "Sphinx::Config: $self->{_filename}:$first: expected '{'" unless $tok eq "{";
191 54         41 $seq = "section";
192 54         53 $state = "inner";
193             # return any leftovers
194 54         180 $input = join(" ", @tokens);
195             }
196             }
197             }
198             elsif ($state eq "inner") {
199 302         297 my $pos = [ $first, $line ];
200 302 100       906 if ($input =~ s/^\s*\}//o) {
    100          
    50          
201 54         46 $state = "outer";
202 54         73 $current->{_lines}[1] = $line;
203 54         133 $current = undef;
204             }
205             elsif ($input =~ s/^\s*([\w]+)\s*=\s*(.*)\s*$//o) {
206 244         251 my $k = $1;
207 244         213 my $v = $2;
208 244 100 100     488 if (exists($current->{_data}->{$k}) && ! $current->{_inherited}->{$k}) {
209 13 50       25 if (ref($current->{_data}->{$k}) eq 'ARRAY') {
210             # append to existing array
211 0         0 push(@{$current->{_data}->{$k}}, $v);
  0         0  
212             }
213             else {
214             # promote to array
215 13         28 $current->{_data}->{$k} = [ $current->{_data}->{$k}, $v ];
216             }
217 13         11 push(@{$current->{_pos}->{$k}}, $pos);
  13         43  
218             }
219             else {
220             # first or simple value
221 231         336 $current->{_data}->{$k} = $v;
222 231         278 $current->{_pos}->{$k} = [$pos];
223 231         594 $current->{_inherited}->{$k} = 0;
224             }
225             }
226             elsif ($input =~ s/^\s+$//o) {
227             # carry on
228             }
229             else {
230 0         0 die "Sphinx::Config: $self->{_filename}:$line: expected name=value pair or end of section, got '$input'";
231             }
232             }
233             }
234             }
235              
236 10         20 $self->{_config} = \@config;
237 10         13 my %keys;
238 10         19 for (@config) {
239 54 100       123 $keys{$_->{_type} . ($_->{_name}?(' ' . $_->{_name}):'')} = $_;
240             }
241              
242 10         20 $self->{_keys} = \%keys;
243 10         144 return;
244             }
245              
246              
247             # Find a section.
248             # Either in $config (at parse-time) or in {_keys}
249             sub _find_section
250             {
251 20     20   19 my( $self, $type, $name, $config ) = @_;
252 20 100       27 if( $config ) {
253 17         13 my $c;
254 17         38 for (my $i = 0; $i <= $#$config; $i++) {
255 31         28 $c = $config->[$i];
256 31 50       44 next unless $c->{_name}; # ignore searchd, indexer sections
257 31 100 66     90 if( $c->{_name} eq $name && $c->{_type} eq $type ) {
258 17         27 return $c;
259             }
260             }
261             }
262             else {
263 3         2 my $key = $type;
264 3 50       5 $key .= " $name" if $name;
265 3         4 return $self->{_keys}{$key};
266             }
267             }
268              
269             # setup (or change) the inheritance of a section
270             # returns true on success
271             # returns undef if it can't find the base section
272             sub _setup_inherit
273             {
274 20     20   21 my( $self, $current, $base_name, $config ) = @_;
275              
276 20         31 my $base = $self->_find_section( $current->{_type}, $base_name, $config );
277            
278 20 50 33     67 return unless defined $base && $base != $current;
279              
280 20   100     54 my $out = $current->{_data} ||= {};
281              
282 20 100       33 if( $current->{_inherit} ) {
283             # Delete all inherited variables
284 3         3 my $I = $current->{_inherited};
285 3         8 while( my( $f, $v ) = each %$I ) {
286 12 100       15 next unless $v;
287 10         19 delete $out->{$f};
288             }
289 3         7 $current->{_inherited} = {};
290             }
291              
292 20         24 $current->{_inherit} = $base_name;
293             # XXX - check that {_children} doesn't already have {_name}
294 20   100     16 push(@{$base->{_children} ||= []}, $current->{_name});
  20         52  
295              
296             # copy new values over
297 20   50     566 my $in = dclone($base->{_data} || {});
298 20         60 while( my( $f, $v ) = each %$in ) {
299 150 100       187 next if exists $out->{$f};
300 148         120 $out->{$f} = $v;
301 148         281 $current->{_inherited}{ $f } = 1;
302             }
303 20         58 return 1;
304             }
305              
306              
307              
308              
309             =head2 config
310              
311             $config = $c->config;
312              
313             Get the parsed configuration data as an array of hashes, where each entry in the
314             array represents one section of the configuration, in the order as parsed or
315             constructed.
316              
317             Each section is described by a hash with the following keys:
318              
319             =over 4
320              
321             =item * _type A mandatory key describing the section type (index, searchd etc)
322              
323             =item * _name The name of the section, where applicable
324              
325             =item * _inherited The name of the parent section, where applicable
326              
327             =item * _data A hash containing the name/value pairs which hold the
328             configuration data for the section. All values are simple data
329             elements, except where the same key can appear multiple times in the
330             configuration file with different values (such as in attribute
331             declarations), in which case the value is an array ref.
332              
333             =item * _inherited A hash describing which data values have been inherited
334              
335             =back
336              
337             =cut
338              
339             sub config {
340 3     3 1 18 return shift->{_config};
341             }
342              
343             =head2 get
344              
345             $value = $c->get($type, $name, $varname)
346             $value = $c->get($type, $name)
347              
348             Get the value of a configuration parameter.
349              
350             If $varname is specified, the value of the named parameter from the section
351             identified by the type and name is returned as a scalar. Otherwise, the hash containing all key/value pairs from the section is returned.
352              
353             $name may be undef for sections that do not require a name (e.g. searchd,
354             indexer, search).
355              
356             If the section cannot be found or the named parameter does not exist, undef is
357             returned.
358              
359             =cut
360              
361             sub get {
362 43     43 1 6822 my ($self, $type, $name, $var) = @_;
363              
364 43         40 my $key = $type;
365 43 100       82 $key .= ' ' . $name if $name;
366              
367 43         58 my $current = $self->{_keys}->{$key};
368 43 100       63 return undef unless $current;
369 41 100       51 if ($var) {
370 34 100       59 if ($var =~ m/^_/) {
371 3         8 return $current->{$var};
372             }
373             else {
374 31         95 return $current->{_data}->{$var};
375             }
376             }
377            
378 7         25 return $current->{_data};
379             }
380              
381             =head2 set
382              
383             $c->set($type, $name, $varname, $value)
384             $c->set($type, $name, \%values)
385             $c->set($type, $name, undef(), $base_name)
386             $c->set($type, $name, \%values, $base_name)
387              
388             Set the value or values of a section in the configuration.
389              
390             If varname is given, then the single parameter of that name in the
391             given section is set to the specified value. If the value is an
392             array, multiple entries will be created in the output file for the
393             same key.
394              
395             If a hash of name/value pairs is given, then any existing values are replaced
396             with the given hash.
397              
398             $c->set('source', , $name, \%values);
399              
400             If the section does not currently exist, a new one is appended.
401              
402             Set C<$name> to C to set variables in an C, C or
403             C section.
404              
405             $c->set('indexer', undef, 'listen', $port);
406             $c->set('search', undef, \%values );
407              
408             To change the section's inheritance, set $value to undef and specify a value
409             in the 4th parameter.
410              
411             $c->set('source', 'src1', undef(), 'base2');
412              
413             You this may be combined with a hash variable :
414              
415             $c->set('source', 'src1', \%values, 'base_source');
416              
417             To delete a name/value pair, set $value to undef.
418              
419             $c->set('source', 'src1', 'sql_query_pre', undef());
420             $c->set('source', 'src1', 'sql_query_pre');
421              
422             Returns the hash containing the current data values for the given section.
423              
424             See L for a description of how inherited values are handled.
425              
426             =cut
427              
428             sub set {
429 19     19 1 1525 my ($self, $type, $name, $var, $value) = @_;
430              
431 19         23 my $key = $type;
432 19 100       39 $key .= ' ' . $name if $name;
433              
434 19 100       42 if (! $self->{_keys}->{$key}) {
435             # append to configuration
436 1         2 my $current = { _type => $type, _new => 1 };
437 1 50       2 $current->{_name} = $name if $name;
438 1         1 push(@{$self->{_config}}, $current);
  1         2  
439 1         2 $self->{_keys}->{$key} = $current;
440             # new lines will be created by as_string()
441             # set inheritance at the same time
442             }
443              
444 19 100 100     70 if( not defined $var and $value ) {
    100          
    50          
445             # change inheritance
446 2 50       4 unless( $self->_change_inherit( $key, $value ) ) {
447 0         0 croak "Sphinx::Config: Unable to find $name $value for inheritance";
448             }
449             }
450             elsif (! ref($var)) {
451 14 100       33 if (! defined($var)) {
    50          
452             # delete section
453 2 50       8 if (my $entry = delete $self->{_keys}->{$key}) {
454 2     7   8 my $i = firstidx { $_ == $entry } @{$self->{_config}};
  7         10  
  2         27  
455 2 50       10 if( $i >= 0 ) {
456             # delete config
457 2         17 splice(@{$self->{_config}}, $i, 1);
  2         5  
458             # delete from file
459 2         7 $self->_clear_lines( $entry->{_lines} );
460             }
461             }
462             }
463             elsif ($var =~ m/^_/) {
464             # This seems to be mainly useful for unit tests
465 0 0       0 if (defined $value) {
466 0         0 $self->{_keys}->{$key}->{$var} = $value;
467             }
468             else {
469 0         0 delete $self->{_keys}->{$key}->{$var};
470             }
471             # _keys belong to us : no inheritance, not written to config file
472             }
473             else {
474 12         21 $self->_set( $type, $name, $var, $value );
475             }
476             }
477             elsif (ref($var) eq "HASH") {
478 3         7 $self->_redefine( $type, $name, $var );
479 3 100       7 if( $value ) {
480             # Change inheritance
481 1 50       2 unless( $self->_change_inherit( $key, $value ) ) {
482 0         0 croak "Sphinx::Config: Unable to find $type $value for inheritance";
483             }
484             }
485             }
486             else {
487 0         0 croak "Must provide variable name or hash, not " . ref($var);
488             }
489              
490 19         49 return $self->{_keys}->{$key}->{_data};
491             }
492              
493             # Set or remove a variable. Deals with inheritance
494             sub _set
495             {
496 16     16   16 my( $self, $type, $name, $var, $value ) = @_;
497              
498 16         16 my $key = $type;
499 16 100       28 $key .= " $name" if $name;
500              
501 16 100       22 if (defined $value) {
502 15         28 $self->{_keys}->{$key}->{_data}->{$var} = $value;
503 15         24 $self->_set_var_lines( $key, $var, $value );
504             }
505             else {
506 1         4 delete $self->{_keys}->{$key}->{_data}->{$var};
507 1         2 $self->_clear_var_lines( $key, $var );
508             }
509 16 100       34 if( $self->{_keys}{$key}{_inherit} ) {
510 3         4 $self->{_keys}->{$key}->{_inherited}->{$var} = 0;
511             }
512              
513 16 100       14 for my $child (@{$self->{_keys}->{$key}->{_children} || []}) {
  16         65  
514 8         11 my $ckey = join ' ', $type, $child;
515 8 50       17 my $c = $self->{_keys}->{$ckey} or next;
516 8 100       13 if ($self->{_bestow}) {
517 4 50       11 if ($c->{_inherited}->{$var}) {
518 4 100       4 if (defined $value) {
519 2         5 $c->{_data}->{$var} = $value;
520             }
521             else {
522 2         5 delete $c->{_data}->{$var};
523             }
524             }
525             }
526             else {
527 4         6 $c->{_inherited}->{$var} = 0;
528 4         9 $self->_set_var_lines( $ckey, $var, $c->{_data}{$var} );
529             }
530             }
531             }
532              
533             # Completely redefine a section
534             sub _redefine {
535 3     3   8 my( $self, $type, $name, $var ) = @_;
536            
537 3         3 my $key = $type;
538 3 100       35 $key .= " $name" if $name;
539 3         7 my $section = $self->{_keys}{$key};
540              
541 3         103 $var = dclone $var;
542             # Get a list of variables that currently exist
543 3         4 my @have = keys %{ $section->{_data} };
  3         10  
544 3         5 my %had;
545 3         22 @had{ @have } = (1) x @have;
546             # Set new values
547 3         9 foreach my $sk ( keys %$var ) {
548 4         11 $self->_set( $type, $name, $sk, $var->{$sk} );
549 4         10 delete $had{ $sk };
550             }
551             # Delete any remaining non-inherited values
552 3         10 foreach my $sk ( keys %had ) {
553 3 50       7 next if $section->{_inherited}{$sk};
554 0         0 $self->_set( $type, $name, $sk );
555             }
556             }
557              
558              
559             # Clear all lines between $pos->[0] and $pos->[1], inclusive
560             sub _clear_lines {
561 11     11   10 my( $self, $pos ) = @_;
562 11         23 for( my $line= $pos->[0]; $line <= $pos->[1]; $line++ ) {
563 22         49 $self->{_file}[$line] = undef;
564             }
565             }
566              
567             # Clear all lines associated with a variable
568             sub _clear_var_lines {
569 8     8   7 my( $self, $key, $var ) = @_;
570 8         9 foreach my $pos ( @{ $self->{_keys}{$key}{_pos}{$var} } ) {
  8         18  
571 9         16 $self->_clear_lines( $pos );
572             }
573             }
574              
575             # Append a variable to a section
576             sub _append_var_lines {
577 9     9   9 my( $self, $key, $var, $value ) = @_;
578 9         12 my $section = $self->{_keys}{ $key };
579              
580             # find last variable
581 9         8 my( $last, $last_var, $output );
582 9         8 foreach my $var ( keys %{ $section->{_pos} } ) {
  9         21  
583 10         8 foreach my $pos ( @{ $section->{_pos}{$var} } ) {
  10         12  
584 10 100 100     28 if( not $last or $pos->[1] > $last->[1] ) {
585 8         7 $last_var = $var;
586 8         10 $last = $pos
587             }
588             }
589             }
590             # adding to an empty section?
591 9 100       13 unless( $last ) {
592 5         7 $last = $section->{_lines};
593 5         8 $output = $self->_var_as_string( $var, $value );
594             }
595             else {
596 4         6 $output = $self->_get_var_lines( $last );
597             # change the key
598 4         40 $output =~ s/$last_var(\s*=)/$var$1/;
599             # change the value(s)
600 4         8 $output = $self->_set_var_value( $output, $var, $value );
601             }
602 9         21 $section->{_append}{$var} = $output;
603             }
604              
605             sub _set_var_value {
606 15     15   17 my( $self, $output, $var, $value ) = @_;
607 15 100       19 unless( ref $value ) {
608 13         191 $output =~ s/($var\s*=\s*)(.+)$/$1$value\n/s;
609             }
610             else {
611 2         3 my $line = $output;
612 2         4 $output = '';
613 2         3 foreach my $v ( @$value ) {
614 4         11 $output .= $self->_set_var_value( $line, $var, $v );
615             }
616             }
617 15         30 return $output;
618             }
619              
620             # Convert a [min,max] into a string that may be modified
621             sub _get_var_lines {
622 11     11   10 my( $self, $pos ) = @_;
623 11         8 my @text;
624 11         23 for( my $line= $pos->[0] ; $line <= $pos->[1] ; $line++ ) {
625 12   50     37 push @text, $self->{_file}[$line]||'';
626             }
627 11         23 return join '', @text;
628             }
629              
630             # Change the line(s) associated with a variable
631             sub _set_var_lines {
632 19     19   20 my( $self, $key, $var, $value ) = @_;
633              
634 19         23 my $section = $self->{_keys}{ $key };
635 19 50       27 croak "Can't find section $key" unless $section;
636              
637             # New variable...
638 19 100       35 unless( $section->{_pos}{ $var } ) {
639             # ... in a new section: generated by as_string
640 12 100       22 return if $section->{_new};
641            
642 9         15 $self->_append_var_lines( $key, $var, $value );
643 9         15 return;
644             }
645              
646             # build one line based on the first instance
647 7         12 my $pos = $section->{_pos}{$var}[0];
648 7         14 my $input = $self->_get_var_lines( $pos );
649             # modify the line
650 7         13 my $output = $self->_set_var_value( $input, $var, $value );
651             # clear every other instance
652 7         14 $self->_clear_var_lines( $key, $var );
653             # set the new line
654 7         13 $self->{_file}[$pos->[0]] = $output;
655             # only one pos, on only one line. Yes this line could contain \n, but
656             # and this will cause problems
657 7         6 $pos->[1] = $pos->[0];
658 7         12 $section->{_pos}{$var} = [ $pos ];
659 7         14 return;
660             }
661              
662             # Change the inheritance of a section
663             sub _set_inherit_lines {
664 3     3   4 my( $self, $key, $base_name, $was ) = @_;
665              
666 3         3 my $section = $self->{_keys}{ $key };
667 3 50       5 croak "Can't find section $key" unless $section;
668 3 50       5 return 1 if $section->{_new};
669              
670 3         3 my $file = $self->{_file};
671 3         2 my $pos = $section->{_lines};
672 3         3 my $done;
673 3         5 for( my $line=$pos->[0]; $line <= $pos->[1]; $line++ ) {
674 7 50       9 next unless defined $file->[$line];
675 7 50       8 if( $was ) {
    0          
676 7 100 100     82 if( ($file->[$line] =~ s/(:\s*)$was/$1$base_name/ or
677             $file->[$line] =~ s/^(\s*)$was(\s*(\{|\Z))/$1$base_name$2/ ) ) {
678 3         11 return 1;
679             }
680             }
681             elsif( $file->[$line] =~ s/\{/$base_name {/ ) {
682 0         0 return 1;
683             }
684             }
685 0         0 die "Can't find where to put the base name in ", join '',
686 0         0 @{ $file }[ $pos->[0] .. $pos->[1] ];
687             }
688              
689             sub _change_inherit {
690 3     3   4 my( $self, $key, $base_name ) = @_;
691 3         4 my $section = $self->{_keys}{$key};
692 3         3 my $was = $section->{_inherit};
693 3 50       3 return unless $self->_setup_inherit( $section, $base_name );
694 3         4 return $self->_set_inherit_lines( $key, $base_name, $was );
695             }
696              
697             =head2 save
698              
699             $c->save
700             $c->save($filename, $comment)
701              
702             Save the configuration to a file. The currently opened file is used if not
703             specified.
704              
705             The comment is inserted literally, so each line should begin with '#'.
706              
707             See L for a description of how inherited blocks are handled.
708              
709             =cut
710              
711             sub save {
712 3     3 1 5 my ($self, $filename, $comment) = @_;
713              
714 3 0 33     10 if( not $filename and not $self->{_filename} ) {
715 0         0 croak "Sphinx::Config: Please to specify the file to save to";
716             }
717              
718 3   33     4 $filename ||= $self->{_filename};
719              
720 3         3 my $fh;
721 3 50       283 open($fh, ">$filename") or croak "Sphinx::Config: Cannot open $filename for writing";
722 3         12 print $fh $self->as_string($comment);
723 3         60 close($fh);
724             }
725              
726              
727              
728             =head2 as_string
729              
730             $s = $c->as_string
731             $s = $c->as_string($comment)
732              
733             Returns the configuration as a string, optionally with a comment prepended.
734              
735             The comment is inserted literally, so each line should begin with '#'.
736              
737             An effort has been made to make the configuration round-trip safe. That is,
738             any formating or comments in the original should also appear as-is in the
739             generated configuration. New sections are added at the end of the
740             configuration with an 8 space indent.
741              
742             New variables added to existing sections are handled as follows:
743              
744             =over 4
745              
746             =item *
747              
748             If you add a new variable to an existing section, it is added at the end of
749             the section, using the whitespace of the last existing variable.
750              
751             Given:
752              
753             index foo {
754             biff= bof
755             # ...
756             }
757              
758             and you add C with the value C, you will end up with:
759              
760             index foo {
761             biff= bof
762             # ...
763             honk= bonk
764             }
765              
766             =item *
767              
768             If you have a comment that looks a bit like the default or commented out
769             variable, the new value is added after the comment.
770              
771             Given:
772              
773             index foo {
774             ....
775             # honk=foo
776             # more details
777             }
778              
779             and you add C with the value C, you will end up with:
780              
781             index foo {
782             ....
783             # honk=foo
784             honk = bonk
785             # more details
786             }
787              
788             =back
789              
790             =cut
791              
792             sub as_string {
793 6     6 1 450 my ($self, $comment) = @_;
794              
795             # By using a copy, ->as_string can be called multiple times, even
796             # if we append variables to a section. Otherwise the new variables
797             # would be added multiple times
798 6 50 33     21 if (! $self->{_file} || ! @{$self->{_file}}) {
  6         15  
799 0         0 return $self->as_string_new($comment);
800             }
801 6         6 my $file = [@{ $self->{_file} }];
  6         224  
802              
803             # Find new sections and variables
804 6         8 my @todo;
805 6         7 foreach my $section ( @{ $self->{_config} } ) {
  6         12  
806 33 100       47 unless( $section->{_lines} ) {
807 1         1 push @todo, $section;
808 1         2 next;
809             }
810 32 100       44 if( $section->{_append} ) {
811 7         7 my $A = { %{ $section->{_append} } };
  7         18  
812 7         9 my $pos = $section->{_lines};
813             LINE:
814 7         16 for( my $line = $pos->[0] ; $line <= $pos->[1] ; $line++ ) {
815 34         37 foreach my $var ( keys %$A ) {
816 51 100       446 next unless $file->[$line] =~ /(\s*)#\s*$var/;
817 1         2 my $prefix = $1;
818 1         2 my $output = delete $A->{$var};
819 1         3 $output =~ s/^\s+//;
820 1         2 $file->[$line] .= "$prefix$output";
821 1         3 next LINE;
822             }
823             }
824 7 50       11 if( %$A ) {
825 7         13 my $add = join '', values %$A;
826 7         5 $DB::single = 1;
827 7         35 $file->[ $pos->[1] ] =~ s/}/$add}/;
828             }
829             }
830             }
831            
832             # Build a config string
833 6 100       14 my $s = $comment ? "$comment\n" : "";
834 6         9 foreach my $line ( @$file ) {
835 2131 100       2214 next unless defined $line;
836 2116         1516 $s .= $line;
837             }
838              
839             # Append new sections
840 6         12 for my $c (@todo) {
841 1 50       2 $s .= "\n" if $s =~ /}$/;
842 1 50       4 $s .= $c->{_type} . ($c->{_name} ? (" " . $c->{_name}) : '');
843 1         26 my $data = dclone($c->{_data});
844 1 50 33     4 if ($c->{_inherit} && $self->{_bestow}) {
845 0         0 $s .= " : " . $c->{_inherit};
846             # my $base = $self->get($c->{_type}, $c->{_inherit});
847             }
848 1         1 my $section = " {\n";
849 1         5 for my $k (sort keys %$data) {
850 2 50 33     7 next if $self->{_bestow} && $c->{_inherited}->{$k};
851 2         5 $section .= $self->_var_as_string( $k, $data->{$k} );
852             }
853 1         3 $s .= $section . "}\n";
854             }
855              
856 6         303 return $s;
857             }
858              
859             sub _var_as_string
860             {
861 7     7   7 my( $self, $k, $value ) = @_;
862 7         9 my $section = '';
863 7 50       10 if ( ref($value) eq 'ARRAY' ) {
864 0         0 for my $v (@$value ) {
865 0         0 $section .= $self->_var_as_string( $k, $v );
866             }
867             }
868             else {
869 7         16 $section .= ' ' . $k . ' = ' . $value . "\n";
870             }
871 7         10 return $section;
872             }
873              
874             =head2 as_string_new
875              
876             $s = $c->as_string_new
877             $s = $c->as_string_new($comment)
878              
879             Returns the configuration as a string, optionally with a comment prepended,
880             without attempting to preserve formatting from the original file.
881              
882             The comment is inserted literally, so each line should begin with '#'.
883              
884             =cut
885              
886             sub as_string_new {
887 0     0 1   my ($self, $comment) = @_;
888              
889 0 0         my $s = $comment ? "$comment\n" : "";
890 0           for my $c (@{$self->{_config}}) {
  0            
891 0 0         $s .= $c->{_type} . ($c->{_name} ? (" " . $c->{_name}) : '');
892 0           my $data = dclone($c->{_data});
893 0 0 0       if ($c->{_inherit} && $self->{_bestow}) {
894 0           $s .= " : " . $c->{_inherit};
895 0           my $base = $self->get($c->{_type}, $c->{_inherit});
896             }
897 0           my $section = " {\n";
898 0           for my $k (sort keys %$data) {
899 0 0 0       next if $self->{_bestow} && $c->{_inherited}->{$k};
900 0 0         if (ref($data->{$k}) eq 'ARRAY') {
901 0           for my $v (@{$data->{$k}}) {
  0            
902 0           $section .= ' ' . $k . ' = ' . $v . "\n";
903             }
904             }
905             else {
906 0           $section .= ' ' . $k . ' = ' . $data->{$k} . "\n";
907             }
908             }
909 0           $s .= $section . "}\n";
910             }
911              
912 0           return $s;
913             }
914              
915             =head1 SEE ALSO
916              
917             L
918              
919             =head1 AUTHOR
920              
921             Jon Schutz, C<< >>
922              
923             =head1 BUGS
924              
925             Please report any bugs or feature requests to
926             C, or through the web interface at
927             L.
928             I will be notified, and then you'll automatically be notified of progress on
929             your bug as I make changes.
930              
931             =head1 SUPPORT
932              
933             You can find documentation for this module with the perldoc command.
934              
935             perldoc Sphinx::Config
936              
937             You can also look for information at:
938              
939             =over 4
940              
941             =item * AnnoCPAN: Annotated CPAN documentation
942              
943             L
944              
945             =item * CPAN Ratings
946              
947             L
948              
949             =item * RT: CPAN's request tracker
950              
951             L
952              
953             =item * Search CPAN
954              
955             L
956              
957             =back
958              
959             =head1 ACKNOWLEDGEMENTS
960              
961             Philip Gwyn contributed the patch to preserve round-trip formatting,
962             which was a significant chunk of work.
963              
964             =head1 COPYRIGHT & LICENSE
965              
966             Copyright 2007 Jon Schutz, all rights reserved.
967              
968             This program is free software; you can redistribute it and/or modify it
969             under the same terms as Perl itself.
970              
971             =cut
972              
973             1; # End of Sphinx::Config