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   188499 use warnings;
  5         13  
  5         173  
4 5     5   30 use strict;
  5         10  
  5         174  
5 5     5   27 use Carp qw/croak/;
  5         13  
  5         368  
6 5     5   157627 use Storable qw/dclone/;
  5         37347  
  5         627  
7 5     5   5000 use List::MoreUtils qw/firstidx/;
  5         9591  
  5         26387  
8              
9             =head1 NAME
10              
11             Sphinx::Config - Sphinx search engine configuration file read/modify/write
12              
13             =cut
14              
15             our $VERSION = '0.09';
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 56 my $class = shift;
38              
39 5   33     55 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 6 my $self = shift;
63 2 50       13 $self->{_bestow} = shift if @_;
64              
65 2         7 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 2499 my ($self, $filename) = @_;
82              
83 7 50       267 die "Sphinx::Config: $filename does not exist" unless -f $filename;
84              
85 7         16 my $fh;
86 7 50       328 open($fh, "<$filename") or die "Sphinx::Config: cannot open $filename: $!";
87 7         5002 $self->{_file} = [ <$fh> ];
88 7         418 close( $fh );
89 7         21 $self->{_filename} = $filename;
90 7         33 $self->_parse_file;
91 7         75 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 5071 my( $self, $string ) = @_;
106             # split string on newlines, keeping the newlines in-place
107 3         39 $self->{_file} = [ split /^/m, $string ];
108 3         23 delete $self->{_filename};
109             # _filename is used by _parse_file in its error messages
110 3         8 local $self->{_filename} = "STRING";
111 3         8 $self->_parse_file;
112 3         8 return;
113             }
114              
115             sub _parse_file
116             {
117 10     10   20 my( $self ) = @_;
118              
119 10         19 my $state = 'outer';
120 10         22 my $seq = "section";
121 10         15 my $max = @{ $self->{_file} };
  10         25  
122 10         18 my $current;
123             my @config;
124              
125 10         40 foreach( my $line = 0; $line < $max ; $line++ ) {
126 2938         4966 my $first = $line;
127 2938         5431 my $input = $self->{_file}[ $line ];
128 2938         4088 chomp $input;
129             # discard comments
130 2938         13813 $input =~ s/\s*\#.*//o;
131             # merge continued lines
132 2938   66     7846 while ($input =~ s!\\\s*$!!s and $line < $max ) {
133 15         23 $line++;
134 15         31 my $new = $self->{_file}[ $line ];
135 15         30 chomp( $new );
136             # We are folding all space up. XXX- How does Sphinx handle this?
137 15 50       60 if( $input =~ / $/ ) {
138 15         53 $new =~ s/^\s+//;
139             } else {
140 0         0 $new =~ s/^\s+/ /;
141             }
142 15         79 $input .= $new;
143             }
144             # handling this virtual line
145 2938         9095 while ($input) {
146 405 100       1007 if ($state eq 'outer') {
    50          
147             # split into tokens, fully consuming input line
148 103         298 my @tokens = split(/\s+/, $input);
149 103         141 $input = "";
150 103         207 while( @tokens ) {
151 219         295 my $tok = shift @tokens;
152 219 100       422 next unless length $tok;
153 211 100       716 if ($seq eq "section") {
    100          
    100          
    100          
    50          
154 54 100       237 if ($tok =~ m/^(?:source|index)$/o) {
    50          
155 43         222 $current = { _type => $tok, _lines => [ $first ] };
156 43         84 push(@config, $current);
157 43         112 $seq = "name";
158             }
159             elsif ($tok =~ m/^(?:indexer|searchd|search)$/o) {
160 11         45 $current = { _type => $tok, _lines => [ $first ] };
161 11         28 push(@config, $current);
162 11         54 $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         90 $current->{_name} = $tok;
170 43         163 $seq = "openorinherit";
171             }
172             elsif ($seq eq "openorinherit") {
173 43 100       80 if ($tok eq ':') {
174 17         53 $seq = "inherit";
175             }
176             else {
177 26         103 unshift(@tokens, $tok);
178 26         65 $seq = "openblock";
179             }
180             }
181             elsif ($seq eq "inherit") {
182 17 50       53 die "Sphinx::Config:: $self->{_filename}:$line: a section may not inherit from itself"
183             if $tok eq $current->{_name};
184 17 50       69 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         93 $seq = "openblock";
188             }
189             elsif ($seq eq "openblock") {
190 54 50       116 die "Sphinx::Config: $self->{_filename}:$first: expected '{'" unless $tok eq "{";
191 54         70 $seq = "section";
192 54         127 $state = "inner";
193             # return any leftovers
194 54         284 $input = join(" ", @tokens);
195             }
196             }
197             }
198             elsif ($state eq "inner") {
199 302         742 my $pos = [ $first, $line ];
200 302 100       10481 if ($input =~ s/^\s*\}//o) {
    100          
    50          
201 54         86 $state = "outer";
202 54         116 $current->{_lines}[1] = $line;
203 54         232 $current = undef;
204             }
205             elsif ($input =~ s/^\s*([\w]+)\s*=\s*(.*)\s*$//o) {
206 244         467 my $k = $1;
207 244         484 my $v = $2;
208 244 100 100     859 if (exists($current->{_data}->{$k}) && ! $current->{_inherited}->{$k}) {
209 13 50       39 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         63 $current->{_data}->{$k} = [ $current->{_data}->{$k}, $v ];
216             }
217 13         23 push(@{$current->{_pos}->{$k}}, $pos);
  13         72  
218             }
219             else {
220             # first or simple value
221 231         732 $current->{_data}->{$k} = $v;
222 231         723 $current->{_pos}->{$k} = [$pos];
223 231         1191 $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         26 $self->{_config} = \@config;
237 10         26 my %keys;
238 10         26 for (@config) {
239 54 100       244 $keys{$_->{_type} . ($_->{_name}?(' ' . $_->{_name}):'')} = $_;
240             }
241              
242 10         30 $self->{_keys} = \%keys;
243 10         14926 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   37 my( $self, $type, $name, $config ) = @_;
252 20 100       39 if( $config ) {
253 17         20 my $c;
254 17         67 for (my $i = 0; $i <= $#$config; $i++) {
255 31         52 $c = $config->[$i];
256 31 50       140 next unless $c->{_name}; # ignore searchd, indexer sections
257 31 100 66     155 if( $c->{_name} eq $name && $c->{_type} eq $type ) {
258 17         54 return $c;
259             }
260             }
261             }
262             else {
263 3         4 my $key = $type;
264 3 50       7 $key .= " $name" if $name;
265 3         7 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   35 my( $self, $current, $base_name, $config ) = @_;
275              
276 20         60 my $base = $self->_find_section( $current->{_type}, $base_name, $config );
277            
278 20 50 33     117 return unless defined $base && $base != $current;
279              
280 20   100     88 my $out = $current->{_data} ||= {};
281              
282 20 100       55 if( $current->{_inherit} ) {
283             # Delete all inherited variables
284 3         4 my $I = $current->{_inherited};
285 3         11 while( my( $f, $v ) = each %$I ) {
286 12 100       23 next unless $v;
287 10         27 delete $out->{$f};
288             }
289 3         7 $current->{_inherited} = {};
290             }
291              
292 20         44 $current->{_inherit} = $base_name;
293             # XXX - check that {_children} doesn't already have {_name}
294 20   100     23 push(@{$base->{_children} ||= []}, $current->{_name});
  20         92  
295              
296             # copy new values over
297 20   50     1355 my $in = dclone($base->{_data} || {});
298 20         89 while( my( $f, $v ) = each %$in ) {
299 150 100       314 next if exists $out->{$f};
300 148         237 $out->{$f} = $v;
301 148         738 $current->{_inherited}{ $f } = 1;
302             }
303 20         104 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 30 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 9868 my ($self, $type, $name, $var) = @_;
363              
364 43         63 my $key = $type;
365 43 100       262 $key .= ' ' . $name if $name;
366              
367 43         92 my $current = $self->{_keys}->{$key};
368 43 100       103 return undef unless $current;
369 41 100       79 if ($var) {
370 34 100       83 if ($var =~ m/^_/) {
371 3         10 return $current->{$var};
372             }
373             else {
374 31         156 return $current->{_data}->{$var};
375             }
376             }
377            
378 7         33 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 2053 my ($self, $type, $name, $var, $value) = @_;
430              
431 19         26 my $key = $type;
432 19 100       68 $key .= ' ' . $name if $name;
433              
434 19 100       61 if (! $self->{_keys}->{$key}) {
435             # append to configuration
436 1         3 my $current = { _type => $type, _new => 1 };
437 1 50       4 $current->{_name} = $name if $name;
438 1         2 push(@{$self->{_config}}, $current);
  1         3  
439 1         3 $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     101 if( not defined $var and $value ) {
    100          
    50          
445             # change inheritance
446 2 50       8 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       48 if (! defined($var)) {
    50          
452             # delete section
453 2 50       13 if (my $entry = delete $self->{_keys}->{$key}) {
454 2     7   10 my $i = firstidx { $_ == $entry } @{$self->{_config}};
  7         17  
  2         37  
455 2 50       14 if( $i >= 0 ) {
456             # delete config
457 2         28 splice(@{$self->{_config}}, $i, 1);
  2         9  
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         36 $self->_set( $type, $name, $var, $value );
475             }
476             }
477             elsif (ref($var) eq "HASH") {
478 3         13 $self->_redefine( $type, $name, $var );
479 3 100       10 if( $value ) {
480             # Change inheritance
481 1 50       3 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         80 return $self->{_keys}->{$key}->{_data};
491             }
492              
493             # Set or remove a variable. Deals with inheritance
494             sub _set
495             {
496 16     16   32 my( $self, $type, $name, $var, $value ) = @_;
497              
498 16         23 my $key = $type;
499 16 100       45 $key .= " $name" if $name;
500              
501 16 100       31 if (defined $value) {
502 15         42 $self->{_keys}->{$key}->{_data}->{$var} = $value;
503 15         39 $self->_set_var_lines( $key, $var, $value );
504             }
505             else {
506 1         5 delete $self->{_keys}->{$key}->{_data}->{$var};
507 1         5 $self->_clear_var_lines( $key, $var );
508             }
509 16 100       87 if( $self->{_keys}{$key}{_inherit} ) {
510 3         7 $self->{_keys}->{$key}->{_inherited}->{$var} = 0;
511             }
512              
513 16 100       27 for my $child (@{$self->{_keys}->{$key}->{_children} || []}) {
  16         92  
514 8         21 my $ckey = join ' ', $type, $child;
515 8 50       27 my $c = $self->{_keys}->{$ckey} or next;
516 8 100       20 if ($self->{_bestow}) {
517 4 50       13 if ($c->{_inherited}->{$var}) {
518 4 100       10 if (defined $value) {
519 2         9 $c->{_data}->{$var} = $value;
520             }
521             else {
522 2         10 delete $c->{_data}->{$var};
523             }
524             }
525             }
526             else {
527 4         10 $c->{_inherited}->{$var} = 0;
528 4         13 $self->_set_var_lines( $ckey, $var, $c->{_data}{$var} );
529             }
530             }
531             }
532              
533             # Completely redefine a section
534             sub _redefine {
535 3     3   7 my( $self, $type, $name, $var ) = @_;
536            
537 3         6 my $key = $type;
538 3 100       57 $key .= " $name" if $name;
539 3         11 my $section = $self->{_keys}{$key};
540              
541 3         253 $var = dclone $var;
542             # Get a list of variables that currently exist
543 3         6 my @have = keys %{ $section->{_data} };
  3         14  
544 3         5 my %had;
545 3         36 @had{ @have } = (1) x @have;
546             # Set new values
547 3         13 foreach my $sk ( keys %$var ) {
548 4         16 $self->_set( $type, $name, $sk, $var->{$sk} );
549 4         10 delete $had{ $sk };
550             }
551             # Delete any remaining non-inherited values
552 3         16 foreach my $sk ( keys %had ) {
553 3 50       10 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   31 my( $self, $pos ) = @_;
562 11         50 for( my $line= $pos->[0]; $line <= $pos->[1]; $line++ ) {
563 22         82 $self->{_file}[$line] = undef;
564             }
565             }
566              
567             # Clear all lines associated with a variable
568             sub _clear_var_lines {
569 8     8   16 my( $self, $key, $var ) = @_;
570 8         11 foreach my $pos ( @{ $self->{_keys}{$key}{_pos}{$var} } ) {
  8         35  
571 9         21 $self->_clear_lines( $pos );
572             }
573             }
574              
575             # Append a variable to a section
576             sub _append_var_lines {
577 9     9   19 my( $self, $key, $var, $value ) = @_;
578 9         20 my $section = $self->{_keys}{ $key };
579              
580             # find last variable
581 9         11 my( $last, $last_var, $output );
582 9         18 foreach my $var ( keys %{ $section->{_pos} } ) {
  9         31  
583 10         14 foreach my $pos ( @{ $section->{_pos}{$var} } ) {
  10         20  
584 10 100 100     47 if( not $last or $pos->[1] > $last->[1] ) {
585 6         8 $last_var = $var;
586 6         18 $last = $pos
587             }
588             }
589             }
590             # adding to an empty section?
591 9 100       25 unless( $last ) {
592 5         8 $last = $section->{_lines};
593 5         15 $output = $self->_var_as_string( $var, $value );
594             }
595             else {
596 4         11 $output = $self->_get_var_lines( $last );
597             # change the key
598 4         55 $output =~ s/$last_var(\s*=)/$var$1/;
599             # change the value(s)
600 4         13 $output = $self->_set_var_value( $output, $var, $value );
601             }
602 9         38 $section->{_append}{$var} = $output;
603             }
604              
605             sub _set_var_value {
606 15     15   32 my( $self, $output, $var, $value ) = @_;
607 15 100       28 unless( ref $value ) {
608 13         294 $output =~ s/($var\s*=\s*)(.+)$/$1$value\n/s;
609             }
610             else {
611 2         6 my $line = $output;
612 2         3 $output = '';
613 2         7 foreach my $v ( @$value ) {
614 4         14 $output .= $self->_set_var_value( $line, $var, $v );
615             }
616             }
617 15         49 return $output;
618             }
619              
620             # Convert a [min,max] into a string that may be modified
621             sub _get_var_lines {
622 11     11   13 my( $self, $pos ) = @_;
623 11         13 my @text;
624 11         43 for( my $line= $pos->[0] ; $line <= $pos->[1] ; $line++ ) {
625 12   50     56 push @text, $self->{_file}[$line]||'';
626             }
627 11         90 return join '', @text;
628             }
629              
630             # Change the line(s) associated with a variable
631             sub _set_var_lines {
632 19     19   34 my( $self, $key, $var, $value ) = @_;
633              
634 19         34 my $section = $self->{_keys}{ $key };
635 19 50       44 croak "Can't find section $key" unless $section;
636              
637             # New variable...
638 19 100       57 unless( $section->{_pos}{ $var } ) {
639             # ... in a new section: generated by as_string
640 12 100       32 return if $section->{_new};
641            
642 9         23 $self->_append_var_lines( $key, $var, $value );
643 9         23 return;
644             }
645              
646             # build one line based on the first instance
647 7         16 my $pos = $section->{_pos}{$var}[0];
648 7         24 my $input = $self->_get_var_lines( $pos );
649             # modify the line
650 7         33 my $output = $self->_set_var_value( $input, $var, $value );
651             # clear every other instance
652 7         23 $self->_clear_var_lines( $key, $var );
653             # set the new line
654 7         19 $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         10 $pos->[1] = $pos->[0];
658 7         21 $section->{_pos}{$var} = [ $pos ];
659 7         19 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         6 my $section = $self->{_keys}{ $key };
667 3 50       9 croak "Can't find section $key" unless $section;
668 3 50       7 return 1 if $section->{_new};
669              
670 3         3 my $file = $self->{_file};
671 3         6 my $pos = $section->{_lines};
672 3         4 my $done;
673 3         10 for( my $line=$pos->[0]; $line <= $pos->[1]; $line++ ) {
674 7 50       16 next unless defined $file->[$line];
675 7 50       11 if( $was ) {
    0          
676 7 100 100     143 if( ($file->[$line] =~ s/(:\s*)$was/$1$base_name/ or
677             $file->[$line] =~ s/^(\s*)$was(\s*(\{|\Z))/$1$base_name$2/ ) ) {
678 3         15 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   5 my( $self, $key, $base_name ) = @_;
691 3         4 my $section = $self->{_keys}{$key};
692 3         5 my $was = $section->{_inherit};
693 3 50       7 return unless $self->_setup_inherit( $section, $base_name );
694 3         11 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 8 my ($self, $filename, $comment) = @_;
713              
714 3 0 33     11 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     8 $filename ||= $self->{_filename};
719              
720 3         5 my $fh;
721 3 50       606 open($fh, ">$filename") or croak "Sphinx::Config: Cannot open $filename for writing";
722 3         14 print $fh $self->as_string($comment);
723 3         144 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 333 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     30 if (! $self->{_file} || ! @{$self->{_file}}) {
  6         23  
799 0         0 return $self->as_string_new($comment);
800             }
801 6         10 my $file = [@{ $self->{_file} }];
  6         471  
802              
803             # Find new sections and variables
804 6         15 my @todo;
805 6         8 foreach my $section ( @{ $self->{_config} } ) {
  6         18  
806 33 100       88 unless( $section->{_lines} ) {
807 1         2 push @todo, $section;
808 1         2 next;
809             }
810 32 100       89 if( $section->{_append} ) {
811 7         10 my $A = { %{ $section->{_append} } };
  7         30  
812 7         15 my $pos = $section->{_lines};
813             LINE:
814 7         32 for( my $line = $pos->[0] ; $line <= $pos->[1] ; $line++ ) {
815 34         69 foreach my $var ( keys %$A ) {
816 52 100       857 next unless $file->[$line] =~ /(\s*)#\s*$var/;
817 1         3 my $prefix = $1;
818 1         2 my $output = delete $A->{$var};
819 1         4 $output =~ s/^\s+//;
820 1         3 $file->[$line] .= "$prefix$output";
821 1         5 next LINE;
822             }
823             }
824 7 50       20 if( %$A ) {
825 7         23 my $add = join '', values %$A;
826 7         19 $DB::single = 1;
827 7         51 $file->[ $pos->[1] ] =~ s/}/$add}/;
828             }
829             }
830             }
831            
832             # Build a config string
833 6 100       24 my $s = $comment ? "$comment\n" : "";
834 6         15 foreach my $line ( @$file ) {
835 2131 100       3877 next unless defined $line;
836 2116         2831 $s .= $line;
837             }
838              
839             # Append new sections
840 6         19 for my $c (@todo) {
841 1 50       5 $s .= "\n" if $s =~ /}$/;
842 1 50       7 $s .= $c->{_type} . ($c->{_name} ? (" " . $c->{_name}) : '');
843 1         59 my $data = dclone($c->{_data});
844 1 50 33     5 if ($c->{_inherit} && $self->{_bestow}) {
845 0         0 $s .= " : " . $c->{_inherit};
846             # my $base = $self->get($c->{_type}, $c->{_inherit});
847             }
848 1         2 my $section = " {\n";
849 1         6 for my $k (sort keys %$data) {
850 2 50 33     11 next if $self->{_bestow} && $c->{_inherited}->{$k};
851 2         6 $section .= $self->_var_as_string( $k, $data->{$k} );
852             }
853 1         28 $s .= $section . "}\n";
854             }
855              
856 6         700 return $s;
857             }
858              
859             sub _var_as_string
860             {
861 7     7   11 my( $self, $k, $value ) = @_;
862 7         10 my $section = '';
863 7 50       17 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         22 $section .= ' ' . $k . ' = ' . $value . "\n";
870             }
871 7         16 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