# TWiki Enterprise Collaboration Platform, http://TWiki.org/
#
# Copyright (C) 1999-2018 Peter Thoeny, peter[at]thoeny.org
# Copyright (C) 2006-2018 TWiki Contributors. All Rights Reserved.
# TWiki Contributors are listed in the AUTHORS file in the root of
# this distribution. NOTE: Please extend that file, not this notice.
#
# Additional copyrights apply to some or all of the code in this
# file as follows:
#
# Based on parts of Ward Cunninghams original Wiki and JosWiki.
# Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
# Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
#
# 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 3
# of the License, or (at your option) any later version. For
# more details read LICENSE in the root of this distribution.
#
# 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.
#
# As per the GPL, removal of this notice is prohibited.
package TWiki;
=pod
---+ package TWiki
TWiki operates by creating a singleton object (known as the Session
object) that acts as a point of reference for all the different
modules in the system. This package is the class for this singleton,
and also contains the vast bulk of the basic constants and the per-
site configuration mechanisms.
Global variables are avoided wherever possible to avoid problems
with CGI accelerators such as mod_perl.
---+++!! Public Data members
* =request= Pointer to the TWiki::Request
* =response= Pointer to the TWiki::Respose
* =context= Hash of context ids
* moved: =loginManager= TWiki::LoginManager singleton (moved to TWiki::Users)
* =plugins= TWiki::Plugins singleton
* =prefs= TWiki::Prefs singleton
* =remoteUser= Login ID when using ApacheLogin. Maintained for
compatibility only, do not use.
* =requestedWebName= Name of web found in URL path or =web= URL parameter
* =sandbox= TWiki::Sandbox singleton
* =scriptUrlPath= URL path to the current script. May be dynamically
extracted from the URL path if {GetScriptUrlFromCgi}.
Only required to support {GetScriptUrlFromCgi} and
not consistently used. Avoid.
* =security= TWiki::Access singleton
* =SESSION_TAGS= Hash of TWiki variables whose value is specific to
the current request.
* =store= TWiki::Store singleton
* =topicName= Name of topic found in URL path or =topic= URL
parameter
* =urlHost= Host part of the URL (including the protocol)
determined during intialisation and defaulting to
{DefaultUrlHost}
* =user= Unique user ID of logged-in user
* =users= TWiki::Users singleton
* =webName= Name of web found in URL path, or =web= URL parameter,
or {UsersWebName}
=cut
use strict;
use Assert;
use Error qw( :try );
use CGI;
$CGI::LIST_CONTEXT_WARN = 0;
use TWiki::Response;
use TWiki::Request;
use TWiki::Time;
require 5.010001; # Perl 5.10.1
# Site configuration constants
use vars qw( %cfg );
# Uncomment this and the __END__ to enable AutoLoader
#use AutoLoader 'AUTOLOAD';
# You then need to autosplit TWiki.pm:
# cd lib
# perl -e 'use AutoSplit; autosplit("TWiki.pm", "auto")'
# Other computed constants
use vars qw(
$TranslationToken
$percentSubstitute
$twikiLibDir
%regex
%functionTags
%contextFreeSyntax
%restDispatch
$VERSION $RELEASE
$TRUE
$FALSE
$sandbox
$engine
$ifParser
%scriptOnMaster
%httpHiddenField
);
# Token character that must not occur in any normal text - converted
# to a flag character if it ever does occur (very unlikely)
# TWiki uses $TranslationToken to mark points in the text. This is
# normally \0, which is not a useful character in any 8-bit character
# set we can find, nor in UTF-8. But if you *do* encounter problems
# with it, the workaround is to change $TranslationToken to something
# longer that is unlikely to occur in your text - for example
# muRfleFli5ble8leep (do *not* use punctuation characters or whitspace
# in the string!)
# See Codev.NationalCharTokenClash for more.
$TranslationToken= "\0";
# Hack to substitute a % into a non-printable character so that a
# search string can be passed from URLPARAM to SEARCH without variable
# expansion, e.g. for a literal search.
# (TWiki:Codev.NewModeSearchEncodingInENCODEandURLPARAM & Item7847)
$percentSubstitute = "\x1a";
=pod
---++ StaticMethod getTWikiLibDir() -> $path
Returns the full path of the directory containing TWiki.pm
=cut
sub getTWikiLibDir {
if( $twikiLibDir ) {
return $twikiLibDir;
}
# FIXME: Should just use $INC{"TWiki.pm"} to get path used to load this
# module.
my $dir = '';
foreach $dir ( @INC ) {
if( $dir && -e "$dir/TWiki.pm" ) {
$twikiLibDir = $dir;
last;
}
}
# fix path relative to location of called script
if( $twikiLibDir =~ /^\./ ) {
print STDERR "WARNING: TWiki lib path $twikiLibDir is relative; you should make it"
. " absolute, otherwise some scripts may not run from the command line.";
my $bin;
# TSA SMELL : Should not assume environment variables and get data from request
if( $ENV{SCRIPT_FILENAME} &&
$ENV{SCRIPT_FILENAME} =~ /^(.+)\/[^\/]+$/ ) {
# CGI script name
$bin = $1;
} elsif ( $0 =~ /^(.*)\/.*?$/ ) {
# program name
$bin = $1;
} else {
# last ditch; relative to current directory.
require Cwd;
import Cwd qw( cwd );
$bin = cwd();
}
$twikiLibDir = "$bin/$twikiLibDir/";
# normalize "/../" and "/./"
while ( $twikiLibDir =~ s|([\\/])[^\\/]+[\\/]\.\.[\\/]|$1| ) {
};
$twikiLibDir =~ s|([\\/])\.[\\/]|$1|g;
}
$twikiLibDir =~ s|([\\/])[\\/]*|$1|g; # reduce "//" to "/"
$twikiLibDir =~ s|[\\/]$||; # cut trailing "/"
return $twikiLibDir;
}
BEGIN {
require TWiki::Sandbox; # system command sandbox
require TWiki::Configure::Load; # read configuration files
$TRUE = 1;
$FALSE = 0;
if( DEBUG ) {
# If ASSERTs are on, then warnings are errors. Paranoid,
# but the only way to be sure we eliminate them all.
# Look out also for $cfg{WarningsAreErrors}, below, which
# is another way to install this handler without enabling
# ASSERTs
# ASSERTS are turned on by defining the environment variable
# TWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
# production environment, and no stack traces or paths are
# output to the browser.
$SIG{'__WARN__'} = sub { die @_ };
$Error::Debug = 1; # verbose stack traces, please
} else {
$Error::Debug = 0; # no verbose stack traces
}
# DO NOT CHANGE THE FORMAT OF $VERSION
# The $VERSION is automatically expanded on checkin of this module
$VERSION = '$Date: 2018-07-16 12:09:47 +0900 (Mon, 16 Jul 2018) $ $Rev: 30610 (2018-07-16) $ ';
$RELEASE = 'TWiki-6.1.0';
$VERSION =~ s/^.*?\((.*)\).*: (\d+) .*?$/$RELEASE, $1, build $2/;
# Default handlers for different %TAGS%
%functionTags = (
ADDTOHEAD => \&ADDTOHEAD,
ALLVARIABLES => \&ALLVARIABLES,
ATTACHURL => \&ATTACHURL,
ATTACHURLPATH => \&ATTACHURLPATH,
BASETOPIC => \&BASETOPIC,
BASEWEB => \&BASEWEB,
CONTENTMODE => \&CONTENTMODE,
CRYPTTOKEN => \&CRYPTTOKEN,
DATE => \&DATE,
DISKID => \&DISKID,
DISPLAYTIME => \&DISPLAYTIME,
EDITFORM => \&EDITFORM,
EDITFORMFIELD => \&EDITFORMFIELD,
ENCODE => \&ENCODE,
ENTITY => \&ENTITY,
ENV => \&ENV,
FORM => \&FORM,
FORMFIELD => \&FORMFIELD,
GMTIME => \&GMTIME,
GROUPS => \&GROUPS,
HIDE => \&HIDE,
HIDEINPRINT => \&HIDEINPRINT,
HTTP_HOST => \&HTTP_HOST_deprecated,
HTTP => \&HTTP,
HTTPS => \&HTTPS,
ICON => \&ICON,
ICONURL => \&ICONURL,
ICONURLPATH => \&ICONURLPATH,
IF => \&IF,
INCLUDE => \&INCLUDE,
INCLUDINGTOPIC => \&INCLUDINGTOPIC,
INCLUDINGWEB => \&INCLUDINGWEB,
INTURLENCODE => \&INTURLENCODE_deprecated,
LANGUAGES => \&LANGUAGES,
MAKETEXT => \&MAKETEXT,
MDREPO => \&MDREPO,
META => \&META,
METASEARCH => \&METASEARCH,
NOP => \&NOP,
PARENTTOPIC => \&PARENTTOPIC,
PLUGINVERSION => \&PLUGINVERSION,
PUBURL => \&PUBURL,
PUBURLPATH => \&PUBURLPATH,
QUERYPARAMS => \&QUERYPARAMS,
QUERYSTRING => \&QUERYSTRING,
RELATIVETOPICPATH => \&RELATIVETOPICPATH,
REMOTE_ADDR => \&REMOTE_ADDR_deprecated,
REMOTE_PORT => \&REMOTE_PORT_deprecated,
REMOTE_USER => \&REMOTE_USER_deprecated,
RENDERHEAD => \&RENDERHEAD,
REVINFO => \&REVINFO,
REVTITLE => \&REVTITLE,
REVARG => \&REVARG,
SCRIPTNAME => \&SCRIPTNAME,
SCRIPTURL => \&SCRIPTURL,
SCRIPTURLPATH => \&SCRIPTURLPATH,
SEARCH => \&SEARCH,
SEP => \&SEP,
SERVERTIME => \&SERVERTIME,
SPACEDTOPIC => \&SPACEDTOPIC_deprecated,
SPACEOUT => \&SPACEOUT,
'TMPL:P' => \&TMPLP,
TOPIC => \&TOPIC,
TOPICLIST => \&TOPICLIST,
TOPICTITLE => \&TOPICTITLE,
TRASHWEB => \&TRASHWEB,
URLENCODE => \&ENCODE,
URLPARAM => \&URLPARAM,
LANGUAGE => \&LANGUAGE,
USERINFO => \&USERINFO,
USERNAME => \&USERNAME_deprecated,
VAR => \&VAR,
WEB => \&WEB,
WEBLIST => \&WEBLIST,
WIKINAME => \&WIKINAME_deprecated,
WIKIUSERNAME => \&WIKIUSERNAME_deprecated,
WIKIWEBMASTER => \&WIKIWEBMASTER,
WIKIWEBMASTERNAME => \&WIKIWEBMASTERNAME,
# Constant tag strings _not_ dependent on config. These get nicely
# optimised by the compiler.
ENDSECTION => sub { '' },
WIKIVERSION => sub { $VERSION },
STARTSECTION => sub { '' },
STARTINCLUDE => sub { '' },
STOPINCLUDE => sub { '' },
);
$contextFreeSyntax{IF} = 1;
unless( ( $TWiki::cfg{DetailedOS} = $^O ) ) {
require Config;
$TWiki::cfg{DetailedOS} = $Config::Config{'osname'};
}
$TWiki::cfg{OS} = 'UNIX';
if ($TWiki::cfg{DetailedOS} =~ /darwin/i) { # MacOS X
$TWiki::cfg{OS} = 'UNIX';
} elsif ($TWiki::cfg{DetailedOS} =~ /Win/i) {
$TWiki::cfg{OS} = 'WINDOWS';
} elsif ($TWiki::cfg{DetailedOS} =~ /vms/i) {
$TWiki::cfg{OS} = 'VMS';
} elsif ($TWiki::cfg{DetailedOS} =~ /bsdos/i) {
$TWiki::cfg{OS} = 'UNIX';
} elsif ($TWiki::cfg{DetailedOS} =~ /dos/i) {
$TWiki::cfg{OS} = 'DOS';
} elsif ($TWiki::cfg{DetailedOS} =~ /^MacOS$/i) { # MacOS 9 or earlier
$TWiki::cfg{OS} = 'MACINTOSH';
} elsif ($TWiki::cfg{DetailedOS} =~ /os2/i) {
$TWiki::cfg{OS} = 'OS2';
}
# Validate and untaint Apache's SERVER_NAME Environment variable
# for use in referencing virtualhost-based paths for separate data/ and templates/ instances, etc
if ( $ENV{SERVER_NAME} &&
$ENV{SERVER_NAME} =~ /^(([a-zA-Z0-9]([a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]{2,6})$/ ) {
$ENV{SERVER_NAME} =
TWiki::Sandbox::untaintUnchecked( $ENV{SERVER_NAME} );
}
# readConfig is defined in TWiki::Configure::Load to allow overriding it
TWiki::Configure::Load::readConfig();
if( $TWiki::cfg{WarningsAreErrors} ) {
# Note: Warnings are always errors if ASSERTs are enabled
$SIG{'__WARN__'} = sub { die @_ };
}
if( $TWiki::cfg{UseLocale} ) {
require locale;
import locale();
}
# Constant tags dependent on the config
$functionTags{ALLOWLOGINNAME} =
sub { $TWiki::cfg{Register}{AllowLoginName} || 0 };
$functionTags{AUTHREALM} = sub { $TWiki::cfg{AuthRealm} };
$functionTags{DEFAULTURLHOST} = sub { $TWiki::cfg{DefaultUrlHost} };
$functionTags{HOMETOPIC} = sub { $TWiki::cfg{HomeTopicName} };
$functionTags{LOCALSITEPREFS} = sub { $TWiki::cfg{LocalSitePreferences} };
$functionTags{NOFOLLOW} =
sub { $TWiki::cfg{NoFollow} ? 'rel='.$TWiki::cfg{NoFollow} : '' };
$functionTags{NOTIFYTOPIC} = sub { $TWiki::cfg{NotifyTopicName} };
$functionTags{SCRIPTSUFFIX} = sub { $TWiki::cfg{ScriptSuffix} };
$functionTags{SITESTATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{SiteStatsTopicName} };
$functionTags{STATISTICSTOPIC} = sub { $TWiki::cfg{Stats}{TopicName} };
$functionTags{SYSTEMWEB} = sub { $TWiki::cfg{SystemWebName} };
# $functionTags{TRASHWEB} = sub { $TWiki::cfg{TrashWebName} };
$functionTags{TWIKIADMINLOGIN} = sub { $TWiki::cfg{AdminUserLogin} };
$functionTags{USERSWEB} = sub { $TWiki::cfg{UsersWebName} };
$functionTags{WEBPREFSTOPIC} = sub { $TWiki::cfg{WebPrefsTopicName} };
$functionTags{WIKIPREFSTOPIC} = sub { $TWiki::cfg{SitePrefsTopicName} };
$functionTags{WIKIUSERSTOPIC} = sub { $TWiki::cfg{UsersTopicName} };
if ( $TWiki::cfg{UserSubwebs}{Enabled} ) {
$functionTags{USERPREFSTOPIC} =
sub { $TWiki::cfg{UserSubwebs}{UserPrefsTopicName} };
}
# Compatibility synonyms, deprecated in 4.2 but still used throughout
# the documentation.
$functionTags{MAINWEB} = $functionTags{USERSWEB};
$functionTags{TWIKIWEB} = $functionTags{SYSTEMWEB};
# locale setup
#
#
# Note that 'use locale' must be done in BEGIN block for regexes and
# sorting to work properly, although regexes can still work without
# this in 'non-locale regexes' mode.
if ( $TWiki::cfg{UseLocale} ) {
# Set environment variables for grep
$ENV{LC_CTYPE} = $TWiki::cfg{Site}{Locale};
# Load POSIX for I18N support.
require POSIX;
import POSIX qw( locale_h LC_CTYPE LC_COLLATE );
# SMELL: mod_perl compatibility note: If TWiki is running under Apache,
# won't this play with the Apache process's locale settings too?
# What effects would this have?
setlocale(&LC_CTYPE, $TWiki::cfg{Site}{Locale});
setlocale(&LC_COLLATE, $TWiki::cfg{Site}{Locale});
}
$functionTags{CHARSET} = sub { $TWiki::cfg{Site}{CharSet} ||
'iso-8859-1' };
# HTML 4.01 and XML refers to RFC 4646 with language specification.
# RFC 4646 dictates the delimiter to be a hyphen rather than an underscore.
my $lang = $TWiki::cfg{Site}{Lang};
unless ( $lang ) {
if ( $TWiki::cfg{Site}{Locale} =~ m/^([a-z]+_[a-z]+)/i ) {
$lang = $1;
$lang =~ s/_/-/;
}
else {
$lang = 'en-US';
}
}
$functionTags{LANG} = sub { $lang };
# Set up pre-compiled regexes for use in rendering. All regexes with
# unchanging variables in match should use the '/o' option.
# In the regex hash, all precompiled REs have "Regex" at the
# end of the name. Anything else is a string, either intended
# for use as a character class, or as a sub-expression in
# another compiled RE.
# Build up character class components for use in regexes.
# Depends on locale mode and Perl version, and finally on
# whether locale-based regexes are turned off.
if ( not $TWiki::cfg{UseLocale} or $] < 5.006
or not $TWiki::cfg{Site}{LocaleRegexes} ) {
# No locales needed/working, or Perl 5.005, so just use
# any additional national characters defined in TWiki.cfg
$regex{upperAlpha} = 'A-Z'.$TWiki::cfg{UpperNational};
$regex{lowerAlpha} = 'a-z'.$TWiki::cfg{LowerNational};
$regex{numeric} = '\d';
$regex{mixedAlpha} = $regex{upperAlpha}.$regex{lowerAlpha};
} else {
# Perl 5.006 or higher with working locales
$regex{upperAlpha} = '[:upper:]';
$regex{lowerAlpha} = '[:lower:]';
$regex{numeric} = '[:digit:]';
$regex{mixedAlpha} = '[:alpha:]';
}
$regex{mixedAlphaNum} = $regex{mixedAlpha}.$regex{numeric};
$regex{lowerAlphaNum} = $regex{lowerAlpha}.$regex{numeric};
$regex{upperAlphaNum} = $regex{upperAlpha}.$regex{numeric};
# Compile regexes for efficiency and ease of use
# Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
# book at http://regex.info/.
$regex{linkProtocolPattern} = $TWiki::cfg{LinkProtocolPattern};
# Header patterns based on '+++'. The '###' are reserved for numbered
# headers
# '---++ Header', '---## Header'
$regex{headerPatternDa} = qr/^---+(\++|\#+)(.*)$/m;
# 'Header
$regex{headerPatternHt} = qr/^(.+?)<\/h\1>/mi;
# '---++!! Header' or '---++ Header %NOTOC% ^top'
$regex{headerPatternNoTOC} = '(\!\!+|%NOTOC%)';
# TWiki concept regexes
$regex{wikiWordRegex} = qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
$regex{webNameBaseRegex} = qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
if ($TWiki::cfg{EnableHierarchicalWebs}) {
$regex{webNameRegex} = qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
} else {
$regex{webNameRegex} = $regex{webNameBaseRegex};
}
$regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
$regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
$regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
# used by _fixIncludeLink: (the last OR pattern is for Interwiki link fix Item6463)
$regex{excludeFixIncludeLinkRegex} =
qr/($regex{webNameRegex}\.|$regex{defaultWebNameRegex}\.|$regex{linkProtocolPattern}:|\/|[$regex{upperAlpha}][$regex{mixedAlphaNum}]+:)/o;
# Simplistic email regex, e.g. for WebNotify processing - no i18n
# characters allowed
$regex{emailAddrRegex} = qr/([A-Za-z0-9\.\+\-\_\']+\@[A-Za-z0-9\.\-]*[A-Za-z0-9])/;
# Filename regex to used to match invalid characters in attachments - allow
# alphanumeric characters, spaces, underscores, etc.
# TODO: Get this to work with I18N chars - currently used only with UseLocale off
$regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o;
# Multi-character alpha-based regexes
$regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
# %TAG% name
$regex{tagNameRegex} = '['.$regex{mixedAlpha}.']['.$regex{mixedAlphaNum}.'_:]*';
# Set statement in a topic
$regex{bulletRegex} = '^(?:\t| )+\*';
$regex{setRegex} = $regex{bulletRegex}.'\s+(Set|Local)\s+';
$regex{setVarRegex} = $regex{setRegex}.'('.$regex{tagNameRegex}.')\s*=\s*(.*)$';
# Character encoding regexes
# 7-bit ASCII only
$regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
# Regex to match only a valid UTF-8 character, taking care to avoid
# security holes due to overlong encodings by excluding the relevant
# gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
# Encodings section. Tested against Markus Kuhn's UTF-8 test file
# at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
$regex{validUtf8CharRegex} = qr{
# Single byte - ASCII
[\x00-\x7F]
|
# 2 bytes
[\xC2-\xDF][\x80-\xBF]
|
# 3 bytes
# Avoid illegal codepoints - negative lookahead
(?!\xEF\xBF[\xBE\xBF])
# Match valid codepoints
(?:
([\xE0][\xA0-\xBF])|
([\xE1-\xEC\xEE-\xEF][\x80-\xBF])|
([\xED][\x80-\x9F])
)
[\x80-\xBF]
|
# 4 bytes
(?:
([\xF0][\x90-\xBF])|
([\xF1-\xF3][\x80-\xBF])|
([\xF4][\x80-\x8F])
)
[\x80-\xBF][\x80-\xBF]
}xo;
$regex{validUtf8StringRegex} =
qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
# Check for unsafe search regex mode (affects filtering in) - default
# to safe mode
$TWiki::cfg{ForceUnsafeRegexes} = 0 unless defined $TWiki::cfg{ForceUnsafeRegexes};
# scripts which cannot work for a slave web
if ( $TWiki::cfg{ReadOnlyAndMirrorWebs}{ScriptOnMaster} ) {
for my $script (
split(/[\s,]+/,
$TWiki::cfg{ReadOnlyAndMirrorWebs}{ScriptOnMaster})
) {
$scriptOnMaster{$script} = 1;
}
}
# HTTP header fields not be exposed to users
if ( $TWiki::cfg{HTTP}{HiddenFields} ) {
for my $field (
split(/[\s,]+/,
$TWiki::cfg{HTTP}{HiddenFields})
) {
$field = lc $field;
$field =~ s/_/-/g;
$httpHiddenField{$field} = 1;
}
}
# initialize lib directory early because of later 'cd's
getTWikiLibDir();
# initialize the runtime engine
if (!defined $TWiki::cfg{Engine}) {
# Caller did not define an engine; try and work it out (mainly for
# the benefit of pre-5.0 CGI scripts)
if ( defined $ENV{GATEWAY_INTERFACE} or defined $ENV{MOD_PERL} ) {
$TWiki::cfg{Engine} = 'TWiki::Engine::CGI';
use CGI::Carp qw(fatalsToBrowser);
$SIG{__DIE__} = \&CGI::Carp::confess;
} else {
$TWiki::cfg{Engine} = 'TWiki::Engine::CLI';
require Carp;
$SIG{__DIE__} = \&Carp::confess;
}
}
$engine ||= eval qq(use $TWiki::cfg{Engine}; $TWiki::cfg{Engine}->new);
die $@ if $@;
};
=pod
---++ ObjectMethod UTF82SiteCharSet( $utf8 ) -> $ascii
Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
charset.
=cut
sub UTF82SiteCharSet {
my( $this, $text ) = @_;
return $text unless( defined $TWiki::cfg{Site}{CharSet} );
# Detect character encoding of the full topic name from URL
return undef if( $text =~ $regex{validAsciiStringRegex} );
# If not UTF-8 - assume in site character set, no conversion required
return undef unless( $text =~ $regex{validUtf8StringRegex} );
# If site charset is already UTF-8, there is no need to convert anything:
if ( $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
# warn if using Perl older than 5.8
if( $] < 5.008 ) {
$this->writeWarning( 'UTF-8 not remotely supported on Perl '.$].
' - use Perl 5.8 or higher..' );
}
return $text;
}
# Convert into ISO-8859-1 if it is the site charset. This conversion
# is *not valid for ISO-8859-15*.
if ( $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
# ISO-8859-1 maps onto first 256 codepoints of Unicode
# (conversion from 'perldoc perluniintro')
$text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) /
chr( ord($1) << 6 & 0xC0 | ord($2) & 0x3F )
/egx;
} else {
# Convert from UTF-8 into some other site charset
if( $] >= 5.008 ) {
require Encode;
import Encode qw(:fallbacks);
# Map $TWiki::cfg{Site}{CharSet} into real encoding name
my $charEncoding =
Encode::resolve_alias( $TWiki::cfg{Site}{CharSet} );
if( not $charEncoding ) {
$this->writeWarning
( 'Conversion to "'.$TWiki::cfg{Site}{CharSet}.
'" not supported, or name not recognised - check '.
'"perldoc Encode::Supported"' );
} else {
# Convert text using Encode:
# - first, convert from UTF8 bytes into internal
# (UTF-8) characters
$text = Encode::decode('utf8', $text);
# - then convert into site charset from internal UTF-8,
# inserting \x{NNNN} for characters that can't be converted
$text =
Encode::encode( $charEncoding, $text,
&FB_PERLQQ() );
}
} else {
require Unicode::MapUTF8; # Pre-5.8 Perl versions
my $charEncoding = $TWiki::cfg{Site}{CharSet};
if( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
$this->writeWarning
( 'Conversion to "'.$TWiki::cfg{Site}{CharSet}.
'" not supported, or name not recognised - check '.
'"perldoc Unicode::MapUTF8"' );
} else {
# Convert text
$text =
Unicode::MapUTF8::from_utf8({
-string => $text,
-charset => $charEncoding
});
# FIXME: Check for failed conversion?
}
}
}
return $text;
}
=pod
---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType, $status )
Write a complete HTML page with basic header to the browser.
* =$text= is the text of the page body (<html> to </html> if it's HTML)
* =$pageType= - May be "edit", which will cause headers to be generated that force
caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
data loss with IE5 and IE6.
* =$contentType= - page content type | text/html
* =$status= - page status | 200 OK
This method removes noautolink and nop tags before outputting the page unless
$contentType is text/plain.
=cut
sub writeCompletePage {
my ( $this, $text, $pageType, $contentType, $status ) = @_;
# Item7197: Check utf-8 flag
if( $] >= 5.008 ) {
require Encode;
if( Encode::is_utf8( $text ) ) {
$this->writeWarning("UTF-8 flag is detected in the text (possibly from some plugins?), which should be remediated");
$text = Encode::encode_utf8($text);
}
}
$contentType ||= 'text/html';
if( $contentType ne 'text/plain' ) {
# Remove and tags
$text =~ s/([\t ]?)[ \t]*<\/?(nop|noautolink)\/?>/$1/gis;
$text .= "\n" unless $text =~ /\n$/s;
# If TWiki is enabled for CryptToken for CSRF kind of
# security issues, send all forms for adding token before
# presenting to the browser
if ($TWiki::cfg{CryptToken}{Enable}) {
$text =~ s/()/$this->{users}->{loginManager}->addCryptTokeninForm($1)/geos;
}
my $htmlHeader = join(
"\n",
map { ''.$this->{_HTMLHEADERS}{$_} }
keys %{$this->{_HTMLHEADERS}} );
$text =~ s!()!$htmlHeader$1!i if $htmlHeader;
chomp($text);
}
$this->generateHTTPHeaders( $pageType, $contentType, $status );
my $hdr;
foreach my $header ( keys %{ $this->{response}->headers } ) {
$hdr .= $header . ': ' . $_ . "\x0D0A"
foreach $this->{response}->getHeader($header);
}
$hdr .= "\x0D0A";
# Call final handler
$this->{plugins}->dispatch(
'completePageHandler',$text, $hdr);
$this->{response}->body($text);
}
=pod
---++ ObjectMethod generateHTTPHeaders ($pageType, $contentType, $status ) -> $header
All parameters are optional.
* =$pageType= - May be "edit", which will cause headers to be generated that force caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused data loss with IE5 and IE6.
* =$contentType= - page content type | text/html
* =$status= - page status | 200 OK
Implements the post-Dec2001 release plugin API, which requires the
writeHeaderHandler in plugin to return a string of HTTP headers, CR/LF
delimited. Filters any illegal headers. Plugin headers will override
core settings.
Does *not* add a =Content-length= header.
=cut
sub generateHTTPHeaders {
my( $this, $pageType, $contentType, $status ) = @_;
my $query = $this->{request};
# Handle Edit pages - future versions will extend to caching
# of other types of page, with expiry time driven by page type.
my( $pluginHeaders, $coreHeaders );
my $hopts = {};
if ($pageType && $pageType eq 'edit') {
# Get time now in HTTP header format
my $lastModifiedString =
TWiki::Time::formatTime(time, '$http', 'gmtime');
# Expiry time is set high to avoid any data loss. Each instance of
# Edit page has a unique URL with time-string suffix (fix for
# RefreshEditPage), so this long expiry time simply means that the
# browser Back button always works. The next Edit on this page
# will use another URL and therefore won't use any cached
# version of this Edit page.
my $expireHours = 24;
my $expireSeconds = $expireHours * 60 * 60;
# and cache control headers, to ensure edit page
# is cached until required expiry time.
$hopts->{'last-modified'} = $lastModifiedString;
$hopts->{expires} = "+${expireHours}h";
$hopts->{'cache-control'} = "max-age=$expireSeconds";
}
# DEPRECATED plugins header handler. Plugins should use
# modifyHeaderHandler instead.
$pluginHeaders = $this->{plugins}->dispatch(
'writeHeaderHandler', $query ) || '';
if( $pluginHeaders ) {
foreach ( split /\r?\n/, $pluginHeaders ) {
if ( m/^([\-a-z]+): (.*)$/i ) {
$hopts->{$1} = $2;
}
}
}
$contentType = 'text/html' unless $contentType;
if( defined( $TWiki::cfg{Site}{CharSet} )) {
$contentType .= '; charset='.$TWiki::cfg{Site}{CharSet};
}
# use our version of the content type
$hopts->{'Content-Type'} = $contentType;
# Item7193: Disable XSS Protection to make JavaScript work when a topic is
# saved with JavaScript contained.
if ( isTrue( $TWiki::cfg{DisableXSSProtection} ) ) {
$hopts->{'X-XSS-Protection'} = '0';
}
if ( $status ) {
$hopts->{Status} = $status;
}
# New (since 1.026)
$this->{plugins}->dispatch(
'modifyHeaderHandler', $hopts, $this->{request} );
# add cookie(s)
$this->{users}->{loginManager}->modifyHeader( $hopts );
$this->{response}->setDefaultHeaders( $hopts );
}
=pod
---++ StaticMethod isRedirectSafe($redirect) => $ok
tests if the $redirect is an external URL, returning false if AllowRedirectUrl is denied
=cut
sub isRedirectSafe {
my $redirect = shift;
return 1 if ($TWiki::cfg{AllowRedirectUrl});
#TODO: this should really use URI
if ( $redirect =~ m!^([^:]*://[^/]*)/*(.*)?$! ) {
my $host = $1;
#remove trailing /'s to match
$TWiki::cfg{DefaultUrlHost} =~ m!^([^:]*://[^/]*)/*(.*)?$!;
my $expected = $1;
return 1 if (uc($host) eq uc($expected));
if (defined($TWiki::cfg{PermittedRedirectHostUrls} ) && $TWiki::cfg{PermittedRedirectHostUrls} ne '') {
my @permitted =
map { s!^([^:]*://[^/]*)/*(.*)?$!$1!; $1 }
split(/,\s*/, $TWiki::cfg{PermittedRedirectHostUrls});
return 1 if ( grep ( { uc($host) eq uc($_) } @permitted));
}
return 0;
}
return 1;
}
# _getRedirectUrl() => redirectURL set from the parameter
# Reads a redirect url from CGI parameter 'redirectto'.
# This function is used to get and test the 'redirectto' cgi parameter,
# and then the calling function can set its own reporting if there is a
# problem.
sub _getRedirectUrl {
my $session = shift;
my $query = $session->{request};
my $redirecturl = $query->param( 'redirectto' );
return '' unless $redirecturl;
if ( $redirecturl =~ /AUTOINC/ && defined $session->{AUTOINC} ) {
$redirecturl =~ s//$session->{AUTOINC}/g;
}
my $sessionParam = {
web => $session->{webName},
topic => $session->{topicName},
};
$redirecturl =~ s/\$\{([^{}]*)\}|\$(\w+)/
my $v = ($1 || $2);
urlEncode($query->param($v) || $sessionParam->{$v} || '')/eg;
if( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) {
# assuming URL
if (isRedirectSafe($redirecturl)) {
return $redirecturl;
} else {
return '';
}
}
# assuming 'web.topic' or 'topic'
my $urlParams = '';
if ( $redirecturl =~ /\?(.*)$/ ) {
$urlParams = $1;
$redirecturl =~ s///;
}
my ( $w, $t ) = $session->normalizeWebTopicName( $session->{webName}, $redirecturl );
$redirecturl = $session->getScriptUrl( 1, 'view', $w, $t );
return $redirecturl . ($urlParams eq '' ? '' : '?' . $urlParams);
}
=pod
---++ ObjectMethod redirect( $url, $passthrough, $action_redirectto, $viaCache )
* $url - url or twikitopic to redirect to
* $passthrough - (optional) parameter to **FILLMEIN**
* $action_redirectto - (optional) redirect to where ?redirectto=
points to (if it's valid)
* $viaCache - forcibly cache a redirect CGI query. It cuts off all
the params in a GET url and replace with a "?$cache=..." param.
Redirects the request to =$url=, *unless*
1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
1 =$session->{request}= is =undef= or
1 $query->param('noredirect') is set to a true value.
Thus a redirect is only generated when in a CGI context.
Normally this method will ignore parameters to the current query. Sometimes,
for example when redirecting to a login page during authentication (and then
again from the login page to the original requested URL), you want to make
sure all parameters are passed on, and for this $passthrough should be set to
true. In this case it will pass all parameters that were passed to the
current query on to the redirect target. If the request_method for the
current query was GET, then all parameters will be passed by encoding them
in the URL (after ?). If the request_method was POST, then there is a risk the
URL would be too big for the receiver, so it caches the form data and passes
over a cache reference in the redirect GET.
NOTE: Passthrough is only meaningful if the redirect target is on the same
server. "$viaCache" is meaningful only if "$action_redirectto" is false and
"$passthru" is true.
=cut
sub redirect {
my( $this, $url, $passthru, $action_redirectto, $viaCache ) = @_;
my $query = $this->{request};
# if we got here without a query, there's not much more we can do
return unless $query;
# SMELL: if noredirect is set, don't generate the redirect, throw an
# exception instead. This is a HACK used to support TWikiDrawPlugin.
# It is deprecated and must be replaced by REST handlers in the plugin.
if( $query->param( 'noredirect' )) {
die "ERROR: $url";
return;
}
if ($action_redirectto) {
my $redir = _getRedirectUrl($this);
$url = $redir if ($redir);
}
if ( $passthru && defined $query->request_method() ) {
my $existing = '';
if ($url =~ s/\?(.*)$//) {
$existing = $1;
}
if ( $query->request_method() =~ /^POST$/i || $viaCache ) {
# Redirecting from a post to a get
my $cache = $this->cacheQuery();
if ($cache) {
$url .= "?$cache";
}
} else {
if ($query->query_string()) {
$url .= '?'.$query->query_string();
}
if ($existing) {
if ($url =~ /\?/) {
$url .= ';';
} else {
$url .= '?';
}
$url .= $existing;
}
}
}
# prevent phishing by only allowing redirect to configured host
# do this check as late as possible to catch _any_ last minute hacks
# TODO: this should really use URI
if (!isRedirectSafe($url)) {
# goto oops if URL is trying to take us somewhere dangerous
$url = $this->getScriptUrl(
1, 'oops',
$this->{web} || $TWiki::cfg{UsersWebName},
$this->{topic} || $TWiki::cfg{HomeTopicName},
template => 'oopsaccessdenied',
def => 'topic_access',
param1 => 'redirect',
param2 => 'unsafe redirect to '.$url.
': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'.
$TWiki::cfg{DefaultUrlHost}.'"'
);
}
return if( $this->{plugins}->dispatch(
'redirectCgiQueryHandler', $this->{response}, $url ));
# SMELL: this is a bad breaking of encapsulation: the loginManager
# should just modify the url, then the redirect should only happen here.
return !$this->{users}->{loginManager}->redirectCgiQuery( $query, $url );
}
=pod
---++ ObjectMethod cacheQuery() -> $queryString
Caches the current query in the params cache, and returns a rewritten
query string for the cache to be picked up again on the other side of a
redirect.
We can't encode post params into a redirect, because they may exceed the
size of the GET request. So we cache the params, and reload them when the
redirect target is reached.
=cut
sub cacheQuery {
my $this = shift;
my $query = $this->{request};
return '' unless (scalar($query->param()));
# Don't double-cache
return '' if ($query->param('twiki_redirect_cache'));
require Digest::MD5;
my $md5 = new Digest::MD5();
$md5->add($$, time(), rand(time));
my $uid = $md5->hexdigest();
my $passthruFilename = "$TWiki::cfg{WorkingDir}/tmp/passthru_$uid";
use Fcntl;
#passthrough file is only written to once, so if it already exists, suspect a security hack (O_EXCL)
sysopen(F, "$passthruFilename", O_RDWR|O_EXCL|O_CREAT, 0600) ||
die "Unable to open $TWiki::cfg{WorkingDir}/tmp for write; check the setting of"
. " {WorkingDir} in configure, and check file permissions: $!";
$query->save(\*F);
close(F);
return 'twiki_redirect_cache='.$uid;
}
=pod
---++ StaticMethod isValidWikiWord( $name ) -> $boolean
Check for a valid WikiWord or WikiName
=cut
sub isValidWikiWord {
my $name = shift || '';
return ( $name =~ m/^$regex{wikiWordRegex}$/o )
}
=pod
---++ StaticMethod isValidTopicName( $name ) -> $boolean
Check for a valid topic name
=cut
sub isValidTopicName {
my( $name ) = @_;
return isValidWikiWord( @_ ) || isValidAbbrev( @_ );
}
=pod
---++ StaticMethod isValidAbbrev( $name ) -> $boolean
Check for a valid ABBREV (acronym)
=cut
sub isValidAbbrev {
my $name = shift || '';
return ( $name =~ m/^$regex{abbrevRegex}$/o )
}
=pod
---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
STATIC Check for a valid web name. If $system is true, then
system web names are considered valid (names starting with _)
otherwise only user web names are valid
If $TWiki::cfg{EnableHierarchicalWebs} is off, it will also return false
when a nested web name is passed to it.
=cut
sub isValidWebName {
my $name = shift || '';
my $sys = shift;
return 0 if ( $name =~ m/$TWiki::cfg{InvalidWebNameRegex}/o ); # Item7838
return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
return ( $name =~ m/^$regex{webNameRegex}$/o )
}
=pod
---++ ObjectMethod modeAndMaster( $web )
Returns the following hash reference such as this:
('', undef)
and this:
('slave', { # master site data
siteName => 'na',
webScriptUrlTmpl => 'http://twiki.example.com/cgi-bin//Web',
scriptSuffix => '',
webViewUrl => 'http://twiki.example.com/Web',
})
The first value is the mode of the web: either 'local', 'master', 'slave',
or 'read-only'. The second value is defined only when the master site is
defined for the web.
=cut
sub modeAndMaster {
my ($this, $web) = @_;
my $mode = 'local'; # by default a web is local
if ( !$TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} ) {
return ($mode, undef);
}
my $cache = $this->{modeAndMaster} ||= {};
if ( my $cached = $cache->{$web} ) {
return @$cached
}
my $cacheHereToo;
my $masterSite;
my %master;
if ( my $mdrepo = $this->{mdrepo} ) {
my $tlweb = topLevelWeb($web);
if ( my $cached = $cache->{$tlweb} ) {
$cache->{$web} = $cached if ( $tlweb ne $web );
return @$cached;
}
$cacheHereToo = $tlweb ne $web ? $tlweb : '';
my $webRec = $mdrepo->getRec('webs', topLevelWeb($web));
if ( $webRec ) {
if ( $masterSite = $webRec->{master} ) {
$master{siteName} = $masterSite;
my $siteRec = $mdrepo->getRec('sites', $masterSite);
if ( $siteRec && $siteRec->{scripturl} ) {
$master{webScriptUrlTmpl} =
$siteRec->{scripturl} . '//' . $web;
$master{scriptSuffix} = $siteRec->{scriptsuffix};
$master{webViewUrl} = $siteRec->{viewurl} . '/' . $web
if ( $siteRec->{viewurl} );
}
}
}
# If the metadata repository is in use and the web's record
# doesn't exist or doesn't have the master field, then the web
# is regarded as 'local'.
# No fall back to the none metadata repository situation processed
# below.
}
else {
my $prefs = $this->{prefs};
$masterSite = $prefs->getWebPreferencesValue('MASTERSITENAME', $web);
if ( $masterSite ) {
$master{siteName} = $masterSite;
$master{webScriptUrlTmpl} =
$prefs->getWebPreferencesValue('MASTERWEBSCRIPTURLTMPL', $web);
$master{scriptSuffix} =
$prefs->getWebPreferencesValue('MASTERSCRIPTSUFFIX', $web);
$master{webViewUrl} =
$prefs->getWebPreferencesValue('MASTERWEBVIEWURL', $web);
}
}
if ( $masterSite ) {
if ( $masterSite eq $TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} ) {
$mode = 'master';
}
else {
if ( $master{webScriptUrlTmpl} ) {
$mode = 'slave';
}
else {
$mode = 'read-only'
}
}
}
my $result = $cache->{$web} = [$mode, %master ? \%master : undef];
$cache->{$cacheHereToo} = $result if ( $cacheHereToo );
return @$result;
}
=pod
---++ ObjectMethod getSkin () -> $string
Get the currently requested skin path
=cut
sub getSkin {
my $this = shift;
my $skinpath = $this->{prefs}->getPreferencesValue( 'SKIN' ) || '';
if( $this->{request} ) {
my $resurface = $this->{request}->param( 'skin' );
$skinpath = $resurface if $resurface;
}
my $epidermis = $this->{prefs}->getPreferencesValue( 'COVER' );
$skinpath = $epidermis.','.$skinpath if $epidermis;
if( $this->{request} ) {
$epidermis = $this->{request}->param( 'cover' );
$skinpath = $epidermis.','.$skinpath if $epidermis;
}
# Resolve TWiki variables if needed
if( $skinpath =~ /\%[A-Z]/ ) {
$skinpath = $this->handleCommonTags( $skinpath, $this->{webName},
$this->{topicName} );
}
# sanitize skin path
$skinpath =~ s/[^A-Za-z0-9_\-\,\. ]//g;
return $skinpath;
}
=pod
---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
Returns the URL to a TWiki script, providing the web and topic as
"path info" parameters. The result looks something like this:
"http://host/twiki/bin/$script/$web/$topic".
* =...= - an arbitrary number of name,value parameter pairs that will be
url-encoded and added to the url. The special parameter name '#' is
reserved for specifying an anchor. e.g.
getScriptUrl('x','y','view','#'=>'XXX',a=>1,b=>2) will give
.../view/x/y?a=1&b=2#XXX %BR%
If $absolute is set, generates an absolute URL. $absolute is advisory only;
TWiki can decide to generate absolute URLs (for example when run from the
command-line) even when relative URLs have been requested.
The default script url is taken from {ScriptUrlPath}, unless there is
an exception defined for the given script in {ScriptUrlPaths}. Both
{ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
they are absolute, then they will always generate absolute URLs. if they
are relative, then they will be converted to absolute when required (e.g.
when running from the command line, or when generating rss). If
$script is not given, absolute URLs will always be generated.
If either the web or the topic is defined, will generate a full url
(including web and topic). Otherwise will generate only up to the script
name. An undefined web will default to the main web name.
The returned URL takes ReadOnlyAndMirrorWebs into account.
If the specified =$web= is slave on this site, with the scripts
=edit=, =save=, =attach=, =upload=, and =rename=, this method returns
the URLs on the master site because it does not make sense to execute
those scripts on the master site of the web.
Even with the other scripts, you may need to get the URLs on the master site.
You can get those URLs by providing =$master => 1= as a name value pair.
=cut
sub getScriptUrl {
my( $this, $absolute, $script, $web, $topic, @params ) = @_;
if( $web || $topic ) {
if ( !$web && $topic !~ /[.\/]/ ) {
$web = $this->{webName};
}
else {
($web, $topic) = $this->normalizeWebTopicName( $web, $topic );
}
}
# the above is needed here because $web is crucial
# check if $master => X exists in @params and makes @params1 excluding it
my $ofMaster = 0;
my @params1;
my $i = 0;
while ( $i < @params ) {
if ( $params[$i] eq '$master' ) {
$ofMaster = 1 if ( $params[$i + 1] );
}
else {
push(@params1, @params[$i, $i+1]);
}
$i += 2;
}
# determine if it's of the master and get the information of the master
my ($contentMode, $master);
if ( $web ) {
($contentMode, $master) = $this->modeAndMaster($web);
if ( $master && $master->{webScriptUrlTmpl} ) {
if ( $contentMode eq 'slave' ) {
if ( $scriptOnMaster{$script} ) {
# even if $script is null, no disaster happens
$ofMaster = 1;
}
}
else {
# if not slave, the master URL is yielded regardless
$ofMaster = 0;
}
}
else {
$ofMaster = 0;
# if $master->{webScriptUrlTmpl} is not defined,
# no way to get the URL for the master site, hence resort to
# 'not of master'
}
}
else {
$ofMaster = 0;
}
# SMELL: topics and webs that contain spaces?
my $url;
if ( $ofMaster ) {
$script ||= 'view';
# A web is specified explicitly or implicitly.
# In that case, a URL having the web cannot be script neutral.
$url = $master->{webScriptUrlTmpl};
if ( $script eq 'view' && $master->{webViewUrl} ) {
$url = $master->{webViewUrl};
}
else {
my $suffix = $master->{scriptSuffix} || '';
$url =~ s:^(.*)//:$1/$script$suffix/:;
}
$url .= urlEncode( '/'.$topic );
$url .= _make_params(0, @params1);
}
else {
# if $ofMaster is true, the URL needs to be absolute regardless.
# So absolute checking is done here.
$absolute ||= ($this->inContext( 'command_line' ) ||
$this->inContext( 'rss' ) ||
$this->inContext( 'absolute_urls' ));
if( defined $TWiki::cfg{ScriptUrlPaths} && $script) {
$url = $TWiki::cfg{ScriptUrlPaths}{$script};
}
unless( defined( $url )) {
$url = $TWiki::cfg{ScriptUrlPath};
if( $script ) {
$url .= '/' unless $url =~ /\/$/;
$url .= $script;
if ( rindex($url, $TWiki::cfg{ScriptSuffix}) !=
( length($url) - length($TWiki::cfg{ScriptSuffix}) )
) {
$url .= $TWiki::cfg{ScriptSuffix} if $script;
}
}
}
if( $absolute && $url !~ /^[a-z]+:/ ) {
# See http://www.ietf.org/rfc/rfc2396.txt for the definition of
# "absolute URI". TWiki bastardises this definition by assuming
# that all relative URLs lack the component as well.
$url = $this->{urlHost}.$url;
}
if( $web || $topic ) {
$url .= urlEncode( '/'.$web.'/'.$topic );
$url .= _make_params(0, @params1);
}
}
return $url;
}
sub _make_params {
my ( $notfirst, @args ) = @_;
my $url = '';
my $ps = '';
my $anchor = '';
while( my $p = shift @args ) {
if( $p eq '#' ) {
$anchor .= '#' . shift( @args );
} else {
my $arg = shift( @args );
$arg = '' unless defined( $arg );
$ps .= ";$p=" . urlEncode( $arg );
}
}
if( $ps ) {
$ps =~ s/^;/?/ unless $notfirst;
$url .= $ps;
}
$url .= $anchor;
return $url;
}
=pod
---++ ObjectMethod getDiskInfo($web, $site, $diskID) -> ($dataDir, $pubDir, $diskID)
You can specify either $web or $diskID, not both.
=cut
sub getDiskInfo {
my( $this, $web, $site, $diskID ) = @_;
if ( !$web ) {
if ( $diskID ) {
$web = '';
}
else {
$web = $this->{webName};
}
}
$site ||= $TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} || '';
return $this->{store}->getDiskInfo($web, $site, $diskID);
}
=pod
---++ ObjectMethod getDiskList() -> ('', 1, 2, ...)
=cut
sub getDiskList {
# my( $this ) = @_;
return $_[0]->{store}->getDiskList();
}
=pod
---++ ObjectMethod getDataDir($web, $diskID) -> $dataDir
You can specify either $web or $diskID, not both.
=cut
sub getDataDir {
# my( $this, $web, $diskID ) = @_;
return
$TWiki::cfg{MultipleDisks} ? (getDiskInfo($_[0], $_[1], '', $_[2]))[0]
: $TWiki::cfg{DataDir};
}
=pod
---++ ObjectMethod getPubDir($web, $diskID) -> $pubDir
You can specify either $web or $diskID, not both.
=cut
sub getPubDir {
# my( $this, $web, $diskID ) = @_;
return
$TWiki::cfg{MultipleDisks} ? (getDiskInfo($_[0], $_[1], '', $_[2]))[1]
: $TWiki::cfg{PubDir};
}
=pod
---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
Composes a pub url. If $absolute is set, returns an absolute URL.
If $absolute is set, generates an absolute URL. $absolute is advisory only;
TWiki can decide to generate absolute URLs (for example when run from the
command-line) even when relative URLs have been requested.
$web, $topic and $attachment are optional. A partial URL path will be
generated if one or all is not given.
=cut
sub getPubUrl {
my( $this, $absolute, $web, $topic, $attachment ) = @_;
$absolute ||= ($this->inContext( 'command_line' ) ||
$this->inContext( 'rss' ) ||
$this->inContext( 'absolute_urls' ));
my $url = '';
$url .= $TWiki::cfg{PubUrlPath};
if( $absolute && $url !~ /^[a-z]+:/ ) {
# See http://www.ietf.org/rfc/rfc2396.txt for the definition of
# "absolute URI". TWiki bastardises this definition by assuming
# that all relative URLs lack the component as well.
$url = $this->{urlHost}.$url;
}
if( $web || $topic || $attachment ) {
( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
my $path = '/'.$web.'/'.$topic;
if( $attachment ) {
$path .= '/'.$attachment;
# Attachments are served directly by web server, need to handle
# URL encoding specially
$url .= urlEncodeAttachment ( $path );
} else {
$url .= urlEncode( $path );
}
}
return $url;
}
=pod
---++ ObjectMethod cacheIconData( $action )
Cache icon data based on action:
* 'delete' - delete cache file
* 'read' - read cache file
* 'expire' - expire (invalidate) cache if needed
* 'save' - save cache file
=cut
sub cacheIconData {
my( $this, $action, $web, $topic ) = @_;
my $cacheFile = $this->{store}->getWorkArea( 'VarICON' ) . '/icon_cache.txt';
if( $action eq 'save' ) {
if( open( FILE, ">$cacheFile" ) ) {
print FILE "# Cached icon data; do not edit. See TWiki.TWikiDocGraphics\n";
my %seen;
my %refs;
foreach my $icn (sort keys %{ $this->{_ICONDATA} } ) {
my $line = "$icn: ";
if( $seen{ $this->{_ICONDATA}{$icn}{name} } ) {
$refs{$icn} = $seen{ $this->{_ICONDATA}{$icn}{name} };
} else {
$seen{ $this->{_ICONDATA}{$icn}{name} } = $icn;
$line .= "$this->{_ICONDATA}{$icn}{name}, "
. "$this->{_ICONDATA}{$icn}{web}, "
. "$this->{_ICONDATA}{$icn}{topic}, "
. "$this->{_ICONDATA}{$icn}{type}, "
. "$this->{_ICONDATA}{$icn}{width}, "
. "$this->{_ICONDATA}{$icn}{height}, "
. "$this->{_ICONDATA}{$icn}{description}";
print FILE "$line\n";
}
}
# add hash aliases
foreach my $icn (sort keys %refs ) {
my $line = "$icn => $refs{$icn}";
print FILE "$line\n";
}
print FILE "# EOF\n";
close( FILE);
}
} elsif( $action eq 'read' ) {
if( -e $cacheFile && open( FILE, "<$cacheFile" ) ) {
local $_;
my $icn;
while( ) {
if( /^([^\:]+)\: ([^,]+), ([^,]+), ([^,]+), ([^,]+), ([^,]+), ([^,]+), ([^\n\r]+)/ ) {
# icon record as hash
$icn->{$1} = {
name => $2,
web => $3,
topic => $4,
type => $5,
width => $6,
height => $7,
description => $8
};
} elsif( /^([^ ]+) \=> *([^\n\r]+)/ ) {
# icon as alias
$icn->{$1} = $icn->{$2};
}
}
close( FILE );
$this->{_ICONDATA} = $icn if( $icn );
}
} elsif( $action eq 'expire' ) {
# invoked by TWiki::Store::saveTopic after afterSaveHandler callback
if( $topic =~ /^(TWikiPreferences|WebPreferences)$/ ) {
# Remove icon cache if preferences changed on site level or web level
unlink( $cacheFile );
} else {
# Remove icon cache if any topic in the ICONTOPIC list changed
my $topics = $this->{prefs}->getPreferencesValue( 'ICONTOPIC' );
if( $topics ) {
foreach my $iconTopic ( split( / *, */, $topics ) ) {
my( $iWeb, $iTopic ) = $this->normalizeWebTopicName( $this->{webName}, $iconTopic );
if( ( $web eq $iWeb ) && ( $topic eq $iTopic ) ) {
unlink( $cacheFile );
}
}
}
}
} elsif( $action eq 'delete' ) {
unlink( $cacheFile );
}
}
=pod
---++ ObjectMethod formatIcon( $iconName, $format, $default ) -> $icon
Format an icon based on name and format parameter. The format parameter handles
these variables (with example):
* $name: Name of icon ('home')
* $type: Type of icon ('gif')
* $filename: Icon filename ('home.gif')
* $web: Web where icon is located ('TWiki')
* $topic: Topic where icon is located ('TWikiDocGraphics')
* $description: Icon description ('Home')
* $width: Width of icon ('16')
* $height: Height of icon ('16')
* $img: Full img tag of icon ('
')
* $url: URL of icon ('http://example.com/pub/TWiki/TWikiDocGraphics/home.gif')
* $urlpath: URL path of icon ('/pub/TWiki/TWikiDocGraphics/home.gif')
The optional default parameter specifies the icon name in case the icon is not defined.
Leave empty if you assume icon files exist in the default location.
=cut
sub formatIcon {
my( $this, $iconName, $format, $default ) = @_;
if( $iconName eq 'action:refresh-cache' ) {
$this->cacheIconData( 'delete' );
my $text = $format ||
"ICON cache is refreshed. "
. "[[$this->{SESSION_TAGS}{BASEWEB}.$this->{SESSION_TAGS}{BASETOPIC}][OK]].";
return $text;
}
unless( $this->{_ICONDATA} ) {
# try to read cache
$this->cacheIconData( 'read' );
}
unless( $this->{_ICONDATA} ) {
# cache does not exist, so let's create it
# create one dummy entry in case icon info cannot be read
# to void repeated retries
$this->{_ICONDATA}->{_default} = {
name => '_default',
web => $TWiki::cfg{SystemWebName},
topic => 'TWikiDocGraphics',
description => 'Default',
type => 'gif',
width => '16',
height => '16',
};
# read icon info
my $i = 0;
foreach my $iconTopic (split(/ *, */, $this->{prefs}->getPreferencesValue( 'ICONTOPIC' ))) {
my( $web, $topic ) = $this->normalizeWebTopicName( $this->{webName}, $iconTopic );
my $text = $this->{store}->readTopicRaw( undef, $web, $topic );
if( $text ) {
foreach my $line (split(/[\n\r]+/, $text)) {
# sample line:
# | %ICON{help}% | =%ICON{help}%=, =%H%= | Help | gif | 16x16 | info |
if( $line =~ / %ICON\{[ "']*([^ "'}]+)[^\|]*\|[^\|]*\| *(.*?) *\| *(.*?) *\| *([0-9]+)x([0-9]+)([^\|]*\| *(.*?) *\|)?/ ) {
my $name = $1;
$this->{_ICONDATA}->{$name} = {
name => $name,
web => $web,
topic => $topic,
description => $2,
type => $3,
width => $4,
height => $5,
};
my $aliases = $7;
if( $aliases ) {
foreach my $alias (split(/[ ,]+/, $aliases)) {
$this->{_ICONDATA}->{$alias} = $this->{_ICONDATA}->{$name};
}
}
}
}
if( $i++ < 2 ) {
$this->{_ICONDATA}->{_default}{web} = $web;
$this->{_ICONDATA}->{_default}{topic} = $topic;
}
}
}
# cache icon info
$this->cacheIconData( 'save' );
}
# cut file path/name, if any, and lowercase the file type
$default =~ s/^.*\.(.*?)$/lc($1)/e;
if( $iconName =~ s/^.*\.(.*?)$/lc($1)/e ) {
# file icon path identified, set default unless defined
$default = 'else' unless( $default );
}
$iconName = 'empty' unless( $iconName );
if( $iconName =~ /^list:/ ) {
my @icons = ();
if( $iconName =~ /all/ ) {
@icons = sort grep { !/_default/ } keys %{ $this->{_ICONDATA} };
} else { # unique
@icons = sort
grep { !/_default/ }
grep { /$this->{_ICONDATA}->{$_}->{name}/ }
keys %{ $this->{_ICONDATA} };
}
if( $iconName =~ /names/ ) {
return join( ', ', @icons );
} elsif( $iconName =~ /icons/ ) {
return join( ' ', map { '%ICON{'.$_.'}%' } @icons );
} elsif( $iconName =~ /info/ ) {
return join( ' ', map { '%ICON{"'.$_.'" format="$info"}%' } @icons );
} else { # /table/
my $text = '| * * | *Name* | *Description* | *Type* | *Size* | *Defined in* |' . "\n";
my $i = 0;
for my $icn ( @icons ) {
$i++;
$text .= "| \%ICON{$icn}\% | $icn ";
$text .= "=> $this->{_ICONDATA}->{$icn}->{name} " if( $this->{_ICONDATA}->{$icn}->{name} ne $icn );
$text .= "| $this->{_ICONDATA}->{$icn}->{description} | $this->{_ICONDATA}->{$icn}->{type} "
. "| $this->{_ICONDATA}->{$icn}->{width}x$this->{_ICONDATA}->{$icn}->{height} "
. "| [[$this->{_ICONDATA}->{$icn}->{web}.$this->{_ICONDATA}->{$icn}->{topic}]] |\n";
}
$text .= "| Total: | $i icons |||||\n";
return $text;
}
}
# determine icon
my $icn = $this->{_ICONDATA}->{$iconName} || $this->{_ICONDATA}->{$default};
unless( $icn ) {
# assume default location (attached to second topic in ICONTOPIC list)
$icn = $this->{_ICONDATA}->{_default};
$icn->{name} = $iconName;
$icn->{description} = $iconName;
$icn->{description} =~ s/^(.)/uc($1)/eo;
}
# format icon tag/url
my $iconTag = '
';
my $iconInfo = '';
$format = '$img' unless( $format );
$format =~ s/\$img\b/$iconTag/go;
$format =~ s/\$info\b/$iconInfo/go;
$format =~ s/\$url\b/$this->getPubUrl( 1, $icn->{web}, $icn->{topic}, "$icn->{name}.$icn->{type}" )/geo;
$format =~ s/\$urlpath\b/$this->getPubUrl( 0, $icn->{web}, $icn->{topic}, "$icn->{name}.$icn->{type}" )/geo;
$format =~ s/\$name\b/$icn->{name}/go;
$format =~ s/\$type\b/$icn->{type}/go;
$format =~ s/\$filename\b/$icn->{name}.$icn->{type}/go;
$format =~ s/\$web\b/$icn->{web}/go;
$format =~ s/\$topic\b/$icn->{topic}/go;
$format =~ s/\$description\b/$icn->{description}/go;
$format =~ s/\$width\b/$icn->{width}/go;
$format =~ s/\$height\b/$icn->{height}/go;
return $format;
}
=pod
---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
Normalize a Web.TopicName
See TWikiFuncDotPm for a full specification of the expansion (not duplicated
here)
*WARNING* if there is no web specification (in the web or topic parameters)
the web defaults to $TWiki::cfg{UsersWebName}. If there is no topic
specification, or the topic is '0', the topic defaults to the web home topic
name.
=cut
sub normalizeWebTopicName {
my( $this, $web, $topic ) = @_;
ASSERT(defined $topic) if DEBUG;
if( $topic =~ m|^(.*)[./](.*?)$| ) {
$web = $1;
$topic = $2;
}
$web ||= $cfg{UsersWebName};
$topic ||= $cfg{HomeTopicName};
while( $web =~ s/%((MAIN|TWIKI|USERS|SYSTEM|DOC)WEB)%/_expandTagOnTopicRendering( $this,$1)||''/e ) {
}
$web =~ s#\.#/#go;
return( $web, $topic );
}
sub _readUserPreferences {
my ($this) = @_;
# User preferences only available if we can get to a valid wikiname,
# which depends on the user mapper.
my $wn = $this->{users}->getWikiName( $this->{user} );
if( $wn ) {
my $prefs = $this->{prefs};
my $userWeb = $TWiki::cfg{UsersWebName}.'/'.$wn;
if ( $TWiki::cfg{UserSubwebs}{Enabled} &&
$this->{store}->topicExists($userWeb,
$TWiki::cfg{UserSubwebs}{UserPrefsTopicName})
) {
$prefs->pushPreferences( $userWeb,
$TWiki::cfg{UserSubwebs}{UserPrefsTopicName},
'USER ' . $wn );
}
else {
$prefs->pushPreferences( $TWiki::cfg{UsersWebName}, $wn,
'USER ' . $wn );
}
}
}
sub _readExtraPreferences {
my ($this) = @_;
my $prefs = $this->{prefs};
my $topics = $prefs->getPreferencesValue( 'EXTRAPREFERENCES' );
# It's somewhat better to use getWebPreferencesValue() than
# getPreferencesValue().
# But getWebPreferencesValue() causes re-processing of WebPreferences
# of the current and parent webs.
# The cost is too much for the marginal benefit of not picking
# prefernces from an unitended place.
if ( $topics ) {
for my $topic ( split(/[,\s]+/, $topics) ) {
my ($epWeb, $epTopic) =
normalizeWebTopicName($this, $this->{webName}, $topic);
$prefs->pushPreferences($epWeb, $epTopic, 'EXTRA');
}
}
}
=pod
---++ ObjectMethod determineWebTopic($pathInfo, $web, $topic) -> ($web, $topic, $requestedWeb)
Determine the web and topic names from PATH_INFO and web and topic names
explicitly provided.
And then sanitize them.
=cut
sub determineWebTopic {
my ($this, $pathInfo, $web, $topic) = @_;
if( $pathInfo =~ /\/((?:.*[\.\/])+)(.*)/ ) {
# is 'bin/script/Webname/SomeTopic' or 'bin/script/Webname/'
$web = $1 unless $web;
$topic = $2 unless $topic;
$web =~ s/\./\//go;
$web =~ s/\/$//o;
} elsif( $pathInfo =~ /\/(.*)/ ) {
# is 'bin/script/Webname' or 'bin/script/'
$web = $1 unless $web;
}
# All roads lead to WebHome
$topic = $TWiki::cfg{HomeTopicName} if ( $topic =~ /\.\./ );
$topic =~ s/$TWiki::cfg{NameFilter}//go;
$topic = $TWiki::cfg{HomeTopicName} unless $topic;
$topic = TWiki::Sandbox::untaintUnchecked( $topic );
$web =~ s/$TWiki::cfg{NameFilter}//go;
my $requestedWeb = TWiki::Sandbox::untaintUnchecked( $web ); #can be an empty string
$web = $TWiki::cfg{UsersWebName} unless $web;
$web = TWiki::Sandbox::untaintUnchecked( $web );
# Convert UTF-8 web and topic name from URL into site charset if necessary
# SMELL: merge these two cases, browsers just don't mix two encodings in one URL
# - can also simplify into 2 lines by making function return unprocessed text if no conversion
my $webNameTemp = $this->UTF82SiteCharSet( $web );
if ( $webNameTemp ) {
$web = $webNameTemp;
}
my $topicNameTemp = $this->UTF82SiteCharSet( $topic );
if ( $topicNameTemp ) {
$topic = $topicNameTemp;
}
return ($web, $topic, $requestedWeb);
}
=pod
---++ ClassMethod new( $loginName, $query, \%initialContext )
Constructs a new TWiki object. Parameters are taken from the query object.
* =$loginName= is the login username (*not* the wikiname) of the user you
want to be logged-in if none is available from a session or browser.
Used mainly for side scripts and debugging.
* =$query= the TWiki::Request query (may be undef, in which case an empty query
is used)
* =\%initialContext= - reference to a hash containing context
name=value pairs to be pre-installed in the context hash
=cut
sub new {
my( $class, $login, $query, $initialContext ) = @_;
ASSERT(!$query || UNIVERSAL::isa($query, 'TWiki::Request'));
# Compatibility; not used except maybe in plugins
$TWiki::cfg{TempfileDir} = "$TWiki::cfg{WorkingDir}/tmp"
unless defined($TWiki::cfg{TempfileDir});
# Set command_line context if there is no query
$initialContext ||= defined( $query ) ? {} : { command_line => 1 };
$query ||= new TWiki::Request();
my $this = bless( {}, $class );
$this->{request} = $query;
$this->{response} = new TWiki::Response();
# Tell TWiki::Response which charset we are using if not default
if( defined $TWiki::cfg{Site}{CharSet} && $TWiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io ) {
$this->{response}->charset( $TWiki::cfg{Site}{CharSet} );
}
$this->{_HTMLHEADERS} = {};
$this->{context} = $initialContext;
# create the various sub-objects
unless ($sandbox) {
# "shared" between mod_perl instances
$sandbox = new TWiki::Sandbox( $TWiki::cfg{OS}, $TWiki::cfg{DetailedOS} );
}
require TWiki::Plugins;
$this->{plugins} = new TWiki::Plugins( $this );
require TWiki::Store;
$this->{store} = new TWiki::Store( $this );
if( $TWiki::cfg{Mdrepo}{Store} && $TWiki::cfg{Mdrepo}{Dir} &&
$TWiki::cfg{Mdrepo}{Tables}
) {
require TWiki::Mdrepo;
$this->{mdrepo} = new TWiki::Mdrepo( $this );
}
$this->{remoteUser} = $login; #use login as a default (set when running from cmd line)
require TWiki::Users;
$this->{users} = new TWiki::Users( $this );
$this->{remoteUser} = $this->{users}->{remoteUser};
# Make %ENV safer, preventing hijack of the search path
# SMELL: can this be done in a BEGIN block? Or is the environment
# set per-query?
# Item4382: Default $ENV{PATH} must be untainted because TWiki runs
# with use strict and calling external programs that writes on the disk
# will fail unless Perl seens it as set to safe value.
if( $TWiki::cfg{SafeEnvPath} ) {
$ENV{PATH} = $TWiki::cfg{SafeEnvPath};
} else {
$ENV{PATH} = TWiki::Sandbox::untaintUnchecked( $ENV{PATH} );
}
delete $ENV{IFS};
delete $ENV{CDPATH};
delete $ENV{ENV};
delete $ENV{BASH_ENV};
my $url = $query->url();
if( $url && $url =~ m{^([^:]*://[^/]*).*$} ) {
$this->{urlHost} = $1;
# If the urlHost in the url is localhost, this is a lot less
# useful than the default url host. This is because new CGI("")
# assigns this host by default - it's a default setting, used
# when there is nothing better available.
if( $this->{urlHost} eq 'http://localhost' ) {
$this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
} elsif( $TWiki::cfg{RemovePortNumber} ) {
$this->{urlHost} =~ s/\:[0-9]+$//;
}
} else {
$this->{urlHost} = $TWiki::cfg{DefaultUrlHost};
}
if ( $TWiki::cfg{GetScriptUrlFromCgi}
&& $url
&& $url =~ m{^[^:]*://[^/]*(.*)/.*$}
&& $1 )
{
# SMELL: this is a really dangerous hack. It will fail
# spectacularly with mod_perl.
# SMELL: why not just use $query->script_name?
$this->{scriptUrlPath} = $1;
}
my $web = '';
my $topic = $query->param( 'topic' );
if( $topic ) {
if( $topic =~ m#^$regex{linkProtocolPattern}://#o &&
$this->{request} ) {
# redirect to URI
$this->{webName} = '';
$this->redirect( $topic );
return $this;
} elsif( $topic =~ /((?:.*[\.\/])+)(.*)/ ) {
# is 'bin/script?topic=Webname.SomeTopic'
$web = $1;
$topic = $2;
$web =~ s/\./\//go;
$web =~ s/\/$//o;
# jump to WebHome if 'bin/script?topic=Webname.'
$topic = $TWiki::cfg{HomeTopicName} if( $web && ! $topic );
}
# otherwise assume 'bin/script/Webname?topic=SomeTopic'
} else {
$topic = '';
}
my $pathInfo = $query->path_info();
# Save the path info with tilde for a later process.
# A login name may contain dots hence the entire pathInfo needs to be saved
# before being processed.
if ( $pathInfo =~ m:^/~: ) {
$this->{pathInfoWithTilde} = $pathInfo;
}
@$this{'webName', 'topicName', 'requestedWebName'} =
$this->determineWebTopic($pathInfo, $web, $topic);
# Item3270 - here's the appropriate place to enforce TWiki spec:
# All topic name sources are evaluated, site charset applied
# SMELL: This untaint unchecked is duplicate of one just above
$this->{topicName} = TWiki::Sandbox::untaintUnchecked(ucfirst $this->{topicName});
$this->{scriptUrlPath} = $TWiki::cfg{ScriptUrlPath};
require TWiki::Prefs;
my $prefs = new TWiki::Prefs( $this );
$this->{prefs} = $prefs;
# Form definition cache
$this->{forms} = {};
# Push global preferences from TWiki.TWikiPreferences
$prefs->pushGlobalPreferences();
# SMELL: what happens if we move this into the TWiki::User::new?
$this->{user} = $this->{users}->initialiseUser($this->{remoteUser});
# Static session variables that can be expanded in topics when they
# are enclosed in % signs
# SMELL: should collapse these into one. The duplication is pretty
# pointless. Could get rid of the SESSION_TAGS hash, might be
# the easiest thing to do, but then that would allow other
# upper-case named fields in the object to be accessed as well...
$this->{SESSION_TAGS}{BASEWEB} = $this->{webName};
$this->{SESSION_TAGS}{BASETOPIC} = $this->{topicName};
$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
$this->{SESSION_TAGS}{INCLUDINGWEB} = $this->{webName};
$this->{SESSION_TAGS}{SITENAME} =
$TWiki::cfg{ReadOnlyAndMirrorWebs}{SiteName} || '';
# Push plugin settings
$this->{plugins}->settings();
# Now the rest of the preferences
$prefs->pushGlobalPreferencesSiteSpecific();
$this->_readUserPreferences() unless ( $TWiki::cfg{DemoteUserPreferences} );
$prefs->pushWebPreferences( $this->{webName} );
$this->_readExtraPreferences();
$prefs->pushPreferences( $this->{webName}, $this->{topicName}, 'TOPIC' );
$prefs->pushPreferenceValues( 'SESSION',
$this->{users}->{loginManager}->getSessionValues() );
$this->_readUserPreferences() if ( $TWiki::cfg{DemoteUserPreferences} );
# Finish plugin initialization - register handlers
$this->{plugins}->enable();
# SMELL: Every place should localize it before use, so it's not necessary here.
$TWiki::Plugins::SESSION = $this;
my ($mode, $master) = $this->modeAndMaster($this->{webName});
$this->{contentMode} = $mode;
if ( $master ) {
$this->{master} = $master;
}
return $this;
}
=begin twiki
---++ ObjectMethod renderer()
Get a reference to the renderer object. Done lazily because not everyone
needs the renderer.
=cut
sub renderer {
my( $this ) = @_;
unless( $this->{renderer} ) {
require TWiki::Render;
# requires preferences (such as LINKTOOLTIPINFO)
$this->{renderer} = new TWiki::Render( $this );
}
return $this->{renderer};
}
=begin twiki
---++ ObjectMethod attach()
Get a reference to the attach object. Done lazily because not everyone
needs the attach.
=cut
sub attach {
my( $this ) = @_;
unless( $this->{attach} ) {
require TWiki::Attach;
$this->{attach} = new TWiki::Attach( $this );
}
return $this->{attach};
}
=begin twiki
---++ ObjectMethod templates()
Get a reference to the templates object. Done lazily because not everyone
needs the templates.
=cut
sub templates {
my( $this ) = @_;
unless( $this->{templates} ) {
require TWiki::Templates;
$this->{templates} = new TWiki::Templates( $this );
}
return $this->{templates};
}
=begin twiki
---++ ObjectMethod i18n()
Get a reference to the i18n object. Done lazily because not everyone
needs the i18ner.
=cut
sub i18n {
my( $this ) = @_;
unless( $this->{i18n} ) {
require TWiki::I18N;
# language information; must be loaded after
# *all possible preferences sources* are available
$this->{i18n} = new TWiki::I18N( $this );
}
return $this->{i18n};
}
=begin twiki
---++ ObjectMethod search()
Get a reference to the search object. Done lazily because not everyone
needs the searcher.
=cut
sub search {
my( $this ) = @_;
unless( $this->{search} ) {
require TWiki::Search;
$this->{search} = new TWiki::Search( $this );
}
return $this->{search};
}
=begin twiki
---++ ObjectMethod security()
Get a reference to the security object. Done lazily because not everyone
needs the security.
=cut
sub security {
my( $this ) = @_;
unless( $this->{security} ) {
require TWiki::Access;
$this->{security} = new TWiki::Access( $this );
}
return $this->{security};
}
=begin twiki
---++ ObjectMethod net()
Get a reference to the net object. Done lazily because not everyone
needs the net.
=cut
sub net {
my( $this ) = @_;
unless( $this->{net} ) {
require TWiki::Net;
$this->{net} = new TWiki::Net( $this );
}
return $this->{net};
}
=begin twiki
---++ ObjectMethod finish()
Break circular references.
=cut
# Note to developers; please undef *all* fields in the object explicitly,
# whether they are references or not. That way this method is "golden
# documentation" of the live fields in the object.
sub finish {
my $this = shift;
$_->finish() foreach values %{$this->{forms}};
$this->{plugins}->finish() if $this->{plugins};
$this->{users}->finish() if $this->{users};
$this->{prefs}->finish() if $this->{prefs};
$this->{templates}->finish() if $this->{templates};
$this->{renderer}->finish() if $this->{renderer};
$this->{net}->finish() if $this->{net};
$this->{store}->finish() if $this->{store};
$this->{mdrepo}->finish() if $this->{mdrepo};
$this->{search}->finish() if $this->{search};
$this->{attach}->finish() if $this->{attach};
$this->{security}->finish() if $this->{security};
$this->{i18n}->finish() if $this->{i18n};
undef $this->{_HTMLHEADERS};
undef $this->{request};
undef $this->{urlHost};
undef $this->{web};
undef $this->{topic};
undef $this->{webName};
undef $this->{topicName};
undef $this->{_ICONMAP};
undef $this->{context};
undef $this->{remoteUser};
undef $this->{requestedWebName}; # Web name before renaming
undef $this->{scriptUrlPath};
undef $this->{user};
undef $this->{SESSION_TAGS};
undef $this->{_INCLUDES};
undef $this->{ignoreTOC};
undef $this->{response};
undef $this->{evaluating_if};
undef $this->{contentMode};
undef $this->{master};
undef $this->{modeAndMaster};
}
=pod
---++ ObjectMethod writeLog( $action, $webTopic, $extra, $user )
* =$action= - what happened, e.g. view, save, rename
* =$wbTopic= - what it happened to
* =$extra= - extra info, such as minor flag
* =$user= - user who did the saving (user id)
Write the log for an event to the logfile
=cut
sub writeLog {
my $this = shift;
my $action = shift || '';
my $webTopic = shift || '';
my $extra = shift || '';
my $user = shift || $this->{user};
my $login = $user;
if( $this->{users} ) {
$login = $this->{users}->getLoginName( $user ) # fast
|| $this->{users}->getLoginName(
$this->{users}->getCanonicalUserID( $user ) ) # slower
|| 'unknown';
}
my $cgiQuery = $this->{request};
if( $cgiQuery && $action eq 'view' ) {
my $agent = $cgiQuery->user_agent();
if( $agent && $agent =~ m/([\w]+)/ ) {
$extra = "$1 $extra";
$extra =~ s/ +$//;
}
}
my $remoteAddr = $this->{request}->remoteAddress() || '';
my $text = "$login | $action | $webTopic | $extra | $remoteAddr |";
_writeReport( $this, $TWiki::cfg{LogFileName}, $text );
}
=pod
---++ ObjectMethod writeWarning( $text )
Prints date, time, and contents $text to $TWiki::cfg{WarningFileName}, typically
'warnings.txt'. Use for warnings and errors that may require admin
intervention. Use this for defensive programming warnings (e.g. assertions).
=cut
sub writeWarning {
my $this = shift;
my $text = shift;
$text =~ s/[\r\n]+$//s;
_writeReport( $this, $TWiki::cfg{WarningFileName}, "$text |" );
}
=pod
---++ ObjectMethod writeDebug( $text )
Prints date, time, and contents of $text to $TWiki::cfg{DebugFileName}, typically
'debug.txt'. Use for debugging messages.
=cut
sub writeDebug {
my $this = shift;
my $text = shift;
_writeReport( $this, $TWiki::cfg{DebugFileName}, "$text |" );
}
# resolve %DATE% (and maybe other things in the future) in a "file name" config
# parameter
sub _fileNameToPath {
my $path = shift;
if ( $path =~ /%DATE%/ ) {
$path =~ s//TWiki::Time::formatTime( time(), '$year$mo', 'gmtime')/ge;
}
return $path;
}
# Concatenates date, time, and $text to a log file.
# The logfilename can optionally use a %DATE% variable to support
# logs that are rotated once a month.
# | =$log= | Base filename for log file |
# | =$message= | Message to print |
sub _writeReport {
my ( $this, $log, $message ) = @_;
if ( $log ) {
$log = _fileNameToPath( $log );
my $time = TWiki::Time::formatTime( time(), '$year-$mo-$day - $hour:$min:$sec' );
# ommitting the third argument ($outputTimeZone) to resort to $TWiki::cfg{DisplayTimeValues} as per Item7811
if( open( FILE, ">>$log" ) ) {
print FILE "| $time | $message\n";
close( FILE );
} else {
print STDERR 'Could not write "'.$message.'" to '."$log: $!\n";
}
}
}
sub _removeNewlines {
my( $theTag ) = @_;
$theTag =~ s/[\r\n]+/ /gs;
return $theTag;
}
# Convert relative URLs to absolute URIs
sub _rewriteURLInInclude {
my( $theHost, $theAbsPath, $url ) = @_;
# leave out an eventual final non-directory component from the absolute path
$theAbsPath =~ s/(.*?)[^\/]*$/$1/;
if( $url =~ /^\// ) {
# fix absolute URL
$url = $theHost.$url;
} elsif( $url =~ /^\./ ) {
# fix relative URL
$url = $theHost.$theAbsPath.'/'.$url;
} elsif( $url =~ /^$regex{linkProtocolPattern}:/o ) {
# full qualified URL, do nothing
} elsif( $url =~ /^#/ ) {
# anchor. This needs to be left relative to the including topic
# so do nothing
} elsif( $url ) {
# FIXME: is this test enough to detect relative URLs?
$url = $theHost.$theAbsPath.'/'.$url;
}
return $url;
}
# Add a web reference to a [[...][...]] link in an included topic
sub _fixIncludeLink {
my( $web, $link, $label ) = @_;
# Detect absolute and relative URLs, web-qualified wikinames and Interwiki links
if( $link =~ m/^$regex{excludeFixIncludeLinkRegex}/o ) {
if( $label ) {
return "[[$link][$label]]";
} else {
return "[[$link]]";
}
} elsif( !$label ) {
# Must be wikiword or spaced-out wikiword (or illegal link :-/)
$label = $link;
}
return "[[$web.$link][$label]]";
}
# Replace web references in a topic. Called from forEachLine, applying to
# each non-verbatim and non-literal line.
sub _fixupIncludedTopic {
my( $text, $options ) = @_;
my $fromWeb = $options->{web};
unless( $options->{in_noautolink} || $options->{force_noautolink} ) {
# Prefix web name to WikiWord to make links work, such as:
# 'TopicName' to 'Web.TopicName'
# TWikibug:Item6840: Exclude 'WikiWordWeb.TopicName' using translation token
$text =~ s/(?:^|(?<=[\s(]))($regex{webNameRegex}\.($regex{wikiWordRegex}|$regex{abbrevRegex}))/-$TranslationToken$1/go;
$text =~ s#(?:^|(?<=[\s(]))($regex{wikiWordRegex})#$fromWeb.$1#go;
$text =~ s/-$TranslationToken//go;
}
# Handle explicit [[]] everywhere
# '[[TopicName][...]]' to '[[Web.TopicName][...]]'
$text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/
_fixIncludeLink( $fromWeb, $1, $2 )/geo;
return $text;
}
# Clean-up HTML text so that it can be shown embedded in a topic
sub _cleanupIncludedHTML {
my( $text, $host, $path, $options ) = @_;
# FIXME: Make aware of tag
$text =~ s/^.*?<\/head>//is
unless ( $options->{disableremoveheaders} ); # remove all HEAD
$text =~ s///gis
unless ( $options->{disableremovescript} ); # remove all SCRIPTs
$text =~ s/^.*?]*>//is
unless ( $options->{disableremovebody} ); # remove all to
$text =~ s/(?:\n)<\/body>.*//is
unless ( $options->{disableremovebody} ); # remove
$text =~ s/(?:\n)<\/html>.*//is
unless ( $options->{disableremoveheaders} ); # remove