lib/TWiki/Configure/TWikiCfg.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
permissions -rw-r--r--
RELEASE 4.2.0 freetown
     1 #
     2 # TWiki Enterprise Collaboration Platform, http://TWiki.org/
     3 #
     4 # Copyright (C) 2000-2006 TWiki Contributors.
     5 #
     6 # This program is free software; you can redistribute it and/or
     7 # modify it under the terms of the GNU General Public License
     8 # as published by the Free Software Foundation; either version 2
     9 # of the License, or (at your option) any later version. For
    10 # more details read LICENSE in the root of this distribution.
    11 #
    12 # This program is distributed in the hope that it will be useful,
    13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
    14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    15 #
    16 # As per the GPL, removal of this notice is prohibited.
    17 #
    18 # This is a both parser for configuration declaration files, such as
    19 # TWikiCfg.spec, and a serialisation visitor for writing out changes
    20 # to LocalSite.cfg
    21 #
    22 # The supported syntax in declaration files is as follows:
    23 #
    24 # cfg ::= ( setting | section | extension )* ;
    25 # setting ::= BOL typespec EOL comment* BOL def ;
    26 # typespec ::= "# **" id options "**" ;
    27 # def ::= "$" ["TWiki::"] "cfg" keys "=" value ";" ;
    28 # keys ::= ( "{" id "}" )+ ;
    29 # value is any perl value not including ";"
    30 # comment ::= BOL "#" string EOL ;
    31 # section ::= BOL "#--++" string EOL comment* ;
    32 # extension ::= BOL " *" id "*"
    33 # EOL ::= end of line
    34 # BOL ::= beginning of line
    35 # id ::= a \w+ word (legal Perl bareword)
    36 #
    37 # * A *section* is simply a divider used to create foldable blocks. It can
    38 #   have varying depth depending on the number of + signs
    39 # * A *setting* is the sugar required for the setting of a single
    40 #   configuration value.
    41 # * An *extension* is a pluggable UI extension that supports some extra UI
    42 #   functionality, such as the menu of languages or the menu of plugins.
    43 #
    44 # Each *setting* has a *typespec* and a *def*.
    45 #
    46 # The typespec consists of a type id and some options. Types are loaded by
    47 # type id from the TWiki::Configure::Types hierachy - for example, type
    48 # BOOLEAN is defined by TWiki::Configure::Types::BOOLEAN. Each type is a
    49 # subclass of TWiki::Configure::Type - see that class for more details of
    50 # what is supported.
    51 #
    52 # A *def* is a specification of a field in the $TWiki::cfg hash, together with
    53 # a perl value for that hash. Each field can have an associated *Checker*
    54 # which is loaded from the TWiki::Configure::Checkers hierarchy. Checkers
    55 # are responsible for specific checks on the value of that variable. For
    56 # example, the checker for $TWiki::cfg{Banana}{Republic} will be expected
    57 # to be found in TWiki::Configure::Checkers::Banana::Republic.
    58 # Checkers are subclasses of TWiki::Configure::Checker. See that class for
    59 # more details.
    60 #
    61 # An *extension* is a placeholder for a pluggable UI module.
    62 #
    63 package TWiki::Configure::TWikiCfg;
    64 
    65 use strict;
    66 use Data::Dumper;
    67 
    68 use TWiki::Configure::Section;
    69 use TWiki::Configure::Value;
    70 use TWiki::Configure::Pluggable;
    71 use TWiki::Configure::Item;
    72 
    73 # Used in saving, when we need a callback. Otherwise the methods here are
    74 # all static.
    75 sub new {
    76     my $class = shift;
    77 
    78     return bless({}, $class);
    79 }
    80 
    81 # Load the configuration declarations. The core set is defined in
    82 # TWiki.spec, which must be found on the @INC path and is always loaded
    83 # first. Then find all settings for extensions in their .spec files.
    84 #
    85 # This *only* reads type specifications, it *does not* read values.
    86 #
    87 # SEE ALSO TWiki::Configure::Load::readDefaults
    88 sub load {
    89     my ($root, $haveLSC) = @_;
    90 
    91     my $file = TWiki::findFileOnPath('TWiki.spec');
    92     if ($file) {
    93         _parse($file, $root, $haveLSC);
    94     }
    95     if ($haveLSC) {
    96         my %read;
    97         foreach my $dir (@INC) {
    98             _loadSpecsFrom("$dir/TWiki/Plugins", $root, \%read);
    99             _loadSpecsFrom("$dir/TWiki/Contrib", $root, \%read);
   100         }
   101     }
   102 }
   103 
   104 sub _loadSpecsFrom {
   105     my ($dir, $root, $read) = @_;
   106 
   107     return unless opendir(D, $dir);
   108     foreach my $extension ( grep { !/^\./ } readdir D) {
   109         next if $read->{$extension};
   110         my $file = "$dir/$extension/Config.spec";
   111         next unless -e $file;
   112         _parse($file, $root, 1);
   113         $read->{$extension} = $file;
   114     }
   115     closedir(D);
   116 }
   117 
   118 ###########################################################################
   119 ## INPUT
   120 ###########################################################################
   121 {
   122     # Inner class that represents section headings temporarily during the
   123     # parse. They are expanded to section blocks at the end.
   124     package SectionMarker;
   125 
   126     use base 'TWiki::Configure::Item';
   127 
   128     sub new {
   129         my ($class, $depth, $head) = @_;
   130         my $this = bless({}, $class);
   131         $this->{depth} = $depth + 1;
   132         $this->{head} = $head;
   133         return $this;
   134     }
   135 
   136     sub getValueObject { return undef; }
   137 }
   138 
   139 # Process the config array and add section objects
   140 sub _extractSections {
   141     my ($settings, $root) = @_;
   142 
   143     my $section = $root;
   144     my $depth = 0;
   145 
   146     foreach my $item (@$settings) {
   147         if ($item->isa('SectionMarker')) {
   148             my $ns = $root->getSectionObject($item->{head}, $item->{depth}+1);
   149             if ($ns) {
   150                 $depth = $item->{depth};
   151             } else {
   152                 while ($depth > $item->{depth} - 1) {
   153                     $section = $section->{parent};
   154                     $depth--;
   155                 }
   156                 while ($depth < $item->{depth} - 1) {
   157                     my $ns = new TWiki::Configure::Section('');
   158                     $section->addChild($ns);
   159                     $section = $ns;
   160                     $depth++;
   161                 }
   162                 $ns = new TWiki::Configure::Section($item->{head});
   163                 $ns->{desc} = $item->{desc};
   164                 $section->addChild($ns);
   165                 $depth++;
   166             }
   167             $section = $ns;
   168         } elsif ($item->isa('TWiki::Configure::Value')) {
   169             # Skip it if we already have a settings object for these
   170             # keys (first loaded always takes precedence, irrespective
   171             # of which section it is in)
   172             my $vo = $root->getValueObject($item->getKeys());
   173             next if ($vo);
   174             $section->addChild($item);
   175         } else {
   176             $section->addChild($item);
   177         }
   178     }
   179 }
   180 
   181 # See if we have already build a value object for these keys
   182 sub _getValueObject {
   183     my ($keys, $settings) = @_;
   184     foreach my $item (@$settings) {
   185         my $i = $item->getValueObject($keys);
   186         return $i if $i;
   187     }
   188     return undef;
   189 }
   190 
   191 # Parse the config declaration file and return a root node for the
   192 # configuration it describes
   193 sub _parse {
   194     my ($file, $root, $haveLSC) = @_;
   195 
   196     open(F, "<$file") || return '';
   197     local $/ = "\n";
   198     my $open = undef;
   199     my @settings;
   200     my $sectionNum = 0;
   201 
   202     foreach my $l (<F>) {
   203         if( $l =~ /^#\s*\*\*\s*([A-Z]+)\s*(.*?)\s*\*\*\s*$/ ) {
   204             pusht(\@settings, $open) if $open;
   205             $open = new TWiki::Configure::Value(typename=>$1, opts=>$2);
   206         }
   207 
   208         elsif ($l =~ /^#?\s*\$(TWiki::)?cfg([^=\s]*)\s*=/) {
   209             my $keys = $2;
   210             if ($open && $open->isa('SectionMarker')) {
   211                 pusht(\@settings, $open);
   212                 $open = undef;
   213             }
   214             # If there is already a UI object for
   215             # these keys, we don't need to add another. But if there
   216             # isn't, we do.
   217             if (!$open) {
   218                 next if $root->getValueObject($keys);
   219                 next if (_getValueObject($keys, \@settings));
   220                 # This is an untyped value
   221                 $open = new TWiki::Configure::Value();
   222             }
   223             $open->set(keys => $keys);
   224             pusht(\@settings, $open);
   225             $open = undef;
   226         }
   227 
   228         elsif( $l =~ /^#\s*\*([A-Z]+)\*/ ) {
   229             my $pluggable = $1;
   230             my $p = TWiki::Configure::Pluggable::load($pluggable);
   231             if ($p) {
   232                 pusht(\@settings, $open) if $open;
   233                 $open = $p;
   234             } elsif ($open) {
   235                 $l =~ s/^#\s?//;
   236                 $open->addToDesc($l);
   237             }
   238         }
   239 
   240         elsif( $l =~ /^#\s*---\+(\+*) *(.*?)$/ ) {
   241             # Only load the first section if we don't have LocalSite.cfg
   242             last if ($sectionNum && !$haveLSC);
   243             $sectionNum++;
   244             pusht(\@settings, $open) if $open;
   245             $open = new SectionMarker(length($1), $2);
   246         }
   247 
   248         elsif( $l =~ /^#\s?(.*)$/ ) {
   249             $open->addToDesc($1) if $open;
   250         }
   251     }
   252     close(F);
   253     pusht(\@settings, $open) if $open;
   254     _extractSections(\@settings, $root);
   255 }
   256 
   257 sub pusht {
   258     my ($a, $n) = @_;
   259     foreach my $v (@$a) {
   260         Carp::confess "$n" if $v eq $n;
   261     }
   262     push(@$a,$n);
   263 }
   264 
   265 ###########################################################################
   266 ## OUTPUT
   267 ###########################################################################
   268 
   269 # Generate .cfg file format output
   270 sub save {
   271     my ($root, $valuer, $logger) = @_;
   272 
   273     # Object used to act as a visitor to hold the output
   274     my $this = new TWiki::Configure::TWikiCfg();
   275     $this->{logger} = $logger;
   276     $this->{valuer} = $valuer;
   277     $this->{root} = $root;
   278     $this->{content} = '';
   279 
   280     my $lsc = TWiki::findFileOnPath('LocalSite.cfg');
   281     unless ($lsc) {
   282         # If not found on the path, park it beside TWiki.spec
   283         $lsc = TWiki::findFileOnPath('TWiki.spec') || '';
   284         $lsc =~ s/TWiki\.spec/LocalSite.cfg/;
   285     }
   286 
   287     if (open(F, '<'.$lsc)) {
   288         local $/ = undef;
   289         $this->{content} = <F>;
   290         close(F);
   291     } else {
   292         $this->{content} = <<'HERE';
   293 # Local site settings for TWiki. This file is managed by the 'configure'
   294 # CGI script, though you can also make (careful!) manual changes with a
   295 # text editor.
   296 HERE
   297     }
   298 
   299     my $out = $this->_save();
   300     open(F, '>'.$lsc) ||
   301       die "Could not open $lsc for write: $!";
   302     print F $this->{content};
   303     close(F);
   304 
   305     return '';
   306 }
   307 
   308 sub _save {
   309     my $this = shift;
   310 
   311     $this->{content} =~ s/\s*1;\s*$/\n/sg;
   312     $this->{root}->visit($this);
   313     $this->{content} .= "1;\n";
   314 }
   315 
   316 # Visitor method called by node traversal during save. Incrementally modify
   317 # values, unless a value is reverting to the default in which case remove it.
   318 sub startVisit {
   319     my ($this, $visitee) = @_;
   320 
   321     if ($visitee->isa('TWiki::Configure::Value')) {
   322         my $keys = $visitee->getKeys();
   323         my $warble = $this->{valuer}->currentValue($visitee);
   324         return 1 unless defined $warble;
   325         my $txt = Data::Dumper->Dump([$warble],
   326                                      ['$TWiki::cfg'.$keys]);
   327         if ($this->{logger}) {
   328             $this->{logger}->logChange($visitee->getKeys(), $txt);
   329         }
   330         # Substitute any existing value, or append if not there
   331         unless ($this->{content} =~ s/\$(TWiki::)?cfg$keys\s*=.*?;\n/$txt/s) {
   332             $this->{content} .= $txt;
   333         }
   334     }
   335     return 1;
   336 }
   337 
   338 sub endVisit {
   339     my ($this, $visitee) = @_;
   340 
   341     return 1;
   342 }
   343 
   344 1;