lib/TWiki/Prefs/PrefsCache.pm
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
equal deleted inserted replaced
-1:000000000000 0:414e01d06fd5
       
     1 # Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
       
     2 #
       
     3 # Copyright (C) 2000-2007 Peter Thoeny, peter@thoeny.org
       
     4 # and TWiki Contributors. All Rights Reserved. TWiki Contributors
       
     5 # are listed in the AUTHORS file in the root of this distribution.
       
     6 # NOTE: Please extend that file, not this notice.
       
     7 #
       
     8 # This program is free software; you can redistribute it and/or
       
     9 # modify it under the terms of the GNU General Public License
       
    10 # as published by the Free Software Foundation; either version 2
       
    11 # of the License, or (at your option) any later version. For
       
    12 # more details read LICENSE in the root of this distribution.
       
    13 #
       
    14 # This program is distributed in the hope that it will be useful,
       
    15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
       
    16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
       
    17 #
       
    18 # As per the GPL, removal of this notice is prohibited.
       
    19 
       
    20 =pod
       
    21 
       
    22 ---+ package TWiki::Prefs::PrefsCache
       
    23 
       
    24 The PrefsCache package holds a cache of topics that have been read in, using
       
    25 the TopicPrefs class.  These functions manage that cache.
       
    26 
       
    27 We maintain 2 hashes of values:
       
    28    * {locals} Contains all locals at this level. Locals are values that
       
    29      only apply when the current topic is the topic where the local is
       
    30      defined. The variable names are decorated with the locality where
       
    31      they apply.
       
    32    * {values} contains all sets, locals, and all values inherited from
       
    33      the parent level
       
    34 
       
    35 As each cache level is built, the values are copied down from the parent
       
    36 cache level. This sounds monstrously inefficient, but in fact perl does
       
    37 this a lot better than doing a multi-level lookup when a value is referenced.
       
    38 This is especially important when many prefs lookups may be done in a
       
    39 session, for example when searching.
       
    40 
       
    41 =cut
       
    42 
       
    43 package TWiki::Prefs::PrefsCache;
       
    44 
       
    45 use strict;
       
    46 use Assert;
       
    47 
       
    48 require TWiki;
       
    49 require TWiki::Prefs::Parser;
       
    50 
       
    51 use vars qw( $parser );
       
    52 
       
    53 =pod
       
    54 
       
    55 ---++ ClassMethod new( $prefs, $parent, $type, $web, $topic, $prefix )
       
    56 
       
    57 Creates a new Prefs object.
       
    58    * =$prefs= - controlling TWiki::Prefs object
       
    59    * =$parent= - the PrefsCache object to use to initialise values from
       
    60    * =$type= - Type of prefs object to create, see notes.
       
    61    * =$web= - web containing topic to load from (required is =$topic= is set)
       
    62    * =$topic= - topic to load from
       
    63    * =$prefix= - key prefix for all preferences (used for plugins)
       
    64 If the specified topic is not found, returns an empty object.
       
    65 
       
    66 =cut
       
    67 
       
    68 sub new {
       
    69     my( $class, $prefs, $parent, $type, $web, $topic, $prefix) = @_;
       
    70 
       
    71     ASSERT($prefs->isa( 'TWiki::Prefs')) if DEBUG;
       
    72     ASSERT($type) if DEBUG;
       
    73 
       
    74     my $this = bless( {}, $class );
       
    75     $this->{MANAGER} = $prefs;
       
    76     $this->{TYPE} = $type;
       
    77     $this->{SOURCE} = '';
       
    78     $this->{CONTEXT} = $prefs;
       
    79 
       
    80     if( $parent && $parent->{values} ) {
       
    81         %{$this->{values}} = %{$parent->{values}};
       
    82     }
       
    83     if( $parent && $parent->{locals} ) {
       
    84         %{$this->{locals}} = %{$parent->{locals}};
       
    85     }
       
    86 
       
    87     if( $web && $topic ) {
       
    88         $this->loadPrefsFromTopic( $web, $topic, $prefix );
       
    89     }
       
    90 
       
    91     return $this;
       
    92 }
       
    93 
       
    94 =begin twiki
       
    95 
       
    96 ---++ ObjectMethod finish()
       
    97 Break circular references.
       
    98 
       
    99 =cut
       
   100 
       
   101 # Note to developers; please undef *all* fields in the object explicitly,
       
   102 # whether they are references or not. That way this method is "golden
       
   103 # documentation" of the live fields in the object.
       
   104 sub finish {
       
   105     my $this = shift;
       
   106     undef $this->{MANAGER};
       
   107     undef $this->{TYPE};
       
   108     undef $this->{SOURCE};
       
   109     undef $this->{CONTEXT};
       
   110     undef $this->{values};
       
   111     undef $this->{locals};
       
   112     undef $this->{final};
       
   113     undef $this->{SetHere};
       
   114 }
       
   115 
       
   116 =pod
       
   117 
       
   118 ---++ ObjectMethod finalise( $parent )
       
   119 
       
   120 Finalise preferences in this cache, by freezing any preferences
       
   121 listed in FINALPREFERENCES at their current value.
       
   122    * $parent = object that supports getPreferenceValue
       
   123 
       
   124 =cut
       
   125 
       
   126 sub finalise {
       
   127     my $this = shift;
       
   128 
       
   129     my $value = $this->{values}{FINALPREFERENCES};
       
   130     if( $value ) {
       
   131         foreach ( split( /[\s,]+/, $value ) ) {
       
   132             # Note: cannot refinalise an already final value
       
   133             unless( $this->{CONTEXT}->isFinalised( $_ )) {
       
   134                 $this->{final}{$_} = 1;
       
   135             }
       
   136         }
       
   137     }
       
   138 }
       
   139 
       
   140 =pod
       
   141 
       
   142 ---++ ObjectMethod loadPrefsFromTopic( $web, $topic, $keyPrefix )
       
   143 
       
   144 Loads preferences from a topic. All settings loaded are prefixed
       
   145 with the key prefix (default '').
       
   146 
       
   147 =cut
       
   148 
       
   149 sub loadPrefsFromTopic {
       
   150     my( $this, $web, $topic, $keyPrefix ) = @_;
       
   151 
       
   152     $keyPrefix ||= '';
       
   153 
       
   154     $this->{SOURCE} = $web.'.'.$topic;
       
   155 
       
   156     my $session = $this->{MANAGER}->{session};
       
   157     if( $session->{store}->topicExists( $web, $topic )) {
       
   158         my( $meta, $text ) =
       
   159           $session->{store}->readTopic( undef, $web, $topic, undef );
       
   160 
       
   161         $parser ||= new TWiki::Prefs::Parser();
       
   162         $parser->parseText( $text, $this, $keyPrefix );
       
   163         $parser->parseMeta( $meta, $this, $keyPrefix );
       
   164     }
       
   165 }
       
   166 
       
   167 =pod
       
   168 
       
   169 ---++ ObjectMethod loadPrefsFromText( $text, $meta, $web, $topic )
       
   170 
       
   171 Loads preferences from text and optional metadata. All settings loaded
       
   172 are prefixed with the key prefix (default ''). If =$meta= is defined,
       
   173 then metadata will be taken from that object. Otherwise, =$text= will
       
   174 be parsed to extract meta-data.
       
   175 
       
   176 =cut
       
   177 
       
   178 # Note: this is required because TWiki stores access control
       
   179 # information in topic text. Useful because you get a complete
       
   180 # audit trail of access control settings for free.
       
   181 
       
   182 sub loadPrefsFromText {
       
   183     my( $this, $text, $meta, $web, $topic ) = @_;
       
   184 
       
   185     $this->{SOURCE} = $web.'.'.$topic;
       
   186 
       
   187     my $session = $this->{MANAGER}->{session};
       
   188     unless( $meta ) {
       
   189         require TWiki::Meta;
       
   190         $meta = new TWiki::Meta( $session, $web, $topic, $text );
       
   191     }
       
   192 
       
   193     my $parser = new TWiki::Prefs::Parser();
       
   194     $parser->parseText( $meta->text(), $this, '' );
       
   195     $parser->parseMeta( $meta, $this, '' );
       
   196 }
       
   197 
       
   198 =pod
       
   199 
       
   200 ---++ ObjectMethod insert($type, $key, $val) -> $boolean
       
   201 
       
   202 Adds a key-value pair of the given type to the object. Type is Set or Local.
       
   203 Callback used for the Prefs::Parser object, or can be used to add
       
   204 arbitrary new entries to a prefs cache.
       
   205 
       
   206 Note that attempts to redefine final preferences will be ignored.
       
   207 
       
   208 Returns 1 if the preference was defined, 0 otherwise.
       
   209 
       
   210 =cut
       
   211 
       
   212 sub insert {
       
   213     my( $this, $type, $key, $value ) = @_;
       
   214 
       
   215     return 0 if $this->{CONTEXT}->isFinalised( $key );
       
   216 
       
   217     $value =~ tr/\r//d;                 # Delete \r
       
   218     $value =~ tr/\t/ /;                 # replace TAB by space
       
   219     $value =~ s/([^\\])\\n/$1\n/g;      # replace \n by new line
       
   220     $value =~ s/([^\\])\\\\n/$1\\n/g;   # replace \\n by \n
       
   221     $value =~ tr/`//d;                  # filter out dangerous chars
       
   222     if( $type eq 'Local' ) {
       
   223         $this->{locals}{$this->{SOURCE}.'-'.$key} = $value;
       
   224     } else {
       
   225         $this->{values}{$key} = $value;
       
   226     }
       
   227     $this->{SetHere}{$key} = 1;
       
   228 
       
   229     return 1;
       
   230 }
       
   231 
       
   232 =pod
       
   233 
       
   234 ---++ ObjectMethod stringify($html, \%shown) -> $text
       
   235 
       
   236 Generate an (HTML if $html) representation of the content of this cache.
       
   237 
       
   238 =cut
       
   239 
       
   240 sub stringify {
       
   241     my( $this, $html ) = @_;
       
   242     my $res;
       
   243 
       
   244     if( $html ) {
       
   245         $res = CGI::Tr( 
       
   246                    CGI::th( {colspan=>2, class=>'twikiFirstCol'}, CGI::H3($this->{TYPE}.' '.
       
   247                               $this->{SOURCE} )))."\n";
       
   248     } else {
       
   249         $res = '******** '.$this->{TYPE}.' '.$this->{SOURCE}."\n";
       
   250     }
       
   251 
       
   252     foreach my $key ( sort keys %{$this->{values}} ) {
       
   253         next unless $this->{SetHere}{$key};
       
   254         my $final = '';
       
   255         if ( $this->{final}{$key}) {
       
   256             $final = ' *final* ';
       
   257         }
       
   258         my $val = $this->{values}{$key};
       
   259         $val =~ s/^(.{32}).*$/$1..../s;
       
   260         if( $html ) {
       
   261             $val = "\n<verbatim style='margin:0;'>\n$val\n</verbatim>\n" if $val;
       
   262             $res .= CGI::Tr( {valign=>'top'},
       
   263                              CGI::td(" Set $final $key").
       
   264                                  CGI::td( $val ))."\n";
       
   265         } else {
       
   266             $res .= "Set $final $key = $val\n";
       
   267         }
       
   268     }
       
   269     foreach my $key ( sort keys %{$this->{locals}} ) {
       
   270         next unless $this->{SetHere}{$key};
       
   271         my $final = '';
       
   272         my $val = $this->{locals}{$key};
       
   273         $val =~ s/^(.{32}).*$/$1..../s;
       
   274         if( $html ) {
       
   275             $val = "\n<verbatim style='margin:0;'>\n$val\n</verbatim>\n" if $val;
       
   276             $res .= CGI::Tr( {valign=>'top'},
       
   277                              CGI::td(" Local $key").
       
   278                                  CGI::td( $val ))."\n";
       
   279         } else {
       
   280             $res .= "Local $key = $val\n";
       
   281         }
       
   282     }
       
   283     return $res;
       
   284 }
       
   285 
       
   286 1;