# Module of TWiki Collaboration Platform, http://TWiki.org/ # # Copyright (C) 2000-2004 Peter Thoeny, peter@thoeny.com # # For licensing info read license.txt file in the TWiki root. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details, published at # http://www.gnu.org/copyleft/gpl.html # # Notes: # - Latest version at http://twiki.org/ # - Installation instructions in $dataDir/TWiki/TWikiDocumentation.txt # - Customize variables in wikicfg.pm when installing TWiki. # - Optionally change wikicfg.pm for custom extensions of rendering rules. # - Files wiki[a-z]+.pm are included by wiki.pm # - Upgrading TWiki is easy as long as you only customize wikicfg.pm. # - Check web server error logs for errors, i.e. % tail /var/log/httpd/error_log use strict; =begin twiki ---+ TWiki::Prefs Module This module reads TWiki preferences of site-level, web-level and user-level topics and implements routines to access those preferences. =cut $TWiki::Prefs::finalPrefsName = "FINALPREFERENCES"; $TWiki::Prefs::formPrefPrefix = "FORM_"; package TWiki::Prefs::Parser; =pod ---++ Prefs::Parser Object This Prefs-internal class is used to parse * Set statements from arbitrary text, and extract settings from meta objects. It is used by TopicPrefs to parse preference settings from topics. This class does no validation or duplicate-checking on the settings; it simply returns the recognized settings in the order it sees them in. ---+++ sub new() Returns a new TopicParser object. ---+++ sub parseText( $text ) Returns an array ref \@settings representing the settings present in the text. The array contains one subarray [ $key, $value ] for each setting. =cut sub new { return bless {}, $_[0]; } sub parseText { my ($self, $text) = @_; my @settings; $text =~ s/\r/\n/g; $text =~ s/\n+/\n/g; my $key = ""; my $value =""; my $isKey = 0; foreach( split( /\n/, $text ) ) { if( /^\t+\*\sSet\s([a-zA-Z0-9_]*)\s\=\s*(.*)/ ) { if( $isKey ) { push @settings, [$key, $value]; } $key = $1; $value = defined $2 ? $2 : ""; $isKey = 1; } elsif ( $isKey ) { if( ( /^\t+/ ) && ( ! /^\t+\*/ ) ) { # follow up line, extending value $value .= "\n$_"; } else { push @settings, [$key, $value]; $isKey = 0; } } } if( $isKey ) { push @settings, [$key, $value]; } return \@settings; } =pod ---+++ sub parseMeta( $metaObject ) Traverses through all FIELD attributes of the meta object, creating one setting named with $TWiki::Prefs::formPrefPrefix . $fieldTitle for each. If the field's attribute list includes a 'S', it also creates an entry named with the field "name", which is a cleaned-up, space-removed version of the title. The resulting list of settings is returned in the same format as for parseText. =cut sub parseMeta { my ($self, $meta) = @_; my @settings; my %form = $meta->findOne( "FORM" ); if( %form ) { my @fields = $meta->find( "FIELD" ); foreach my $field ( @fields ) { my $title = $field->{"title"}; my $prefixedTitle = $TWiki::Prefs::formPrefPrefix . $title; my $value = $field->{"value"}; push @settings, [$prefixedTitle, $value]; my $attributes = $field->{"attributes"}; if( $attributes && $attributes =~ /[S]/o ) { my $name = $field->{"name"}; push @settings, [$name, $value]; } } } return \@settings; } package TWiki::Prefs::TopicPrefs; =pod ---++ TopicPrefs Object This Prefs-internal class is used to cache preferences read in from a single topic. ---+++ sub new( $web, $topic ) Reads preferences from the specified topic into a new TopicPrefs object. =cut sub new { my ($class, $theWeb, $theTopic) = @_; my $self = {}; bless $self, $class; $self->{web} = $theWeb; $self->{topic} = $theTopic; $self->readPrefs(); return $self; } =pod ---+++ sub insertPrefsRegexp( $key, $value ) Adds a regexps for a key to the TopicPrefs object. =cut sub insertPrefsRegexp{ my ( $self, $theKey, $theIndex) = @_; $self->{prefsRegexps}[$theIndex] = qr/%\Q$theKey\E%/; } =pod ---+++ sub readPrefs() Rereads preferences from the topic, updating the TopicPrefs object. =cut sub readPrefs { my $self = shift; my $theWeb = $self->{web}; my $theTopic = $self->{topic}; $self->{prefsHash} = {}; $self->{prefsKeys} = []; $self->{prefsRegexps} = []; $self->{prefsVals} = []; my $parser = TWiki::Prefs::Parser->new(); my( $meta, $text ) = &TWiki::Store::readTopic( $theWeb, $theTopic, 1 ); foreach my $setting ( @{ $parser->parseText($text) } ) { $self->insertPrefsValue( $setting->[0], $setting->[1] ); } foreach my $setting ( @{ $parser->parseMeta($meta) } ) { $self->insertPrefsValue( $setting->[0], $setting->[1] ); } } =pod ---+++ sub insertPrefsValue( $key, $value ) Adds a key-value pair to the TopicPrefs object. =cut sub insertPrefsValue { my ( $self, $theKey, $theValue ) = @_; return if exists $self->{finalHash}{$theKey}; # key is final, may not be overridden $theValue =~ s/\t/ /g; # replace TAB by space $theValue =~ s/([^\\])\\n/$1\n/g; # replace \n by new line $theValue =~ s/([^\\])\\\\n/$1\\n/g; # replace \\n by \n $theValue =~ s/`//g; # filter out dangerous chars if (exists $self->{prefsHash}{$theKey}) { # key exists, need to deal with existing preference my $valueRef = $self->{prefsHash}{$theKey}; if ($theKey eq $TWiki::Prefs::finalPrefsName) { $$valueRef .= ", $theValue"; # merge final preferences lists } else { $$valueRef = $theValue; # simply replace all other values } } else { # new preference setting, no previous value my $newIndex = scalar @{ $self->{prefsKeys} }; $self->{prefsKeys}[$newIndex] = $theKey; $self->insertPrefsRegexp( $theKey,$newIndex); $self->{prefsVals}[$newIndex] = $theValue; $self->{prefsHash}{$theKey} = \$self->{prefsVals}[$newIndex]; } } =pod ---+++ sub getTopicPrefs() Returns a list =( \@keys, \@values )= listing the preference settings in the current topic. Changing entries in the =@values= array will change cached preference settings. Changing entries in the =@keys= array will result in unspecified behavior -- don't do that. =cut sub getTopicPrefs { my $self = shift; return ($self->{prefsKeys}, $self->{prefsVals}) if wantarray; return [$self->{prefsKeys}, $self->{prefsVals}]; # return array ref in scalar context } # ============================================================================= package TWiki::Prefs::PrefsCache; use vars qw( %topicCache ); =pod ---++ PrefsCache Package Functions The PrefsCache package holds a cache of topics that have been read in, using the TopicPrefs class. These functions manage that cache. ---+++ sub clearCache() This non-member function clears cached topic preferences, forcing all settings to be reread. ---+++ sub invalidateCache( $web, $topic ) This non-member function invalidates the cache on a particular topic. =cut sub clearCache { undef %topicCache; } sub invalidateCache { delete $topicCache{$_[0]}{$_[1]}; } =pod ---++ PrefsCache Object This defines an object used internally by the functions in TWiki::Prefs to hold preferences. This object handles the cascading of preferences from site, to web, to topic/user. ---+++ sub new( $type, $parent, @target ) | Description: | Creates a new Prefs object. | | Parameter: =$type= | Type of prefs object to create, see notes. | | Parameter: =$parent= | Prefs object from which to inherit higher-level settings. | | Parameter: =@target= | What this object stores preferences for, see notes. | *Notes:* =$type= should be one of "global", "web", "request", or "copy". If the type is "global", no parent or target should be specified; the object will cache sitewide preferences. If the type is "web", =$parent= should hold global preferences, and @target should contain only the web's name. If the type is "request", then $parent should be a "web" preferences object for the current web, and =@target= should be ( $topicName, $userName ). $userName should be just the WikiName, with no web specifier. If the type is "copy", the result is a simple copy of =$parent=; no =@target= is needed. Call like this: =$mainWebPrefs = TWiki::Prefs->new("web", "Main");= =cut sub new { my ($theClass, $theType, $theParent, @theTarget) = @_; my $self; if ($theType eq "copy") { $self = { %$theParent }; bless $self, $theClass; $self->inheritPrefs($theParent); } else { $self = {}; bless $self, $theClass; $self->{type} = $theType; $self->{parent} = $theParent; $self->{web} = $theTarget[0] if ($theType eq "web"); if ($theType eq "request") { $self->{topic} = $theTarget[0]; $self->{user} = $theTarget[1]; } $self->loadPrefs( 1 ); } return $self; } =pod ---+++ sub insertPrefsRegexp( $key, $value ) Adds a regexps for a key to the TopicPrefs object. =cut sub insertPrefsRegexp{ my ( $self, $theKey, $theIndex) = @_; $self->{prefsRegexps}[$theIndex] = qr/%\Q$theKey\E%/; } =pod ---+++ sub loadPrefs( $allowCache ) Requests for Prefs object to load preferences from its defining topics, re-cascading the overrides. If =$allowCache= is set, the topic cache will be used to load preferences when applicable. Topics that must be read will be placed in the cache regardless of the setting of $allowCache. =cut sub loadPrefs { my ($self, $allowCache) = @_; $self->{prefsKeys} = []; $self->{prefsRegexps} = []; $self->{prefsVals} = []; $self->{prefsHash} = {}; $self->{finalHash} = {}; $self->inheritPrefs($self->{parent}) if defined $self->{parent}; if ($self->{type} eq "global") { # global prefs $self->loadPrefsFromTopic($TWiki::twikiWebname, $TWiki::wikiPrefsTopicname, "", $allowCache); $self->loadPrefsFromTopic($TWiki::mainWebname, $TWiki::wikiPrefsTopicname, "", $allowCache); } elsif ($self->{type} eq "web") { # web prefs $self->loadPrefsFromTopic( $self->{web}, $TWiki::webPrefsTopicname, "", $allowCache); } elsif ($self->{type} eq "request") { # request prefs - read topic and user my $parent = $self->{parent}; my $topicPrefsSetting = $parent->getPreferenceFlag("READTOPICPREFS"); my $topicPrefsOverride = $parent->getPreferenceFlag("TOPICOVERRIDESUSER"); if ($topicPrefsSetting && !$topicPrefsOverride) { # topic prefs overridden by user prefs $self->loadPrefsFromTopic( $parent->{web}, $self->{topic}, "", $allowCache); } $self->loadPrefsFromTopic( $TWiki::mainWebname, $self->{user}, "", $allowCache ); if ($topicPrefsSetting && $topicPrefsOverride) { # topic prefs override user prefs $self->loadPrefsFromTopic( $parent->{web}, $self->{topic}, "", $allowCache ); } } } =pod ---+++ sub loadPrefsFromTopic( $web, $topic, $keyPrefix, $allowCache ) Loads preferences from a topic. If =$allowCache= is set then cached settings are used where available. All settings loaded are prefixed with =$keyPrefix=. =cut sub loadPrefsFromTopic { my ($self, $theWeb, $theTopic, $theKeyPrefix, $allowCache) = @_; my $topicPrefs; if ($allowCache && exists( $topicCache{$theWeb}{$theTopic} )) { $topicPrefs = $topicCache{$theWeb}{$theTopic}; } else { $topicPrefs = TWiki::Prefs::TopicPrefs->new($theWeb, $theTopic); } my ($topicKeys, $topicVals) = $topicPrefs->getTopicPrefs(); $theKeyPrefix = "" unless defined $theKeyPrefix; for ( my $i = 0; $i < @$topicVals; $i++) { $self->_insertPreference($theKeyPrefix . $topicKeys->[$i], $topicVals->[$i]); } if (exists($self->{prefsHash}{$TWiki::Prefs::finalPrefsName})) { my $finalPrefsRef = $self->{prefsHash}{$TWiki::Prefs::finalPrefsName}; my @finalPrefsList = split /[\s,]+/, $$finalPrefsRef; $self->{finalHash} = { map { $_ => 1 } @finalPrefsList }; } } # Private function to insert a value into a PrefsCache object sub _insertPreference { my ($self, $theKey, $theValue) = @_; return if (exists $self->{finalHash}{$theKey}); # $theKey is in FINALPREFERENCES, don't update it if (exists $self->{prefsHash}{$theKey}) { # key exists, need to deal with existing preference my $valueRef = $self->{prefsHash}{$theKey}; if ($theKey eq $TWiki::Prefs::finalPrefsName) { $$valueRef .= ", $theValue"; # merge final preferences lists } else { $$valueRef = $theValue; # simply replace all other values } } else { # new preference setting, no previous value my $newIndex = scalar @{ $self->{prefsKeys} }; $self->{prefsKeys}[$newIndex] = $theKey; $self->insertPrefsRegexp( $theKey,$newIndex); $self->{prefsVals}[$newIndex] = $theValue; $self->{prefsHash}{$theKey} = \$self->{prefsVals}[$newIndex]; } } =pod ---+++ sub inheritPrefs( $otherPrefsObject ) Simply copies the preferences contained in the $otherPrefsObject into the current one, discarding anything that may currently be there. =cut sub inheritPrefs { my ($self, $otherPrefsObject) = @_; $self->{prefsKeys} = [ @{ $otherPrefsObject->{prefsKeys} } ]; $self->{prefsRegexps} = [ @{ $otherPrefsObject->{prefsRegexps} } ]; $self->{prefsVals} = [ @{ $otherPrefsObject->{prefsVals} } ]; $self->{finalHash} = { %{ $otherPrefsObject->{finalHash} } }; for (my $i = 0; $i < @{ $self->{prefsKeys} }; $i++) { $self->{prefsHash}{$self->{prefsKeys}[$i]} = \$self->{prefsVals}[$i]; } } =pod ---+++ sub replacePreferencesTags( $text ) Substitutes preferences values for =%PREF%= tags in =$text=, modifying that parameter in-place. =cut sub replacePreferencesTags { my $self = shift; my $x; my $term; my $keys = $self->{prefsKeys}; my $vals = $self->{prefsVals}; my $regexps = $self->{prefsRegexps}; for( $x = 0; $x < @$keys; $x++ ) { #$term = qr/%\Q$keys->[$x]\E%/; $_[0] =~ s/$regexps->[$x]/$vals->[$x]/ge; } } =pod ---+++ sub getPreferenceValue( $key ) Returns the stored preference with key =$key=, or "" if no such preference exists. =cut sub getPreferenceValue { my ($self, $theKey) = @_; if (exists($self->{prefsHash}{$theKey})) { return ${ $self->{prefsHash}{$theKey} }; #double dereference } else { return ""; } } =pod ---+++ sub getPreferenceFlag( $key ) Returns a preference as a flag. See =[[#sub_formatAsFlag_prefValue][Prefs::formatAsFlag]]= for details on how preference values are converted to flags. =cut sub getPreferenceFlag { my ( $self, $theKey ) = @_; my $value = $self->getPreferenceValue( $theKey ); return TWiki::Prefs::formatAsFlag( $value ); } # ============================================================================= package TWiki::Prefs; use vars qw( $globalPrefs %webPrefs $requestPrefs $requestWeb $finalPrefsName ); =pod ---++ TWiki::Prefs package This is the external interface to the Prefs module, and is how the rest of the TWiki code accesses preferences. ---+++ sub initializePrefs( $webName ) Resets all preference globals (for mod_perl compatibility), and reads preferences from TWiki::TWikiPreferences, Main::TWikiPreferences, and $webName::WebPreferences. =cut sub initializePrefs { my( $theWebName ) = @_; TWiki::Prefs::PrefsCache::clearCache(); # for mod_perl compatibility $requestWeb = $theWebName; $globalPrefs = TWiki::Prefs::PrefsCache->new("global"); $webPrefs{$requestWeb} = TWiki::Prefs::PrefsCache->new("web", $globalPrefs, $requestWeb); $requestPrefs = TWiki::Prefs::PrefsCache->new("copy", $webPrefs{$requestWeb}); return; } # ========================= =pod ---+++ sub initializeUserPrefs( $userPrefsTopic ) Called after user is known (potentially by Plugin), this function reads preferences from the user's personal topic. The parameter is the topic to read user-level preferences from (Generally "Main.CurrentUserName"). =cut sub initializeUserPrefs { my( $theWikiUserName ) = @_; $theWikiUserName = "Main.TWikiGuest" unless $theWikiUserName; if( $theWikiUserName =~ /^(.*)\.(.*)$/ ) { $requestPrefs = TWiki::Prefs::PrefsCache->new("request", $webPrefs{$requestWeb}, $TWiki::topicName, $2); } return; } # ========================= =pod ---+++ sub getPrefsFromTopic ( $web, $topic, $keyPrefix ) Reads preferences from the topic at =$theWeb.$theTopic=, prefixes them with =$theKeyPrefix= if one is provided, and adds them to the preference cache. =cut sub getPrefsFromTopic { my ($web, $topic, $keyPrefix) = @_; $requestPrefs->loadPrefsFromTopic($web, $topic, $keyPrefix, 1); } # ========================= =pod ---+++ sub updateSetFromForm ( $meta, $text ) Return value: $newText If there are any settings "Set SETTING = value" in =$text= for a setting that is set in form metadata in =$meta=, these are changed so that the value in the =$text= setting is the same as the one set in the =$meta= form. =$text= is not modified; rather, a new copy with these changes is returned. =cut sub updateSetFromForm { my( $meta, $text ) = @_; my( $key, $value ); my $ret = ""; my %form = $meta->findOne( "FORM" ); if( %form ) { my @fields = $meta->find( "FIELD" ); foreach my $line ( split( /\n/, $text ) ) { foreach my $field ( @fields ) { $key = $field->{"name"}; $value = $field->{"value"}; my $attributes = $field->{"attributes"}; if( $attributes && $attributes =~ /[S]/o ) { $value =~ s/\n/\\\n/o; ##TWiki::writeDebug( "updateSetFromForm: \"$key\"=\"$value\"" ); # Worry about verbatim? Multi-lines if ( $line =~ s/^(\t+\*\sSet\s$key\s\=\s*).*$/$1$value/g ) { last; } } } $ret .= "$line\n"; } } else { $ret = $text; } return $ret; } # ========================= =pod ---+++ sub handlePreferencesTags ( $text ) Replaces %PREF% and %VAR{"pref"}% syntax in $text, modifying that parameter in-place. =cut sub handlePreferencesTags { my $textRef = \$_[0]; $requestPrefs->replacePreferencesTags($$textRef); if( $$textRef =~ /\%VAR{(.*?)}\%/ ) { # handle web specific variables $$textRef =~ s/\%VAR{(.*?)}\%/prvGetWebVariable($1)/ge; } } =pod ---+++ sub prvGetWebVariable( $attributeString ) Returns the value for a %VAR{"foo" web="bar"}% syntax, given the stuff inside the {}'s. =cut sub prvGetWebVariable { my ( $attributeString ) = @_; my $key = &TWiki::extractNameValuePair( $attributeString ); my $attrWeb = &TWiki::extractNameValuePair( $attributeString, "web" ); if( $attrWeb =~ /%[A-Z]+%/ ) { # handle %MAINWEB%-type cases &TWiki::handleInternalTags( $attrWeb, $requestWeb, "dummy" ); } return getPreferencesValue( $key, $attrWeb); } =pod ---+++ sub formatAsFlag( $prefValue ) Returns 1 if the =$prefValue= is "on", and 0 otherwise. "On" means set to something with a true Perl-truth-value, with the special cases that "off" and "no" are forced to false. (Both of the latter are case-insensitive.) Note also that leading and trailing whitespace on =$prefValue= will be stripped prior to this conversion. =cut sub formatAsFlag { my ( $value ) = @_; $value =~ s/^\s*(.*?)\s*$/$1/gi; $value =~ s/off//gi; $value =~ s/no//gi; if( $value ) { return 1; } else { return 0; } } =pod ---+++ sub formatAsNumber( $prefValue ) Converts the string =$prefValue= to a number. First any whitespace and commas are removed. L10N note: assumes thousands separator is comma and decimal point is period. Then, if the first character is a zero, the value is passed to oct(), which will interpret hex (0x prefix), octal (leading zero only), or binary (0b prefix) numbers. If the first character is a digit greater than zero, the value is assumed to be a decimal number and returned. If the =$prefValue= is empty or not a number, zero is returned. Finally, if =$prefValue= is undefined, an undefined value is returned. Undefined preferences are automatically converted to empty strings, and so this function will always return zero for these, rather than 'undef'. =cut sub formatAsNumber { my ( $strValue ) = @_; return undef unless defined( $strValue ); $strValue =~ s/[,\s]+//g; if ($strValue =~ /^0/) { return oct($strValue); # hex/octal/binary } elsif ($strValue =~ /^(\d|\.\d)/) { return $strValue; # decimal } else { return 0; # empty/non-numeric } } =pod ---+++ sub getPreferencesValue ( $theKey, $theWeb ) Returns the value of the preference =$theKey=. If =$theWeb= is also specified, looks up the value with respect to that web instead of the current one; also, in this case user/topic preferences are not considered. In any case, if a plugin supports sessions and provides a value for =$theKey=, this value overrides all preference settings in any web. =cut sub getPreferencesValue { my ( $theKey, $theWeb ) = @_; my $sessionValue = &TWiki::getSessionValue( $theKey ); if( defined( $sessionValue ) ) { return $sessionValue; } if ($theWeb) { if (!exists $webPrefs{$theWeb}) { $webPrefs{$theWeb} = TWiki::Prefs::PrefsCache->new("web", $globalPrefs, $theWeb); } return $webPrefs{$theWeb}->getPreferenceValue($theKey); } else { return $requestPrefs->getPreferenceValue($theKey) if defined $requestPrefs; if (exists $webPrefs{$requestWeb}) { return $webPrefs{$requestWeb}->getPreferenceValue($theKey); # user/topic prefs not yet init'd } } } # ========================= =pod ---+++ sub getPreferencesFlag ( $theKey, $theWeb ) Returns the preference =$theKey= from =$theWeb= as a flag. See =getPreferencesValue= for the semantics of the parameters, and =[[#sub_formatAsFlag_prefValue][formatAsFlag]]= for the method of interpreting a value as a flag. =cut sub getPreferencesFlag { my ( $theKey, $theWeb ) = @_; my $value = getPreferencesValue( $theKey, $theWeb ); return formatAsFlag($value); } =pod ---+++ sub getPreferencesNumber ( $theKey, $theWeb ) Returns the preference =$theKey= from =$theWeb= as a flag. See =getPreferencesValue= for the semantics of the parameters, and =[[#sub_formatAsNumber_prefValue][formatAsNumber]]= for the method of interpreting a value as a number. =cut sub getPreferencesNumber { my ( $theKey, $theWeb ) = @_; my $value = getPreferencesValue( $theKey, $theWeb ); return formatAsNumber($value); } # ========================= 1; =end twiki =cut # EOF