Context Navigation

Foswiki.pm @ 8969

Revision 8969, 141.4 KB checked in by KennethLavrsen, 21 months ago (diff)
Item000: BUILD Foswiki-1.0.10 at Wed Sep 8 08:52:29 2010 GMT
Property LASTBUILD set to `BUILD Foswiki-1.0.10 at Wed Sep 8 08:52:29 2010 GMT` Property svn:keywords set to `Revision Date`

Line
1	# See bottom of file for license and copyright information
2	package Foswiki;
3
4	=begin TML
5
6	---+ package Foswiki
7
8	Foswiki operates by creating a singleton object (known as the Session
9	object) that acts as a point of reference for all the different
10	modules in the system. This package is the class for this singleton,
11	and also contains the vast bulk of the basic constants and the per-
12	site configuration mechanisms.
13
14	Global variables are avoided wherever possible to avoid problems
15	with CGI accelerators such as mod_perl.
16
17	---++ Public Data members
18	* =request= Pointer to the Foswiki::Request
19	* =response= Pointer to the Foswiki::Respose
20	* =context= Hash of context ids
21	* moved: =loginManager= Foswiki::LoginManager singleton (moved to Foswiki::Users)
22	* =plugins= Foswiki::Plugins singleton
23	* =prefs= Foswiki::Prefs singleton
24	* =remoteUser= Login ID when using ApacheLogin. Maintained for
25	compatibility only, do not use.
26	* =requestedWebName= Name of web found in URL path or =web= URL parameter
27	* =scriptUrlPath= URL path to the current script. May be dynamically
28	extracted from the URL path if {GetScriptUrlFromCgi}.
29	Only required to support {GetScriptUrlFromCgi} and
30	not consistently used. Avoid.
31	* =security= Foswiki::Access singleton
32	* =SESSION_TAGS= Hash of preference settings whose value is specific to
33	the current request.
34	* =store= Foswiki::Store singleton
35	* =topicName= Name of topic found in URL path or =topic= URL
36	parameter
37	* =urlHost= Host part of the URL (including the protocol)
38	determined during intialisation and defaulting to
39	{DefaultUrlHost}
40	* =user= Unique user ID of logged-in user
41	* =users= Foswiki::Users singleton
42	* =webName= Name of web found in URL path, or =web= URL parameter,
43	or {UsersWebName}
44
45	=cut
46
47	use strict;
48	use Assert;
49	use Error qw( :try );
50
51	use Fcntl; # File control constants e.g. O_EXCL
52	use CGI (); # Always required to get html generation tags;
53	use Digest::MD5 (); # For passthru and validation
54
55	use Foswiki::Response ();
56	use Foswiki::Request ();
57	use Foswiki::Logger ();
58	use Foswiki::Validation ();
59
60	require 5.005; # For regex objects and internationalisation
61
62	# Site configuration constants
63	use vars qw( %cfg );
64
65	# Uncomment this and the __END__ to enable AutoLoader
66	#use AutoLoader 'AUTOLOAD';
67	# You then need to autosplit Foswiki.pm:
68	# cd lib
69	# perl -e 'use AutoSplit; autosplit("Foswiki.pm", "auto")'
70
71	# Other computed constants
72	our $foswikiLibDir;
73	our %regex;
74	our %functionTags;
75	our %contextFreeSyntax;
76	our $VERSION;
77	our $RELEASE;
78	our $TRUE = 1;
79	our $FALSE = 0;
80	our $engine;
81	our $ifParser;
82
83	# Token character that must not occur in any normal text - converted
84	# to a flag character if it ever does occur (very unlikely)
85	# Foswiki uses $TranslationToken to mark points in the text. This is
86	# normally \0, which is not a useful character in any 8-bit character
87	# set we can find, nor in UTF-8. But if you do encounter problems
88	# with it, the workaround is to change $TranslationToken to something
89	# longer that is unlikely to occur in your text - for example
90	# muRfleFli5ble8leep (do not use punctuation characters or whitspace
91	# in the string!)
92	# See Codev.NationalCharTokenClash for more.
93	our $TranslationToken = "\0";
94
95	# Returns the full path of the directory containing Foswiki.pm
96	sub _getLibDir {
97	return $foswikiLibDir if $foswikiLibDir;
98
99	$foswikiLibDir = $INC{'Foswiki.pm'};
100
101	# fix path relative to location of called script
102	if ( $foswikiLibDir =~ /^\./ ) {
103	print STDERR
104	"WARNING: Foswiki lib path $foswikiLibDir is relative; you should make it absolute, otherwise some scripts may not run from the command line.";
105	my $bin;
106
107	# SMELL : Should not assume environment variables; get data from request
108	if ( $ENV{SCRIPT_FILENAME}
109	&& $ENV{SCRIPT_FILENAME} =~ m#^(.+)/.+?$# )
110	{
111
112	# CGI script name
113	# implicit untaint OK, because of use of $SCRIPT_FILENAME
114	$bin = $1;
115	}
116	elsif ( $0 =~ m#^(.)/.?$# ) {
117
118	# program name
119	# implicit untaint OK, because of use of $PROGRAM_NAME ($0)
120	$bin = $1;
121	}
122	else {
123
124	# last ditch; relative to current directory.
125	require Cwd;
126	$bin = Cwd::cwd();
127	}
128	$foswikiLibDir = "$bin/$foswikiLibDir/";
129
130	# normalize "/../" and "/./"
131	while ( $foswikiLibDir =~ s\|([\\/])[^\\/]+[\\/]\.\.[\\/]\|$1\| ) {
132	}
133	$foswikiLibDir =~ s\|([\\/])\.[\\/]\|$1\|g;
134	}
135	$foswikiLibDir =~ s\|([\\/])[\\/]*\|$1\|g; # reduce "//" to "/"
136	$foswikiLibDir =~ s\|[\\/]$\|\|; # cut trailing "/"
137
138	return $foswikiLibDir;
139	}
140
141	BEGIN {
142	require Monitor;
143	require Foswiki::Sandbox; # system command sandbox
144	require Foswiki::Configure::Load; # read configuration files
145
146	if (DEBUG) {
147
148	# If ASSERTs are on, then warnings are errors. Paranoid,
149	# but the only way to be sure we eliminate them all.
150	# Look out also for $cfg{WarningsAreErrors}, below, which
151	# is another way to install this handler without enabling
152	# ASSERTs
153	# ASSERTS are turned on by defining the environment variable
154	# FOSWIKI_ASSERTS. If ASSERTs are off, this is assumed to be a
155	# production environment, and no stack traces or paths are
156	# output to the browser.
157	$SIG{'__WARN__'} = sub { die @_ };
158	$Error::Debug = 1; # verbose stack traces, please
159	}
160	else {
161	$Error::Debug = 0; # no verbose stack traces
162	}
163
164	# DO NOT CHANGE THE FORMAT OF $VERSION
165	# Automatically expanded on checkin of this module
166	$VERSION = '$Date$ $Rev$ ';
167	$RELEASE = 'Foswiki-1.0.10';
168	$VERSION =~ s/^.?$(.)$.: (\d+) .?$/$RELEASE, $1, build $2/;
169
170	# Default handlers for different %TAGS%
171	%functionTags = (
172	ADDTOHEAD => \&ADDTOHEAD,
173	ALLVARIABLES => \&ALLVARIABLES,
174	ATTACHURL => \&ATTACHURL,
175	ATTACHURLPATH => \&ATTACHURLPATH,
176	COREPOD => \&COREPOD,
177	DATE => \&DATE,
178	DISPLAYTIME => \&DISPLAYTIME,
179	ENCODE => \&ENCODE,
180	ENV => \&ENV,
181	FORMFIELD => \&FORMFIELD,
182	GMTIME => \&GMTIME,
183	GROUPS => \&GROUPS,
184	HTTP_HOST => \&HTTP_HOST_deprecated,
185	HTTP => \&HTTP,
186	HTTPS => \&HTTPS,
187	ICON => \&ICON,
188	ICONURL => \&ICONURL,
189	ICONURLPATH => \&ICONURLPATH,
190	IF => \&IF,
191	INCLUDE => \&INCLUDE,
192	INTURLENCODE => \&INTURLENCODE_deprecated,
193	LANGUAGES => \&LANGUAGES,
194	MAKETEXT => \&MAKETEXT,
195	META => \&META,
196	METASEARCH => \&METASEARCH,
197	NOP => \&NOP,
198	PLUGINVERSION => \&PLUGINVERSION,
199	PUBURL => \&PUBURL,
200	PUBURLPATH => \&PUBURLPATH,
201	QUERYPARAMS => \&QUERYPARAMS,
202	QUERYSTRING => \&QUERYSTRING,
203	RELATIVETOPICPATH => \&RELATIVETOPICPATH,
204	REMOTE_ADDR => \&REMOTE_ADDR_deprecated,
205	REMOTE_PORT => \&REMOTE_PORT_deprecated,
206	REMOTE_USER => \&REMOTE_USER_deprecated,
207	RENDERHEAD => \&RENDERHEAD,
208	REVINFO => \&REVINFO,
209	REVTITLE => \&REVTITLE,
210	REVARG => \&REVARG,
211	SCRIPTNAME => \&SCRIPTNAME,
212	SCRIPTURL => \&SCRIPTURL,
213	SCRIPTURLPATH => \&SCRIPTURLPATH,
214	SEARCH => \&SEARCH,
215	SEP => \&SEP,
216	SERVERTIME => \&SERVERTIME,
217	SPACEDTOPIC => \&SPACEDTOPIC_deprecated,
218	SPACEOUT => \&SPACEOUT,
219	'TMPL:P' => \&TMPLP,
220	TOPICLIST => \&TOPICLIST,
221	URLENCODE => \&ENCODE,
222	URLPARAM => \&URLPARAM,
223	LANGUAGE => \&LANGUAGE,
224	USERINFO => \&USERINFO,
225	USERNAME => \&USERNAME_deprecated,
226	VAR => \&VAR,
227	WEBLIST => \&WEBLIST,
228	WIKINAME => \&WIKINAME_deprecated,
229	WIKIUSERNAME => \&WIKIUSERNAME_deprecated,
230
231	# Constant tag strings _not_ dependent on config. These get nicely
232	# optimised by the compiler.
233	ENDSECTION => sub { '' },
234	WIKIVERSION => sub { $VERSION },
235	STARTSECTION => sub { '' },
236	STARTINCLUDE => sub { '' },
237	STOPINCLUDE => sub { '' },
238	);
239	$contextFreeSyntax{IF} = 1;
240
241	unless ( ( $Foswiki::cfg{DetailedOS} = $^O ) ) {
242	require Config;
243	$Foswiki::cfg{DetailedOS} = $Config::Config{'osname'};
244	}
245	$Foswiki::cfg{OS} = 'UNIX';
246	if ( $Foswiki::cfg{DetailedOS} =~ /darwin/i ) { # MacOS X
247	$Foswiki::cfg{OS} = 'UNIX';
248	}
249	elsif ( $Foswiki::cfg{DetailedOS} =~ /Win/i ) {
250	$Foswiki::cfg{OS} = 'WINDOWS';
251	}
252	elsif ( $Foswiki::cfg{DetailedOS} =~ /vms/i ) {
253	$Foswiki::cfg{OS} = 'VMS';
254	}
255	elsif ( $Foswiki::cfg{DetailedOS} =~ /bsdos/i ) {
256	$Foswiki::cfg{OS} = 'UNIX';
257	}
258	elsif ( $Foswiki::cfg{DetailedOS} =~ /dos/i ) {
259	$Foswiki::cfg{OS} = 'DOS';
260	}
261	elsif ( $Foswiki::cfg{DetailedOS} =~ /^MacOS$/i ) { # MacOS 9 or earlier
262	$Foswiki::cfg{OS} = 'MACINTOSH';
263	}
264	elsif ( $Foswiki::cfg{DetailedOS} =~ /os2/i ) {
265	$Foswiki::cfg{OS} = 'OS2';
266	}
267
268	# readConfig is defined in Foswiki::Configure::Load to allow overriding it
269	if ( Foswiki::Configure::Load::readConfig() ) {
270	$Foswiki::cfg{isVALID} = 1;
271	}
272
273
274	if ( $Foswiki::cfg{WarningsAreErrors} ) {
275
276	# Note: Warnings are always errors if ASSERTs are enabled
277	$SIG{'__WARN__'} = sub { die @_ };
278	}
279
280	if ( $Foswiki::cfg{UseLocale} ) {
281	require locale;
282	import locale();
283	}
284
285	# If not set, default to strikeone validation
286	$Foswiki::cfg{Validation}{Method} \|\|= 'strikeone';
287	$Foswiki::cfg{Validation}{ValidForTime} = $Foswiki::cfg{LeaseLength}
288	unless defined $Foswiki::cfg{Validation}{ValidForTime};
289	$Foswiki::cfg{Validation}{MaxKeys} = 1000
290	unless defined $Foswiki::cfg{Validation}{MaxKeys};
291
292	# Constant tags dependent on the config
293	$functionTags{ALLOWLOGINNAME} =
294	sub { $Foswiki::cfg{Register}{AllowLoginName} \|\| 0 };
295	$functionTags{AUTHREALM} = sub { $Foswiki::cfg{AuthRealm} };
296	$functionTags{DEFAULTURLHOST} = sub { $Foswiki::cfg{DefaultUrlHost} };
297	$functionTags{HOMETOPIC} = sub { $Foswiki::cfg{HomeTopicName} };
298	$functionTags{LOCALSITEPREFS} = sub { $Foswiki::cfg{LocalSitePreferences} };
299	$functionTags{NOFOLLOW} =
300	sub { $Foswiki::cfg{NoFollow} ? 'rel=' . $Foswiki::cfg{NoFollow} : '' };
301	$functionTags{NOTIFYTOPIC} = sub { $Foswiki::cfg{NotifyTopicName} };
302	$functionTags{SCRIPTSUFFIX} = sub { $Foswiki::cfg{ScriptSuffix} };
303	$functionTags{STATISTICSTOPIC} = sub { $Foswiki::cfg{Stats}{TopicName} };
304	$functionTags{SYSTEMWEB} = sub { $Foswiki::cfg{SystemWebName} };
305	$functionTags{TRASHWEB} = sub { $Foswiki::cfg{TrashWebName} };
306	$functionTags{WIKIADMINLOGIN} = sub { $Foswiki::cfg{AdminUserLogin} };
307	$functionTags{USERSWEB} = sub { $Foswiki::cfg{UsersWebName} };
308	$functionTags{WEBPREFSTOPIC} = sub { $Foswiki::cfg{WebPrefsTopicName} };
309	$functionTags{WIKIPREFSTOPIC} = sub { $Foswiki::cfg{SitePrefsTopicName} };
310	$functionTags{WIKIUSERSTOPIC} = sub { $Foswiki::cfg{UsersTopicName} };
311	$functionTags{WIKIWEBMASTER} = sub { $Foswiki::cfg{WebMasterEmail} };
312	$functionTags{WIKIWEBMASTERNAME} = sub { $Foswiki::cfg{WebMasterName} };
313
314	# locale setup
315	#
316	#
317	# Note that 'use locale' must be done in BEGIN block for regexes and
318	# sorting to work properly, although regexes can still work without
319	# this in 'non-locale regexes' mode.
320
321	if ( $Foswiki::cfg{UseLocale} ) {
322
323	# Set environment variables for grep
324	$ENV{LC_CTYPE} = $Foswiki::cfg{Site}{Locale};
325
326	# Load POSIX for I18N support.
327	require POSIX;
328	import POSIX qw( locale_h LC_CTYPE LC_COLLATE );
329
330	# SMELL: mod_perl compatibility note: If Foswiki is running under Apache,
331	# won't this play with the Apache process's locale settings too?
332	# What effects would this have?
333	setlocale( &LC_CTYPE, $Foswiki::cfg{Site}{Locale} );
334	setlocale( &LC_COLLATE, $Foswiki::cfg{Site}{Locale} );
335	}
336
337	$functionTags{CHARSET} = sub {
338	$Foswiki::cfg{Site}{CharSet}
339	\|\| 'iso-8859-1';
340	};
341
342	$functionTags{LANG} = sub {
343	$Foswiki::cfg{Site}{Locale} =~ m/^([a-z]+_[a-z]+)/i ? $1 : 'en_US';
344	};
345
346	# Set up pre-compiled regexes for use in rendering. All regexes with
347	# unchanging variables in match should use the '/o' option.
348	# In the regex hash, all precompiled REs have "Regex" at the
349	# end of the name. Anything else is a string, either intended
350	# for use as a character class, or as a sub-expression in
351	# another compiled RE.
352
353	# Build up character class components for use in regexes.
354	# Depends on locale mode and Perl version, and finally on
355	# whether locale-based regexes are turned off.
356	if ( not $Foswiki::cfg{UseLocale}
357	or $] < 5.006
358	or not $Foswiki::cfg{Site}{LocaleRegexes} )
359	{
360
361	# No locales needed/working, or Perl 5.005, so just use
362	# any additional national characters defined in LocalSite.cfg
363	$regex{upperAlpha} = 'A-Z' . $Foswiki::cfg{UpperNational};
364	$regex{lowerAlpha} = 'a-z' . $Foswiki::cfg{LowerNational};
365	$regex{numeric} = '\d';
366	$regex{mixedAlpha} = $regex{upperAlpha} . $regex{lowerAlpha};
367	}
368	else {
369
370	# Perl 5.006 or higher with working locales
371	$regex{upperAlpha} = '[:upper:]';
372	$regex{lowerAlpha} = '[:lower:]';
373	$regex{numeric} = '[:digit:]';
374	$regex{mixedAlpha} = '[:alpha:]';
375	}
376	$regex{mixedAlphaNum} = $regex{mixedAlpha} . $regex{numeric};
377	$regex{lowerAlphaNum} = $regex{lowerAlpha} . $regex{numeric};
378	$regex{upperAlphaNum} = $regex{upperAlpha} . $regex{numeric};
379
380	# Compile regexes for efficiency and ease of use
381	# Note: qr// locks in regex modes (i.e. '-xism' here) - see Friedl
382	# book at http://regex.info/.
383
384	$regex{linkProtocolPattern} = $Foswiki::cfg{LinkProtocolPattern};
385
386	# Header patterns based on '+++'. The '###' are reserved for numbered
387	# headers
388	# '---++ Header', '---## Header'
389	$regex{headerPatternDa} = qr/^---+(\++\|\#+)(.*)$/m;
390
391	# '<h6>Header</h6>
392	$regex{headerPatternHt} = qr/^<h([1-6])>(.+?)<\/h\1>/mi;
393
394	# '---++!! Header' or '---++ Header %NOTOC% ^top'
395	$regex{headerPatternNoTOC} = '(\!\!+\|%NOTOC%)';
396
397	# Foswiki concept regexes
398	$regex{wikiWordRegex} =
399	qr/[$regex{upperAlpha}]+[$regex{lowerAlphaNum}]+[$regex{upperAlpha}]+[$regex{mixedAlphaNum}]*/o;
400	$regex{webNameBaseRegex} =
401	qr/[$regex{upperAlpha}]+[$regex{mixedAlphaNum}_]*/o;
402	if ( $Foswiki::cfg{EnableHierarchicalWebs} ) {
403	$regex{webNameRegex} =
404	qr/$regex{webNameBaseRegex}(?:(?:[\.\/]$regex{webNameBaseRegex})+)*/o;
405	}
406	else {
407	$regex{webNameRegex} = $regex{webNameBaseRegex};
408	}
409	$regex{defaultWebNameRegex} = qr/_[$regex{mixedAlphaNum}_]+/o;
410	$regex{anchorRegex} = qr/\#[$regex{mixedAlphaNum}_]+/o;
411	$regex{abbrevRegex} = qr/[$regex{upperAlpha}]{3,}s?\b/o;
412	$regex{topicNameRegex} =
413	qr/(?:(?:$regex{wikiWordRegex})\|(?:$regex{abbrevRegex}))/o;
414
415	# Simplistic email regex, e.g. for WebNotify processing - no i18n
416	# characters allowed
417	$regex{emailAddrRegex} =
418	qr/([a-z0-9!+$%&'*+-\/=?^_`{\|}~.]+\@[a-z0-9\.\-]+)/i;
419
420	# Filename regex to used to match invalid characters in attachments - allow
421	# alphanumeric characters, spaces, underscores, etc.
422	# TODO: Get this to work with I18N chars - currently used only with UseLocale off
423	$regex{filenameInvalidCharRegex} = qr/[^$regex{mixedAlphaNum}\. _-]/o;
424
425	# Multi-character alpha-based regexes
426	$regex{mixedAlphaNumRegex} = qr/[$regex{mixedAlphaNum}]*/o;
427
428	# %TAG% name
429	$regex{tagNameRegex} =
430	'[' . $regex{mixedAlpha} . '][' . $regex{mixedAlphaNum} . '_:]*';
431
432	# Set statement in a topic
433	$regex{bulletRegex} = '^(?:\t\| )+\*';
434	$regex{setRegex} = $regex{bulletRegex} . '\s+(Set\|Local)\s+';
435	$regex{setVarRegex} =
436	$regex{setRegex} . '(' . $regex{tagNameRegex} . ')\s=\s(.*)$';
437
438	# Character encoding regexes
439
440	# 7-bit ASCII only
441	$regex{validAsciiStringRegex} = qr/^[\x00-\x7F]+$/o;
442
443	# Regex to match only a valid UTF-8 character, taking care to avoid
444	# security holes due to overlong encodings by excluding the relevant
445	# gaps in UTF-8 encoding space - see 'perldoc perlunicode', Unicode
446	# Encodings section. Tested against Markus Kuhn's UTF-8 test file
447	# at http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt.
448	$regex{validUtf8CharRegex} = qr{
449	# Single byte - ASCII
450	[\x00-\x7F]
451	\|
452
453	# 2 bytes
454	[\xC2-\xDF][\x80-\xBF]
455	\|
456
457	# 3 bytes
458
459	# Avoid illegal codepoints - negative lookahead
460	(?!\xEF\xBF[\xBE\xBF])
461
462	# Match valid codepoints
463	(?:
464	([\xE0][\xA0-\xBF])\|
465	([\xE1-\xEC\xEE-\xEF][\x80-\xBF])\|
466	([\xED][\x80-\x9F])
467	)
468	[\x80-\xBF]
469	\|
470
471	# 4 bytes
472	(?:
473	([\xF0][\x90-\xBF])\|
474	([\xF1-\xF3][\x80-\xBF])\|
475	([\xF4][\x80-\x8F])
476	)
477	[\x80-\xBF][\x80-\xBF]
478	}xo;
479
480	$regex{validUtf8StringRegex} = qr/^ (?: $regex{validUtf8CharRegex} )+ $/xo;
481
482	# Check for unsafe search regex mode (affects filtering in) - default
483	# to safe mode
484	$Foswiki::cfg{ForceUnsafeRegexes} = 0
485	unless defined $Foswiki::cfg{ForceUnsafeRegexes};
486
487	# initialize lib directory early because of later 'cd's
488	_getLibDir();
489
490	# initialize the runtime engine
491	if ( !defined $Foswiki::cfg{Engine} ) {
492
493	# Caller did not define an engine; try and work it out (mainly for
494	# the benefit of pre-1.0 CGI scripts)
495	$Foswiki::cfg{Engine} = 'Foswiki::Engine::Legacy';
496	}
497	$engine = eval qq(use $Foswiki::cfg{Engine}; $Foswiki::cfg{Engine}->new);
498	die $@ if $@;
499
500	Monitor::MARK('Static configuration loaded');
501	}
502
503	=begin TML
504
505	---++ ObjectMethod UTF82SiteCharSet( $utf8 ) -> $ascii
506
507	Auto-detect UTF-8 vs. site charset in string, and convert UTF-8 into site
508	charset.
509
510	=cut
511
512	sub UTF82SiteCharSet {
513	my ( $this, $text ) = @_;
514
515	return $text unless ( defined $Foswiki::cfg{Site}{CharSet} );
516
517	# Detect character encoding of the full topic name from URL
518	return undef if ( $text =~ $regex{validAsciiStringRegex} );
519
520	# SMELL: all this regex stuff should go away.
521	# If not UTF-8 - assume in site character set, no conversion required
522	if ( $^O eq 'darwin' ) {
523
524	#this is a gross over-generalisation - as not all darwins are apple's
525	# and not all darwins use apple's perl
526	my $trial = $text;
527	$trial =~ s/$regex{validUtf8CharRegex}//g;
528	return unless ( length($trial) == 0 );
529	}
530	else {
531
532	#SMELL: this seg faults on OSX leopard. (and possibly others)
533	return undef unless ( $text =~ $regex{validUtf8StringRegex} );
534	}
535
536	# If site charset is already UTF-8, there is no need to convert anything:
537	if ( $Foswiki::cfg{Site}{CharSet} =~ /^utf-?8$/i ) {
538
539	# warn if using Perl older than 5.8
540	if ( $] < 5.008 ) {
541	$this->logger->log( 'warning',
542	'UTF-8 not remotely supported on Perl '
543	. $]
544	. ' - use Perl 5.8 or higher..' );
545	}
546
547	# We still don't have Codev.UnicodeSupport
548	$this->logger->log( 'warning',
549	'UTF-8 not yet supported as site charset -'
550	. 'Foswiki is likely to have problems' );
551	return $text;
552	}
553
554	# Convert into ISO-8859-1 if it is the site charset. This conversion
555	# is not valid for ISO-8859-15.
556	if ( $Foswiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
557
558	# ISO-8859-1 maps onto first 256 codepoints of Unicode
559	# (conversion from 'perldoc perluniintro')
560	$text =~ s/ ([\xC2\xC3]) ([\x80-\xBF]) /
561	chr( ord($1) << 6 & 0xC0 \| ord($2) & 0x3F )
562	/egx;
563	}
564	else {
565
566	# Convert from UTF-8 into some other site charset
567	if ( $] >= 5.008 ) {
568	require Encode;
569	import Encode qw(:fallbacks);
570
571	# Map $Foswiki::cfg{Site}{CharSet} into real encoding name
572	my $charEncoding =
573	Encode::resolve_alias( $Foswiki::cfg{Site}{CharSet} );
574	if ( not $charEncoding ) {
575	$this->logger->log( 'warning',
576	'Conversion to "'
577	. $Foswiki::cfg{Site}{CharSet}
578	. '" not supported, or name not recognised - check '
579	. '"perldoc Encode::Supported"' );
580	}
581	else {
582
583	# Convert text using Encode:
584	# - first, convert from UTF8 bytes into internal
585	# (UTF-8) characters
586	$text = Encode::decode( 'utf8', $text );
587
588	# - then convert into site charset from internal UTF-8,
589	# inserting \x{NNNN} for characters that can't be converted
590	$text = Encode::encode( $charEncoding, $text, &FB_PERLQQ() );
591	}
592	}
593	else {
594	require Unicode::MapUTF8; # Pre-5.8 Perl versions
595	my $charEncoding = $Foswiki::cfg{Site}{CharSet};
596	if ( not Unicode::MapUTF8::utf8_supported_charset($charEncoding) ) {
597	$this->logger->log( 'warning',
598	'Conversion to "'
599	. $Foswiki::cfg{Site}{CharSet}
600	. '" not supported, or name not recognised - check '
601	. '"perldoc Unicode::MapUTF8"' );
602	}
603	else {
604
605	# Convert text
606	$text = Unicode::MapUTF8::from_utf8(
607	{
608	-string => $text,
609	-charset => $charEncoding
610	}
611	);
612
613	# FIXME: Check for failed conversion?
614	}
615	}
616	}
617	return $text;
618	}
619
620	=begin TML
621
622	---++ ObjectMethod writeCompletePage( $text, $pageType, $contentType )
623
624	Write a complete HTML page with basic header to the browser.
625	* =$text= is the text of the page body (<html> to </html> if it's HTML)
626	* =$pageType= - May be "edit", which will cause headers to be generated that force
627	caching for 24 hours, to prevent Codev.BackFromPreviewLosesText bug, which caused
628	data loss with IE5 and IE6.
629	* =$contentType= - page content type \| text/html
630
631	This method removes noautolink and nop tags before outputting the page unless
632	$contentType is text/plain.
633
634	=cut
635
636	sub writeCompletePage {
637	my ( $this, $text, $pageType, $contentType ) = @_;
638	$contentType \|\|= 'text/html';
639
640	if ( $contentType ne 'text/plain' ) {
641
642	# Remove <nop> and <noautolink> tags
643	$text =~ s/([\t ]?)[ \t]*<\/?(nop\|noautolink)\/?>/$1/gis;
644	$text .= "\n" unless $text =~ /\n$/s;
645
646	my $cgis = $this->getCGISession();
647	if ( $cgis && $contentType eq 'text/html'
648	&& $Foswiki::cfg{Validation}{Method} ne 'none') {
649	# Don't expire the validation key through login, or when
650	# endpoint is an error.
651	Foswiki::Validation::expireValidationKeys($cgis)
652	unless ($this->{request}->action() eq 'login'
653	or ( $ENV{REDIRECT_STATUS} \|\| 0 ) >= 400);
654	my $usingStrikeOne = 0;
655	if ($Foswiki::cfg{Validation}{Method} eq 'strikeone'
656	# Add the onsubmit handler to the form
657	&& $text =~ s/(<form[^>]method=['"]POST['"][^>]>)/
658	Foswiki::Validation::addOnSubmit($1)/gei) {
659	# At least one form has been touched; add the validation
660	# cookie
661	$this->{users}->{loginManager}->addCookie(
662	Foswiki::Validation::getCookie(
663	$cgis, $this->{response}));
664	# Add the JS module to the page. Note that this is not
665	# incorporated into the foswikilib.js because that module
666	# is conditionally loaded under the control of the
667	# templates, and we have to be sure it gets loaded.
668	$this->addToHEAD( 'FOSWIKI STRIKE ONE',
669	<<STRIKEONE);
670	<script type="text/javascript" src="$Foswiki::cfg{PubUrlPath}/$Foswiki::cfg{SystemWebName}/JavascriptFiles/strikeone.js"></script>
671	STRIKEONE
672	$usingStrikeOne = 1;
673	}
674	# Inject validation key in HTML forms
675	my $context =
676	$this->{request}->url( -full => 1, -path => 1, -query => 1 )
677	. time();
678	$text =~ s/(<form[^>]method=['"]POST['"][^>]>)/
679	$1 . Foswiki::Validation::addValidationKey(
680	$cgis, $context, $usingStrikeOne )/gei;
681	}
682	my $htmlHeader = join( "\n",
683	map { '<!--' . $_ . '-->' . $this->{_HTMLHEADERS}{$_} }
684	keys %{ $this->{_HTMLHEADERS} } );
685	$text =~ s!(</head>)!$htmlHeader$1!i if $htmlHeader;
686	chomp($text);
687	}
688
689	$this->generateHTTPHeaders( undef, $pageType, $contentType );
690	my $hdr = $this->{response}->printHeaders;
691
692	# Call final handler
693	$this->{plugins}->dispatch( 'completePageHandler', $text, $hdr );
694
695	$this->{response}->print($text);
696	}
697
698	=begin TML
699
700	---++ ObjectMethod generateHTTPHeaders( $query, $pageType, $contentType ) -> $header
701
702	All parameters are optional.
703
704	* =$query= CGI query object \| Session CGI query (there is no good reason to set this)
705	* =$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.
706	* =$contentType= - page content type \| text/html
707
708	=cut
709
710	sub generateHTTPHeaders {
711	my ( $this, $query, $pageType, $contentType ) = @_;
712
713	$query = $this->{request} unless $query;
714
715	# Handle Edit pages - future versions will extend to caching
716	# of other types of page, with expiry time driven by page type.
717	my ( $pluginHeaders, $coreHeaders );
718
719	my $hopts = {};
720
721	if ( $pageType && $pageType eq 'edit' ) {
722
723	# Get time now in HTTP header format
724	require Foswiki::Time;
725	my $lastModifiedString =
726	Foswiki::Time::formatTime( time, '$http', 'gmtime' );
727
728	# Expiry time is set high to avoid any data loss. Each instance of
729	# Edit page has a unique URL with time-string suffix (fix for
730	# RefreshEditPage), so this long expiry time simply means that the
731	# browser Back button always works. The next Edit on this page
732	# will use another URL and therefore won't use any cached
733	# version of this Edit page.
734	my $expireHours = 24;
735	my $expireSeconds = $expireHours * 60 * 60;
736
737	# and cache control headers, to ensure edit page
738	# is cached until required expiry time.
739	$hopts->{'last-modified'} = $lastModifiedString;
740	$hopts->{expires} = "+${expireHours}h";
741	$hopts->{'cache-control'} = "max-age=$expireSeconds";
742	}
743
744	# DEPRECATED plugins header handler. Plugins should use
745	# modifyHeaderHandler instead.
746	$pluginHeaders = $this->{plugins}->dispatch( 'writeHeaderHandler', $query )
747	\|\| '';
748	if ($pluginHeaders) {
749	foreach ( split /\r?\n/, $pluginHeaders ) {
750
751	# Implicit untaint OK; data from plugin handler
752	if (m/^([\-a-z]+): (.*)$/i) {
753	$hopts->{$1} = $2;
754	}
755	}
756	}
757
758	$contentType = 'text/html' unless $contentType;
759	if ( defined( $Foswiki::cfg{Site}{CharSet} ) ) {
760	$contentType .= '; charset=' . $Foswiki::cfg{Site}{CharSet};
761	}
762
763	# use our version of the content type
764	$hopts->{'Content-Type'} = $contentType;
765
766	# New (since 1.026)
767	$this->{plugins}
768	->dispatch( 'modifyHeaderHandler', $hopts, $this->{request} );
769
770	# add cookie(s)
771	$this->{users}->{loginManager}->modifyHeader($hopts);
772
773	# The headers method resets all headers to what we pass
774	# what we want is simply ensure our headers are there
775	$this->{response}->setDefaultHeaders($hopts);
776	}
777
778	# Tests if the $redirect is an external URL, returning false if
779	# AllowRedirectUrl is denied
780	sub _isRedirectSafe {
781	my $redirect = shift;
782
783	return 1 if ( $Foswiki::cfg{AllowRedirectUrl} );
784	return 1 if $redirect =~ m#^/#; # relative URL - OK
785
786	#TODO: this should really use URI
787	# Compare protocol, host name and port number
788	if ( $redirect =~ m!^(.?://[^/?#])! ) {
789
790	# implicit untaints OK because result not used. uc retaints
791	# if use locale anyway.
792	my $target = uc($1);
793
794	$Foswiki::cfg{DefaultUrlHost} =~ m!^(.?://[^/])!;
795	return 1 if ( $target eq uc($1) );
796
797	if ( $Foswiki::cfg{PermittedRedirectHostUrls} ) {
798	foreach my $red (
799	split( /\s,\s/, $Foswiki::cfg{PermittedRedirectHostUrls} ) )
800	{
801	$red =~ m!^(.?://[^/])!;
802	return 1 if ( $target eq uc($1) );
803	}
804	}
805	}
806	return 0;
807	}
808
809	=begin TML
810
811	---++ ObjectMethod redirectto($url) -> $url
812	Gets a redirect url from CGI parameter 'redirectto', if present on the query.
813
814	If the redirectto CGI parameter specifies a valid redirection target it is
815	returned; otherwise the original URL passed in the parameter is returned.
816
817	Conditions for a valid redirection target are:
818	* The target matches the linkProtocolPattern regex, and redirection
819	to the url _isRedirectSafe
820	* The target specified a topic, or a Web.Topic (redirect will be to
821	'view')
822
823	=cut
824
825	sub redirectto {
826	my ( $this, $url ) = @_;
827	ASSERT($url);
828
829	my $redirecturl = $this->{request}->param('redirectto');
830	return $url unless $redirecturl;
831
832	if ( $redirecturl =~ m#^$regex{linkProtocolPattern}://#o ) {
833
834	# assuming URL
835	if ( _isRedirectSafe($redirecturl) ) {
836	return $redirecturl;
837	}
838	else {
839	return $url;
840	}
841	}
842
843	# assuming 'web.topic' or 'topic'
844	my ( $w, $t ) =
845	$this->normalizeWebTopicName( $this->{webName}, $redirecturl );
846
847	# capture anchor
848	my ( $topic, $anchor ) = split( '#', $t, 2 );
849	$t = $topic if $topic;
850	my @attrs = ();
851	push( @attrs, '#' => $anchor ) if $anchor;
852
853	return $this->getScriptUrl( 1, 'view', $w, $t, @attrs );
854	}
855
856	=begin TML
857
858	---++ StaticMethod splitAnchorFromUrl( $url ) -> ( $url, $anchor )
859
860	Takes a full url (including possible query string) and splits off the anchor.
861	The anchor includes the # sign. Returns an empty string if not found in the url.
862
863	=cut
864
865	sub splitAnchorFromUrl {
866	my ($url) = @_;
867
868	($url, my $anchor) = $url =~ m/^(.?)(#(.?))*$/;
869	return ( $url, $anchor );
870	}
871
872	=begin TML
873
874	---++ ObjectMethod redirect( $url, $passthrough )
875
876	* $url - url or topic to redirect to
877	* $passthrough - (optional) parameter to pass through current query
878	parameters (see below)
879
880	Redirects the request to =$url=, unless
881	1 It is overridden by a plugin declaring a =redirectCgiQueryHandler=.
882	1 =$session->{request}= is =undef= or
883	Thus a redirect is only generated when in a CGI context.
884
885	Normally this method will ignore parameters to the current query. Sometimes,
886	for example when redirecting to a login page during authentication (and then
887	again from the login page to the original requested URL), you want to make
888	sure all parameters are passed on, and for this $passthrough should be set to
889	true. In this case it will pass all parameters that were passed to the
890	current query on to the redirect target. If the request_method for the
891	current query was GET, then all parameters will be passed by encoding them
892	in the URL (after ?). If the request_method was POST, then there is a risk the
893	URL would be too big for the receiver, so it caches the form data and passes
894	over a cache reference in the redirect GET.
895
896	NOTE: Passthrough is only meaningful if the redirect target is on the same
897	server.
898
899	=cut
900
901	sub redirect {
902	my ( $this, $url, $passthru ) = @_;
903	ASSERT( defined $url );
904
905	my $query = $this->{request};
906
907	# if we got here without a query, there's not much more we can do
908	return unless $query;
909
910	( $url, my $anchor ) = splitAnchorFromUrl($url);
911
912	if ( $passthru && defined $query->method() ) {
913	my $existing = '';
914	if ( $url =~ s/\?(.*)$// ) {
915	$existing = $1; # implicit untaint OK; recombined later
916	}
917
918	if ( uc( $query->method() ) eq 'POST' ) {
919
920	# Redirecting from a post to a get
921	my $cache = $this->cacheQuery();
922	if ($cache) {
923	if ($url eq '/') {
924	$url = $this->getScriptUrl(1, 'view');
925	}
926	$url .= $cache;
927	}
928	}
929	else {
930	# Redirecting a get to a get; no need to use passthru
931	if ( $query->query_string() ) {
932	$url .= '?' . $query->query_string();
933	}
934	if ($existing) {
935	if ( $url =~ /\?/ ) {
936	$url .= ';';
937	}
938	else {
939	$url .= '?';
940	}
941	$url .= $existing;
942	}
943	}
944	}
945
946	# prevent phishing by only allowing redirect to configured host
947	# do this check as late as possible to catch _any_ last minute hacks
948	# TODO: this should really use URI
949	if ( !_isRedirectSafe($url) ) {
950
951	# goto oops if URL is trying to take us somewhere dangerous
952	$url = $this->getScriptUrl(
953	1, 'oops',
954	$this->{web} \|\| $Foswiki::cfg{UsersWebName},
955	$this->{topic} \|\| $Foswiki::cfg{HomeTopicName},
956	template => 'oopsaccessdenied',
957	def => 'topic_access',
958	param1 => 'redirect',
959	param2 => 'unsafe redirect to '
960	. $url
961	. ': host does not match {DefaultUrlHost} , and is not in {PermittedRedirectHostUrls}"'
962	. $Foswiki::cfg{DefaultUrlHost} . '"'
963	);
964	}
965
966	$url .= $anchor if $anchor;
967
968	return
969	if ( $this->{plugins}
970	->dispatch( 'redirectCgiQueryHandler', $this->{response}, $url ) );
971
972	# SMELL: this is a bad breaking of encapsulation: the loginManager
973	# should just modify the url, then the redirect should only happen here.
974	return !$this->{users}->{loginManager}->redirectCgiQuery( $query, $url );
975	}
976
977	=begin TML
978
979	---++ ObjectMethod cacheQuery() -> $queryString
980
981	Caches the current query in the params cache, and returns a rewritten
982	query string for the cache to be picked up again on the other side of a
983	redirect.
984
985	We can't encode post params into a redirect, because they may exceed the
986	size of the GET request. So we cache the params, and reload them when the
987	redirect target is reached.
988
989	=cut
990
991	sub cacheQuery {
992	my $this = shift;
993	my $query = $this->{request};
994
995	return '' unless ( scalar( $query->param() ) );
996
997	# Don't double-cache
998	return '' if ( $query->param('foswiki_redirect_cache') );
999
1000	$this->{digester}->add( $$, rand(time) );
1001	my $uid = $this->{digester}->hexdigest();
1002	my $passthruFilename = "$Foswiki::cfg{WorkingDir}/tmp/passthru_$uid";
1003
1004	# passthrough file is only written to once, so if it already exists,
1005	# suspect a security hack (O_EXCL)
1006	sysopen( F, "$passthruFilename", O_RDWR \| O_EXCL \| O_CREAT, 0600 )
1007	\|\| die 'Unable to open '.$Foswiki::cfg{WorkingDir}
1008	.'/tmp for write; check the setting of {WorkingDir} in configure,'
1009	.' and check file permissions: '.$!;
1010	$query->save( \*F );
1011	close(F);
1012
1013	if ($Foswiki::cfg{UsePathForRedirectCache}) {
1014	return '/foswiki_redirect_cache/' . $uid;
1015	} else {
1016	return '?foswiki_redirect_cache=' . $uid;
1017	}
1018	}
1019
1020	=begin TML
1021
1022	---++ ObjectMethod getCGISession() -> $cgisession
1023
1024	Get the CGI::Session object associated with this session, if there is
1025	one. May return undef.
1026
1027	=cut
1028
1029	sub getCGISession {
1030	my $this = shift;
1031	return $this->{users}->{loginManager}->{_cgisession};
1032	}
1033
1034	=begin TML
1035
1036	---++ StaticMethod isValidWikiWord( $name ) -> $boolean
1037
1038	Check for a valid WikiWord or WikiName
1039
1040	=cut
1041
1042	sub isValidWikiWord {
1043	my $name = shift \|\| '';
1044	return ( $name =~ m/^$regex{wikiWordRegex}$/o );
1045	}
1046
1047	=begin TML
1048
1049	---++ StaticMethod isValidTopicName( $name [, $nonww] ) -> $boolean
1050
1051	Check for a valid topic =$name=. If =$nonww=, then accept non wiki-words
1052	(though they must still be composed of only valid, unfiltered characters)
1053
1054	=cut
1055
1056	# Note: must work on tainted names.
1057	sub isValidTopicName {
1058	my ( $name, $nonww ) = @_;
1059
1060	return 0 unless defined $name && $name ne '';
1061	return 1 if ( $name =~ m/^$regex{topicNameRegex}$/o );
1062	return 0 unless $nonww;
1063	return 0 if $name =~ /$Foswiki::cfg{NameFilter}/;
1064	return 1;
1065	}
1066
1067	=begin TML
1068
1069	---++ StaticMethod isValidWebName( $name, $system ) -> $boolean
1070
1071	STATIC Check for a valid web name. If $system is true, then
1072	system web names are considered valid (names starting with _)
1073	otherwise only user web names are valid
1074
1075	If $Foswiki::cfg{EnableHierarchicalWebs} is off, it will also return false
1076	when a nested web name is passed to it.
1077
1078	=cut
1079
1080	# Note: must work on tainted names.
1081	sub isValidWebName {
1082	my $name = shift \|\| '';
1083	my $sys = shift;
1084	return 1 if ( $sys && $name =~ m/^$regex{defaultWebNameRegex}$/o );
1085	return ( $name =~ m/^$regex{webNameRegex}$/o );
1086	}
1087
1088	=begin TML
1089
1090	---++ StaticMethod isValidEmailAddress( $name ) -> $boolean
1091
1092	STATIC Check for a valid email address name.
1093
1094	=cut
1095
1096	# Note: must work on tainted names.
1097	sub isValidEmailAddress {
1098	my ($name) = @_;
1099	return $name =~ /^$regex{emailAddrRegex}$/;
1100	}
1101
1102	=begin TML
1103
1104	---++ ObjectMethod getSkin () -> $string
1105
1106	Get the currently requested skin path
1107
1108	=cut
1109
1110	sub getSkin {
1111	my $this = shift;
1112
1113	my $skinpath = $this->{prefs}->getPreferencesValue('SKIN') \|\| '';
1114
1115	if ( $this->{request} ) {
1116	my $resurface = $this->{request}->param('skin');
1117	$skinpath = $resurface if $resurface;
1118	}
1119
1120	my $epidermis = $this->{prefs}->getPreferencesValue('COVER');
1121	$skinpath = $epidermis . ',' . $skinpath if $epidermis;
1122
1123	if ( $this->{request} ) {
1124	$epidermis = $this->{request}->param('cover');
1125	$skinpath = $epidermis . ',' . $skinpath if $epidermis;
1126	}
1127
1128	return $skinpath;
1129	}
1130
1131	=begin TML
1132
1133	---++ ObjectMethod getScriptUrl( $absolute, $script, $web, $topic, ... ) -> $scriptURL
1134
1135	Returns the URL to a Foswiki script, providing the web and topic as
1136	"path info" parameters. The result looks something like this:
1137	"http://host/foswiki/bin/$script/$web/$topic".
1138	* =...= - 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. <tt>getScriptUrl('x','y','view','#'=>'XXX',a=>1,b=>2)</tt> will give <tt>.../view/x/y?a=1&b=2#XXX</tt>
1139
1140	If $absolute is set, generates an absolute URL. $absolute is advisory only;
1141	Foswiki can decide to generate absolute URLs (for example when run from the
1142	command-line) even when relative URLs have been requested.
1143
1144	The default script url is taken from {ScriptUrlPath}, unless there is
1145	an exception defined for the given script in {ScriptUrlPaths}. Both
1146	{ScriptUrlPath} and {ScriptUrlPaths} may be absolute or relative URIs. If
1147	they are absolute, then they will always generate absolute URLs. if they
1148	are relative, then they will be converted to absolute when required (e.g.
1149	when running from the command line, or when generating rss). If
1150	$script is not given, absolute URLs will always be generated.
1151
1152	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.
1153
1154	=cut
1155
1156	sub getScriptUrl {
1157	my ( $this, $absolute, $script, $web, $topic, @params ) = @_;
1158
1159	$absolute \|\|=
1160	( $this->inContext('command_line')
1161	\|\| $this->inContext('rss')
1162	\|\| $this->inContext('absolute_urls') );
1163
1164	# SMELL: topics and webs that contain spaces?
1165
1166	my $url;
1167	if ( defined $Foswiki::cfg{ScriptUrlPaths} && $script ) {
1168	$url = $Foswiki::cfg{ScriptUrlPaths}{$script};
1169	}
1170	unless ( defined($url) ) {
1171	$url = $Foswiki::cfg{ScriptUrlPath};
1172	if ($script) {
1173	$url .= '/' unless $url =~ /\/$/;
1174	$url .= $script;
1175	if (
1176	rindex( $url, $Foswiki::cfg{ScriptSuffix} ) !=
1177	( length($url) - length( $Foswiki::cfg{ScriptSuffix} ) ) )
1178	{
1179	$url .= $Foswiki::cfg{ScriptSuffix} if $script;
1180	}
1181	}
1182	}
1183
1184	if ( $absolute && $url !~ /^[a-z]+:/ ) {
1185
1186	# See http://www.ietf.org/rfc/rfc2396.txt for the definition of
1187	# "absolute URI". Foswiki bastardises this definition by assuming
1188	# that all relative URLs lack the <authority> component as well.
1189	$url = $this->{urlHost} . $url;
1190	}
1191
1192	if ( $web \|\| $topic ) {
1193	( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
1194
1195	$url .= urlEncode( '/' . $web . '/' . $topic );
1196
1197	$url .= _make_params( 0, @params );
1198	}
1199
1200	return $url;
1201	}
1202
1203	sub _make_params {
1204	my ( $notfirst, @args ) = @_;
1205	my $url = '';
1206	my $ps = '';
1207	my $anchor = '';
1208	while ( my $p = shift @args ) {
1209	if ( $p eq '#' ) {
1210	$anchor .= '#' . urlEncode( shift(@args) );
1211	}
1212	else {
1213	$ps .= ';' . urlEncode($p) . '=' . urlEncode( shift(@args) \|\| '' );
1214	}
1215	}
1216	if ($ps) {
1217	$ps =~ s/^;/?/ unless $notfirst;
1218	$url .= $ps;
1219	}
1220	$url .= $anchor;
1221	return $url;
1222	}
1223
1224	=begin TML
1225
1226	---++ ObjectMethod getPubUrl($absolute, $web, $topic, $attachment) -> $url
1227
1228	Composes a pub url. If $absolute is set, returns an absolute URL.
1229	If $absolute is set, generates an absolute URL. $absolute is advisory only;
1230	Foswiki can decide to generate absolute URLs (for example when run from the
1231	command-line) even when relative URLs have been requested.
1232
1233	$web, $topic and $attachment are optional. A partial URL path will be
1234	generated if one or all is not given.
1235
1236	=cut
1237
1238	sub getPubUrl {
1239	my ( $this, $absolute, $web, $topic, $attachment ) = @_;
1240
1241	$absolute \|\|=
1242	( $this->inContext('command_line')
1243	\|\| $this->inContext('rss')
1244	\|\| $this->inContext('absolute_urls') );
1245
1246	my $url = '';
1247	$url .= $Foswiki::cfg{PubUrlPath};
1248	if ( $absolute && $url !~ /^[a-z]+:/ ) {
1249
1250	# See http://www.ietf.org/rfc/rfc2396.txt for the definition of
1251	# "absolute URI". Foswiki bastardises this definition by assuming
1252	# that all relative URLs lack the <authority> component as well.
1253	$url = $this->{urlHost} . $url;
1254	}
1255	if ( $web \|\| $topic \|\| $attachment ) {
1256	( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
1257
1258	my $path = '/' . $web . '/' . $topic;
1259	if ($attachment) {
1260	$path .= '/' . $attachment;
1261
1262	# Attachments are served directly by web server, need to handle
1263	# URL encoding specially
1264	$url .= urlEncodeAttachment($path);
1265	}
1266	else {
1267	$url .= urlEncode($path);
1268	}
1269	}
1270
1271	return $url;
1272	}
1273
1274	=begin TML
1275
1276	---++ ObjectMethod getIconUrl( $absolute, $iconName ) -> $iconURL
1277
1278	Map an icon name to a URL path.
1279
1280	=cut
1281
1282	sub getIconUrl {
1283	my ( $this, $absolute, $iconName ) = @_;
1284
1285	my $iconTopic = $this->{prefs}->getPreferencesValue('ICONTOPIC');
1286	if ( defined($iconTopic) ) {
1287	$iconTopic =~ s/\s+$//;
1288	my ( $web, $topic ) =
1289	$this->normalizeWebTopicName( $this->{webName}, $iconTopic );
1290	$iconName =~ s/^.\.(.?)$/$1/;
1291	return $this->getPubUrl( $absolute, $web, $topic, $iconName . '.gif' );
1292	}
1293	else {
1294	return '';
1295	}
1296	}
1297
1298	=begin TML
1299
1300	---++ ObjectMethod mapToIconFileName( $fileName, $default ) -> $fileName
1301
1302	Maps from a filename (or just the extension) to the name of the
1303	file that contains the image for that file type.
1304
1305	=cut
1306
1307	sub mapToIconFileName {
1308	my ( $this, $fileName, $default ) = @_;
1309
1310	my @bits = ( split( /\./, $fileName ) );
1311	my $fileExt = lc( $bits[$#bits] );
1312
1313	unless ( $this->{_ICONMAP} ) {
1314	my $iconTopic = $this->{prefs}->getPreferencesValue('ICONTOPIC');
1315	if ( defined($iconTopic) ) {
1316	my ( $web, $topic ) =
1317	$this->normalizeWebTopicName( $this->{webName}, $iconTopic );
1318	local $/ = undef;
1319	try {
1320	my $icons =
1321	$this->{store}->getAttachmentStream( undef, $web, $topic,
1322	'_filetypes.txt' );
1323	%{ $this->{_ICONMAP} } = split( /\s+/, <$icons> );
1324	close($icons);
1325	}
1326	catch Error::Simple with {
1327	%{ $this->{_ICONMAP} } = ();
1328	};
1329	}
1330	else {
1331	return $default \|\| $fileName;
1332	}
1333	}
1334
1335	return $this->{_ICONMAP}->{$fileExt} \|\| $default \|\| 'else';
1336	}
1337
1338	=begin TML
1339
1340	---++ ObjectMethod normalizeWebTopicName( $theWeb, $theTopic ) -> ( $theWeb, $theTopic )
1341
1342	Normalize a Web<nop>.<nop>TopicName
1343
1344	See =Foswiki::Func= for a full specification of the expansion (not duplicated
1345	here)
1346
1347	WARNING if there is no web specification (in the web or topic parameters)
1348	the web defaults to $Foswiki::cfg{UsersWebName}. If there is no topic
1349	specification, or the topic is '0', the topic defaults to the web home topic
1350	name.
1351
1352	WARNING if the input topic name is tainted, then the output web and
1353	topic names will be tainted.
1354
1355	=cut
1356
1357	sub normalizeWebTopicName {
1358	my ( $this, $web, $topic ) = @_;
1359
1360	ASSERT( defined $topic ) if DEBUG;
1361
1362	if ( $topic =~ m\|^(.)[./](.?)$\| ) {
1363	$web = $1;
1364	$topic = $2;
1365
1366	if ( DEBUG && !UNTAINTED( $_[2] ) ) {
1367
1368	# retaint data untainted by RE above
1369	$web = TAINT($web);
1370	$topic = TAINT($topic);
1371	}
1372	}
1373	$web \|\|= $cfg{UsersWebName};
1374	$topic \|\|= $cfg{HomeTopicName};
1375
1376	# MAINWEB and TWIKIWEB expanded for compatibility reasons
1377	while (
1378	$web =~ s/%((MAIN\|TWIKI\|USERS\|SYSTEM\|DOC)WEB)%/
1379	$this->_expandTagOnTopicRendering( $1 ) \|\| ''/e
1380	)
1381	{
1382	}
1383
1384	# Normalize web name to use / and not . as a subweb separator
1385	$web =~ s#\.#/#g;
1386
1387	return ( $web, $topic );
1388	}
1389
1390	=begin TML
1391
1392	---++ ClassMethod new( $loginName, $query, \%initialContext )
1393
1394	Constructs a new Foswiki object. Parameters are taken from the query object.
1395
1396	* =$loginName= is the login username (not the wikiname) of the user you
1397	want to be logged-in if none is available from a session or browser.
1398	Used mainly for side scripts and debugging.
1399	* =$query= the Foswiki::Request query (may be undef, in which case an empty query
1400	is used)
1401	* =\%initialContext= - reference to a hash containing context
1402	name=value pairs to be pre-installed in the context hash
1403
1404	=cut
1405
1406	sub new {
1407	my ( $class, $login, $query, $initialContext ) = @_;
1408	ASSERT( !$query \|\| UNIVERSAL::isa( $query, 'Foswiki::Request' ) );
1409	Monitor::MARK("Static compilation complete");
1410
1411	# Compatibility; not used except maybe in plugins
1412	$Foswiki::cfg{TempfileDir} = "$Foswiki::cfg{WorkingDir}/tmp"
1413	unless defined( $Foswiki::cfg{TempfileDir} );
1414
1415	# Set command_line context if there is no query
1416	$initialContext \|\|= defined($query) ? {} : { command_line => 1 };
1417
1418	$query \|\|= new Foswiki::Request();
1419	my $this = bless( { sandbox => 'Foswiki::Sandbox' }, $class );
1420
1421	$this->{request} = $query;
1422	$this->{cgiQuery} = $query; # for backwards compatibility in contribs
1423	$this->{response} = new Foswiki::Response();
1424	$this->{digester} = new Digest::MD5();
1425
1426	# Tell Foswiki::Response which charset we are using if not default
1427	if ( defined $Foswiki::cfg{Site}{CharSet}
1428	&& $Foswiki::cfg{Site}{CharSet} !~ /^iso-?8859-?1$/io )
1429	{
1430	$this->{response}->charset( $Foswiki::cfg{Site}{CharSet} );
1431	}
1432
1433	$this->{_HTMLHEADERS} = {};
1434	$this->{context} = $initialContext;
1435
1436	require Foswiki::Plugins;
1437	$this->{plugins} = new Foswiki::Plugins($this);
1438	require Foswiki::Store;
1439	$this->{store} = new Foswiki::Store($this);
1440
1441	# use login as a default (set when running from cmd line)
1442	$this->{remoteUser} = $login;
1443
1444	require Foswiki::Users;
1445	$this->{users} = new Foswiki::Users($this);
1446	$this->{remoteUser} = $this->{users}->{remoteUser};
1447
1448	# Make %ENV safer, preventing hijack of the search path. The
1449	# environment is set per-query, so this can't be done in a BEGIN.
1450	# TWikibug:Item4382: Default $ENV{PATH} must be untainted because
1451	# Foswiki runs with use strict and calling external programs that
1452	# writes on the disk will fail unless Perl seens it as set to safe value.
1453	if ( $Foswiki::cfg{SafeEnvPath} ) {
1454	$ENV{PATH} = $Foswiki::cfg{SafeEnvPath};
1455	}
1456	else {
1457
1458	# SMELL: how can we validate the PATH?
1459	$ENV{PATH} = Foswiki::Sandbox::untaintUnchecked( $ENV{PATH} );
1460	}
1461	delete @ENV{qw( IFS CDPATH ENV BASH_ENV )};
1462
1463	my $url = $query->url();
1464	if ( $url && $url =~ m{^([^:]://[^/]).*$} ) {
1465	$this->{urlHost} = $1;
1466
1467	# If the urlHost in the url is localhost, this is a lot less
1468	# useful than the default url host. This is because new CGI("")
1469	# assigns this host by default - it's a default setting, used
1470	# when there is nothing better available.
1471	if ( $this->{urlHost} eq 'http://localhost' ) {
1472	$this->{urlHost} = $Foswiki::cfg{DefaultUrlHost};
1473	}
1474	elsif ( $Foswiki::cfg{RemovePortNumber} ) {
1475	$this->{urlHost} =~ s/\:[0-9]+$//;
1476	}
1477	}
1478	else {
1479	$this->{urlHost} = $Foswiki::cfg{DefaultUrlHost};
1480	}
1481	if ( $Foswiki::cfg{GetScriptUrlFromCgi}
1482	&& $url
1483	&& $url =~ m{^[^:]://[^/](.)/.$}
1484	&& $1 )
1485	{
1486
1487	# SMELL: this is a really dangerous hack. It will fail
1488	# spectacularly with mod_perl.
1489	# SMELL: why not just use $query->script_name?
1490	# SMELL: unchecked implicit untaint?
1491	$this->{scriptUrlPath} = $1;
1492	}
1493
1494	my $web = '';
1495	my $topic = $query->param('topic');
1496	if ($topic) {
1497	if ( $topic =~ m#^$regex{linkProtocolPattern}://#o
1498	&& $this->{request} )
1499	{
1500
1501	# redirect to URI
1502	$this->{webName} = '';
1503	$this->redirect($topic);
1504	return $this;
1505	}
1506	elsif ( $topic =~ m#^(.)[./](.?)$# ) {
1507
1508	# is '?topic=Webname.SomeTopic'
1509	# implicit untaint OK - validated later
1510	$web = $1;
1511	$topic = $2;
1512	$web =~ s/\./\//g;
1513
1514	# jump to WebHome if 'bin/script?topic=Webname.'
1515	$topic = $Foswiki::cfg{HomeTopicName} if ( $web && !$topic );
1516	}
1517
1518	# otherwise assume 'bin/script/Webname?topic=SomeTopic'
1519	}
1520	else {
1521	$topic = '';
1522	}
1523
1524	my $pathInfo = $query->path_info();
1525	$pathInfo =~ s\|//+\|/\|g; # multiple //'s are illogical
1526
1527	# Get the web and topic names from PATH_INFO
1528	if ( $pathInfo =~ m#^/(.)[./](.?)$# ) {
1529
1530	# is '/Webname/SomeTopic' or '/Webname'
1531	# implicit untaint OK - validated later
1532	$web = $1 unless $web;
1533	$topic = $2 unless $topic;
1534	$web =~ s/\./\//g;
1535	}
1536	elsif ( $pathInfo =~ m#^/(.*?)$# ) {
1537
1538	# is 'bin/script/Webname' or 'bin/script/'
1539	# implicit untaint OK - validated later
1540	$web = $1 unless $web;
1541	}
1542
1543	my $topicNameTemp = $this->UTF82SiteCharSet($topic);
1544	if ($topicNameTemp) {
1545	$topic = $topicNameTemp;
1546	}
1547
1548	# TWikibug:Item3270 - here's the appropriate place to enforce spec
1549	$topic = ucfirst($topic);
1550
1551	# Validate and untaint topic name from path info
1552	$this->{topicName} = Foswiki::Sandbox::untaint( $topic,
1553	\&Foswiki::Sandbox::validateTopicName );
1554
1555	# Validate web name from path info
1556	$this->{webName} =
1557	Foswiki::Sandbox::untaint( $web, \&Foswiki::Sandbox::validateWebName );
1558
1559	if ( !defined $this->{webName} && !defined $this->{topicName} ) {
1560	$this->{webName} = $Foswiki::cfg{UsersWebName};
1561	$this->{topicName} = $Foswiki::cfg{HomeTopicName};
1562	}
1563
1564	$this->{webName} = ''
1565	unless ( defined $this->{webName} );
1566
1567	$this->{topicName} = $Foswiki::cfg{HomeTopicName}
1568	unless ( defined $this->{topicName} );
1569
1570	# Convert UTF-8 web and topic name from URL into site charset if
1571	# necessary
1572	# SMELL: merge these two cases, browsers just don't mix two encodings
1573	# in one URL - can also simplify into 2 lines by making function
1574	# return unprocessed text if no conversion
1575	my $webNameTemp = $this->UTF82SiteCharSet( $this->{webName} );
1576	if ($webNameTemp) {
1577	$this->{webName} = $webNameTemp;
1578	}
1579
1580	$this->{scriptUrlPath} = $Foswiki::cfg{ScriptUrlPath};
1581
1582	require Foswiki::Prefs;
1583	my $prefs = new Foswiki::Prefs($this);
1584	$this->{prefs} = $prefs;
1585
1586	# Form definition cache
1587	$this->{forms} = {};
1588
1589	# Push global preferences from %SYSTEMWEB%.DefaultPreferences
1590	$prefs->pushGlobalPreferences();
1591
1592	# SMELL: what happens if we move this into the Foswiki::User::new?
1593	$this->{user} = $this->{users}->initialiseUser( $this->{remoteUser} );
1594
1595	# Static session variables that can be expanded in topics when they
1596	# are enclosed in % signs
1597	# SMELL: should collapse these into one. The duplication is pretty
1598	# pointless. Could get rid of the SESSION_TAGS hash, might be
1599	# the easiest thing to do, but then that would allow other
1600	# upper-case named fields in the object to be accessed as well...
1601	$this->{SESSION_TAGS}{BASEWEB} = $this->{webName};
1602	$this->{SESSION_TAGS}{BASETOPIC} = $this->{topicName};
1603	$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $this->{topicName};
1604	$this->{SESSION_TAGS}{INCLUDINGWEB} = $this->{webName};
1605
1606	# Push plugin settings
1607	$this->{plugins}->settings();
1608
1609	# Now the rest of the preferences
1610	$prefs->pushGlobalPreferencesSiteSpecific();
1611
1612	# User preferences only available if we can get to a valid wikiname,
1613	# which depends on the user mapper.
1614	my $wn = $this->{users}->getWikiName( $this->{user} );
1615	if ($wn) {
1616	$prefs->pushPreferences( $Foswiki::cfg{UsersWebName},
1617	$wn, 'USER ' . $wn );
1618	}
1619
1620	$prefs->pushWebPreferences( $this->{webName} );
1621
1622	$prefs->pushPreferences( $this->{webName}, $this->{topicName}, 'TOPIC' );
1623
1624	$prefs->pushPreferenceValues( 'SESSION',
1625	$this->{users}->{loginManager}->getSessionValues() );
1626
1627	# Finish plugin initialization - register handlers
1628	$this->{plugins}->enable();
1629
1630	# SMELL: Every place should localize it before use, so it's not necessary here.
1631	$Foswiki::Plugins::SESSION = $this;
1632
1633	Monitor::MARK("Foswiki session created");
1634
1635	return $this;
1636	}
1637
1638	=begin TML
1639
1640	---++ ObjectMethod renderer()
1641	Get a reference to the renderer object. Done lazily because not everyone
1642	needs the renderer.
1643
1644	=cut
1645
1646	sub renderer {
1647	my ($this) = @_;
1648
1649	unless ( $this->{renderer} ) {
1650	require Foswiki::Render;
1651
1652	# requires preferences (such as LINKTOOLTIPINFO)
1653	$this->{renderer} = new Foswiki::Render($this);
1654	}
1655	return $this->{renderer};
1656	}
1657
1658	=begin TML
1659
1660	---++ ObjectMethod attach()
1661	Get a reference to the attach object. Done lazily because not everyone
1662	needs the attach.
1663
1664	=cut
1665
1666	sub attach {
1667	my ($this) = @_;
1668
1669	unless ( $this->{attach} ) {
1670	require Foswiki::Attach;
1671	$this->{attach} = new Foswiki::Attach($this);
1672	}
1673	return $this->{attach};
1674	}
1675
1676	=begin TML
1677
1678	---++ ObjectMethod templates()
1679	Get a reference to the templates object. Done lazily because not everyone
1680	needs the templates.
1681
1682	=cut
1683
1684	sub templates {
1685	my ($this) = @_;
1686
1687	unless ( $this->{templates} ) {
1688	require Foswiki::Templates;
1689	$this->{templates} = new Foswiki::Templates($this);
1690	}
1691	return $this->{templates};
1692	}
1693
1694	=begin TML
1695
1696	---++ ObjectMethod i18n()
1697	Get a reference to the i18n object. Done lazily because not everyone
1698	needs the i18ner.
1699
1700	=cut
1701
1702	sub i18n {
1703	my ($this) = @_;
1704
1705	unless ( $this->{i18n} ) {
1706	require Foswiki::I18N;
1707
1708	# language information; must be loaded after
1709	# all possible preferences sources are available
1710	$this->{i18n} = new Foswiki::I18N($this);
1711	}
1712	return $this->{i18n};
1713	}
1714
1715	=begin TML
1716
1717	---++ ObjectMethod logger()
1718
1719	=cut
1720
1721	sub logger {
1722	my $this = shift;
1723
1724	unless ( $this->{logger} ) {
1725	eval "require $Foswiki::cfg{Log}{Implementation}";
1726	die $@ if $@;
1727	$this->{logger} = $Foswiki::cfg{Log}{Implementation}->new();
1728	}
1729	return $this->{logger};
1730	}
1731
1732	=begin TML
1733
1734	---++ ObjectMethod search()
1735	Get a reference to the search object. Done lazily because not everyone
1736	needs the searcher.
1737
1738	=cut
1739
1740	sub search {
1741	my ($this) = @_;
1742
1743	unless ( $this->{search} ) {
1744	require Foswiki::Search;
1745	$this->{search} = new Foswiki::Search($this);
1746	}
1747	return $this->{search};
1748	}
1749
1750	=begin TML
1751
1752	---++ ObjectMethod security()
1753	Get a reference to the security object. Done lazily because not everyone
1754	needs the security.
1755
1756	=cut
1757
1758	sub security {
1759	my ($this) = @_;
1760
1761	unless ( $this->{security} ) {
1762	require Foswiki::Access;
1763	$this->{security} = new Foswiki::Access($this);
1764	}
1765	return $this->{security};
1766	}
1767
1768	=begin TML
1769
1770	---++ ObjectMethod net()
1771	Get a reference to the net object. Done lazily because not everyone
1772	needs the net.
1773
1774	=cut
1775
1776	sub net {
1777	my ($this) = @_;
1778
1779	unless ( $this->{net} ) {
1780	require Foswiki::Net;
1781	$this->{net} = new Foswiki::Net($this);
1782	}
1783	return $this->{net};
1784	}
1785
1786	=begin TML
1787
1788	---++ ObjectMethod DESTROY()
1789
1790	called by Perl when the Foswiki object goes out of scope
1791	(maybe should be used kist to ASSERT that finish() was called..
1792
1793	=cut
1794
1795	#sub DESTROY {
1796	# my $this = shift;
1797	# $this->finish();
1798	#}
1799
1800	=begin TML
1801
1802	---++ ObjectMethod finish()
1803	Break circular references.
1804
1805	=cut
1806
1807	# Note to developers; please undef all fields in the object explicitly,
1808	# whether they are references or not. That way this method is "golden
1809	# documentation" of the live fields in the object.
1810	sub finish {
1811	my $this = shift;
1812
1813	$_->finish() foreach values %{ $this->{forms} };
1814	$this->{plugins}->finish() if $this->{plugins};
1815	undef $this->{plugins};
1816	$this->{users}->finish() if $this->{users};
1817	undef $this->{users};
1818	$this->{prefs}->finish() if $this->{prefs};
1819	undef $this->{prefs};
1820	$this->{templates}->finish() if $this->{templates};
1821	undef $this->{templates};
1822	$this->{renderer}->finish() if $this->{renderer};
1823	undef $this->{renderer};
1824	$this->{net}->finish() if $this->{net};
1825	undef $this->{net};
1826	$this->{store}->finish() if $this->{store};
1827	undef $this->{store};
1828	$this->{search}->finish() if $this->{search};
1829	undef $this->{search};
1830	$this->{attach}->finish() if $this->{attach};
1831	undef $this->{attach};
1832	$this->{security}->finish() if $this->{security};
1833	undef $this->{security};
1834	$this->{i18n}->finish() if $this->{i18n};
1835	undef $this->{i18n};
1836	#TODO: the logger doesn't seem to have a finish...
1837	# $this->{logger}->finish() if $this->{logger};
1838	undef $this->{logger};
1839
1840	undef $this->{_HTMLHEADERS};
1841	undef $this->{request};
1842	undef $this->{digester};
1843	undef $this->{urlHost};
1844	undef $this->{web};
1845	undef $this->{topic};
1846	undef $this->{webName};
1847	undef $this->{topicName};
1848	undef $this->{_ICONMAP};
1849	undef $this->{context};
1850	undef $this->{remoteUser};
1851	undef $this->{requestedWebName}; # Web name before renaming
1852	undef $this->{scriptUrlPath};
1853	undef $this->{user};
1854	undef $this->{SESSION_TAGS};
1855	undef $this->{_INCLUDES};
1856	undef $this->{response};
1857	undef $this->{evaluating_if};
1858	undef $this->{_addedToHEAD};
1859	}
1860
1861	=begin TML
1862
1863	---++ ObjectMethod logEvent( $action, $webTopic, $extra, $user )
1864	* =$action= - what happened, e.g. view, save, rename
1865	* =$webTopic= - what it happened to
1866	* =$extra= - extra info, such as minor flag
1867	* =$user= - login name of user - default current user,
1868	or failing that the user agent
1869
1870	Write the log for an event to the logfile
1871
1872	=cut
1873
1874	sub logEvent {
1875	my $this = shift;
1876
1877	my $action = shift \|\| '';
1878	my $webTopic = shift \|\| '';
1879	my $extra = shift \|\| '';
1880	my $user = shift;
1881
1882	$user \|\|= $this->{user};
1883	$user = ( $this->{users}->getLoginName($user) \|\| 'unknown' )
1884	if ( $this->{users} );
1885
1886	$user = '' unless (defined $user); # Avoid undefined string in compare
1887
1888	if ( $user eq $cfg{DefaultUserLogin} ) {
1889	my $cgiQuery = $this->{request};
1890	if ($cgiQuery) {
1891	my $agent = $cgiQuery->user_agent();
1892	if ($agent) {
1893	if ( $agent =~ m/([\w]+)/ ) {
1894	$extra .= ' ' . $1;
1895	}
1896	}
1897	}
1898	}
1899
1900	my $remoteAddr = $this->{request}->remoteAddress() \|\| '';
1901
1902	$this->logger->log( 'info', $user, $action, $webTopic, $extra,
1903	$remoteAddr );
1904	}
1905
1906	# Add a web reference to a [[...][...]] link in an included topic
1907	sub _fixIncludeLink {
1908	my ( $web, $link, $label ) = @_;
1909
1910	# Detect absolute and relative URLs and web-qualified wikinames
1911	if ( $link =~
1912	m#^($regex{webNameRegex}\.\|$regex{defaultWebNameRegex}\.\|$regex{linkProtocolPattern}:\|/)#o
1913	)
1914	{
1915	if ($label) {
1916	return "[[$link][$label]]";
1917	}
1918	else {
1919	return "[[$link]]";
1920	}
1921	}
1922	elsif ( !$label ) {
1923
1924	# Must be wikiword or spaced-out wikiword (or illegal link :-/)
1925	$label = $link;
1926	}
1927
1928	# If link is only an anchor, leave it as is (Foswikitask:Item771)
1929	return "[[$link][$label]]" if $link =~ /^#/;
1930	return "[[$web.$link][$label]]";
1931	}
1932
1933	# Replace web references in a topic. Called from forEachLine, applying to
1934	# each non-verbatim and non-literal line.
1935	sub _fixupIncludedTopic {
1936	my ( $text, $options ) = @_;
1937
1938	my $fromWeb = $options->{web};
1939
1940	unless ( $options->{in_noautolink} ) {
1941
1942	# 'TopicName' to 'Web.TopicName'
1943	$text =~
1944	s#(?:^\|(?<=[\s(]))($regex{wikiWordRegex})(?=\s\|\)\|$)#$fromWeb.$1#go;
1945	}
1946
1947	# Handle explicit [[]] everywhere
1948	# '[[TopicName][...]]' to '[[Web.TopicName][...]]'
1949	$text =~ s/\[\[([^]]+)\](?:\[([^]]+)\])?\]/
1950	_fixIncludeLink( $fromWeb, $1, $2 )/geo;
1951
1952	return $text;
1953	}
1954
1955	=begin TML
1956
1957	---++ StaticMethod validatePattern( $pattern ) -> $pattern
1958
1959	Validate a pattern provided in a parameter to $pattern so that
1960	dangerous chars (interpolation and execution) are disabled.
1961
1962	=cut
1963
1964	sub validatePattern {
1965	my $pattern = shift;
1966
1967	# Escape unescaped $ and @ characters that might interpolate
1968	# an internal variable.
1969	# There is no need to defuse (??{ and (?{ as perl won't allow
1970	# it anyway, unless one uses re 'eval' which we won't do
1971	$pattern =~ s/(^\|[^\\])([\$\@])/$1\\$2/g;
1972	return $pattern;
1973	}
1974
1975	=begin TML
1976
1977	---++ StaticMethod applyPatternToIncludedText( $text, $pattern ) -> $text
1978
1979	Apply a pattern on included text to extract a subset
1980
1981	=cut
1982
1983	sub applyPatternToIncludedText {
1984	my ( $text, $pattern ) = @_;
1985
1986	$pattern = Foswiki::Sandbox::untaint( $pattern, \&validatePattern );
1987
1988	my $ok = 0;
1989	eval {
1990	# The eval acts as a try block in case there is anything evil in
1991	# the pattern.
1992
1993	# The () ensures that $1 is defined if $pattern matches
1994	# but does not capture anything
1995	if ($text =~ m/$pattern()/is) {
1996	$text = $1;
1997	}
1998	else {
1999	# The pattern did not match, so return nothing
2000	$text = '';
2001	}
2002	$ok = 1;
2003	};
2004	$text = '' unless $ok;
2005
2006	return $text;
2007	}
2008
2009	#
2010	# SMELL: this is _not_ a tag handler in the sense of other builtin tags,
2011	# because it requires far more context information (the text of the topic)
2012	# than any handler.
2013	# SMELL: as a tag handler that also semi-renders the topic to extract the
2014	# headings, this handler would be much better as a preRenderingHandler in
2015	# a plugin (where head, script and verbatim sections are already protected)
2016	#
2017	# * $text : ref to the text of the current topic
2018	# * $topic : the topic we are in
2019	# * $web : the web we are in
2020	# * $args : 'Topic' [web='Web'] [depth='N']
2021	# Return value: $tableOfContents
2022	# Handles %<nop>TOC{...}% syntax. Creates a table of contents
2023	# using Foswiki bulleted
2024	# list markup, linked to the section headings of a topic. A section heading is
2025	# entered in one of the following forms:
2026	# * $headingPatternSp : \t++... spaces section heading
2027	# * $headingPatternDa : ---++... dashes section heading
2028	# * $headingPatternHt : <h[1-6]> HTML section heading </h[1-6]>
2029	sub _TOC {
2030	my ( $this, $text, $defaultTopic, $defaultWeb, $args ) = @_;
2031
2032	require Foswiki::Attrs;
2033
2034	my $params = new Foswiki::Attrs($args);
2035
2036	# get the topic name attribute
2037	my $topic = $params->{_DEFAULT} \|\| $defaultTopic;
2038
2039	# get the web name attribute
2040	$defaultWeb =~ s#/#.#g;
2041	my $web = $params->{web} \|\| $defaultWeb;
2042
2043	my $isSameTopic = $web eq $defaultWeb && $topic eq $defaultTopic;
2044
2045	$web =~ s#/#\.#g;
2046	my $webPath = $web;
2047	$webPath =~ s/\./\//g;
2048
2049	# get the depth limit attribute
2050	my $maxDepth =
2051	$params->{depth}
2052	\|\| $this->{prefs}->getPreferencesValue('TOC_MAX_DEPTH')
2053	\|\| 6;
2054	my $minDepth = $this->{prefs}->getPreferencesValue('TOC_MIN_DEPTH') \|\| 1;
2055
2056	# get the title attribute
2057	my $title =
2058	$params->{title}
2059	\|\| $this->{prefs}->getPreferencesValue('TOC_TITLE')
2060	\|\| '';
2061	$title = CGI::span( { class => 'foswikiTocTitle' }, $title ) if ($title);
2062
2063	if ( $web ne $defaultWeb \|\| $topic ne $defaultTopic ) {
2064	unless (
2065	$this->security->checkAccessPermission(
2066	'VIEW', $this->{user}, undef, undef, $topic, $web
2067	)
2068	)
2069	{
2070	return $this->inlineAlert( 'alerts', 'access_denied', $web,
2071	$topic );
2072	}
2073	my $meta;
2074	( $meta, $text ) =
2075	$this->{store}->readTopic( $this->{user}, $web, $topic );
2076	}
2077
2078	my $insidePre = 0;
2079	my $insideVerbatim = 0;
2080	my $highest = 99;
2081	my $result = '';
2082	my $verbatim = {};
2083	$text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim );
2084	$text = $this->renderer->takeOutBlocks( $text, 'pre', $verbatim );
2085
2086	# Find URL parameters
2087	my $query = $this->{request};
2088	my @qparams = ();
2089	foreach my $name ( $query->param ) {
2090	next if ( $name eq 'keywords' );
2091	next if ( $name eq 'topic' );
2092	next if ( $name eq 'text' );
2093	push @qparams, $name => $query->param($name);
2094	}
2095
2096	# clear the set of unique anchornames in order to inhibit the 'relabeling' of
2097	# anchor names if the same topic is processed more than once, cf. explanation
2098	# in handleCommonTags()
2099	$this->renderer->_eraseAnchorNameMemory();
2100
2101	# NB: While we're processing $text line by line here,
2102	# $this->renderer->getRendereredVersion() 'allocates' unique anchor names by
2103	# first replacing '#WikiWord', followed by regex{headerPatternHt} and
2104	# regex{headerPatternDa}. In order to stay in sync and not 'clutter'/slow
2105	# down the renderer code, we have to adhere to this order here as well
2106	my @regexps = (
2107	'^(\#)(' . $regex{wikiWordRegex} . ')',
2108	$regex{headerPatternHt}, $regex{headerPatternDa}
2109	);
2110	my @lines = split( /\r?\n/, $text );
2111	my %anchors = ();
2112	my %headings = ();
2113	my %levels = ();
2114	for my $i ( 0 .. $#regexps ) {
2115	my $lineno = 0;
2116
2117	# SMELL: use forEachLine
2118	foreach my $line (@lines) {
2119	$lineno++;
2120	if ( $line =~ m/$regexps[$i]/ ) {
2121	my ( $level, $heading ) = ( $1, $2 );
2122	my $anchor =
2123	$this->renderer->makeUniqueAnchorName( $web, $topic,
2124	$heading );
2125
2126	if ( $i > 0 ) {
2127
2128	# SMELL: needed only because Render::_makeAnchorHeading uses it
2129	my $compatAnchor =
2130	$this->renderer->makeAnchorName( $anchor, 1 );
2131	$compatAnchor =
2132	$this->renderer->makeUniqueAnchorName( $web, $topic,
2133	$anchor, 1 )
2134	if ( $compatAnchor ne $anchor );
2135
2136	$heading =~ s/\s*$regex{headerPatternNoTOC}.+$//go;
2137	next unless $heading;
2138
2139	$level = length $level if ( $i == 2 );
2140	if ( ( $level >= $minDepth ) && ( $level <= $maxDepth ) ) {
2141	$anchors{$lineno} = $anchor;
2142	$headings{$lineno} = $heading;
2143	$levels{$lineno} = $level;
2144	}
2145	}
2146	}
2147	}
2148	}
2149
2150	# SMELL: this handling of <pre> is archaic.
2151	foreach my $lineno ( sort { $a <=> $b } ( keys %headings ) ) {
2152	my ( $level, $line, $anchor ) =
2153	( $levels{$lineno}, $headings{$lineno}, $anchors{$lineno} );
2154	$highest = $level if ( $level < $highest );
2155	my $tabs = "\t" x $level;
2156
2157	# Remove bold, _italic_ and =fixed= formatting
2158	$line =~
2159	s/(^\|[\s$])\([^\s]+?\|[^\s].?[^\s])\*($\|[\s\,\.\;\:\!\?$])/$1$2$3/g;
2160	$line =~
2161	s/(^\|[\s$])_+([^\s]+?\|[^\s].*?[^\s])_+($\|[\s\,\.\;\:\!\?$])/$1$2$3/g;
2162	$line =~
2163	s/(^\|[\s$])=+([^\s]+?\|[^\s].*?[^\s])=+($\|[\s\,\.\;\:\!\?$])/$1$2$3/g;
2164
2165	# Prevent WikiLinks
2166	$line =~ s/\[\[.?\]\[(.?)\]\]/$1/g; # '[[...][...]]'
2167	$line =~ s/\[\[(.*?)\]\]/$1/ge; # '[[...]]'
2168	$line =~
2169	s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/$1<nop>$3/go
2170	; # 'Web.TopicName'
2171	$line =~ s/([\s\(])($regex{wikiWordRegex})/$1<nop>$2/go; # 'TopicName'
2172	$line =~ s/([\s\(])($regex{abbrevRegex})/$1<nop>$2/go; # 'TLA'
2173	$line =~ s/([\s\-\*\(])([$regex{mixedAlphaNum}]+\:)/$1<nop>$2/go
2174	; # 'Site:page' Interwiki link
2175	# Prevent manual links
2176	$line =~ s/<[\/]?a\b[^>]*>//gi;
2177
2178	# create linked bullet item, using a relative link to anchor
2179	my $target =
2180	$isSameTopic
2181	? _make_params( 0, '#' => $anchor, @qparams )
2182	: $this->getScriptUrl(
2183	0, 'view', $web, $topic,
2184	'#' => $anchor,
2185	@qparams
2186	);
2187	$line = $tabs . '* ' . CGI::a( { href => $target }, $line );
2188	$result .= "\n" . $line;
2189	}
2190
2191	if ($result) {
2192	if ( $highest > 1 ) {
2193
2194	# left shift TOC
2195	$highest--;
2196	$result =~ s/^\t{$highest}//gm;
2197	}
2198
2199	# add a anchor to be able to jump to the toc and add a outer div
2200	return CGI::a( { name => 'foswikiTOC' }, '' )
2201	. CGI::div( { class => 'foswikiToc' }, "$title$result\n" );
2202
2203	}
2204	else {
2205	return '';
2206	}
2207	}
2208
2209	=begin TML
2210
2211	---++ ObjectMethod inlineAlert($template, $def, ... ) -> $string
2212
2213	Format an error for inline inclusion in rendered output. The message string
2214	is obtained from the template 'oops'.$template, and the DEF $def is
2215	selected. The parameters (...) are used to populate %PARAM1%..%PARAMn%
2216
2217	=cut
2218
2219	sub inlineAlert {
2220	my $this = shift;
2221	my $template = shift;
2222	my $def = shift;
2223
2224	my $text =
2225	$this->templates->readTemplate( 'oops' . $template, $this->getSkin() );
2226	if ($text) {
2227	my $blah = $this->templates->expandTemplate($def);
2228	$text =~ s/%INSTANTIATE%/$blah/;
2229
2230	# web and topic can be anything; they are not used
2231	$text =
2232	$this->handleCommonTags( $text, $this->{webName},
2233	$this->{topicName} );
2234	my $n = 1;
2235	while ( defined( my $param = shift ) ) {
2236	$text =~ s/%PARAM$n%/$param/g;
2237	$n++;
2238	}
2239
2240	# Suppress missing params
2241	$text =~ s/%PARAM\d+%//g;
2242
2243	# Suppress missing params
2244	$text =~ s/%PARAM\d+%//g;
2245	}
2246	else {
2247	$text =
2248	CGI::h1('Foswiki Installation Error')
2249	. 'Template "'
2250	. $template
2251	. '" not found.'
2252	. CGI::p()
2253	. 'Check your configuration settings for {TemplateDir} and {TemplatePath}';
2254	}
2255
2256	return $text;
2257	}
2258
2259	=begin TML
2260
2261	---++ StaticMethod parseSections($text) -> ($string,$sectionlistref)
2262
2263	Generic parser for sections within a topic. Sections are delimited
2264	by STARTSECTION and ENDSECTION, which may be nested, overlapped or
2265	otherwise abused. The parser builds an array of sections, which is
2266	ordered by the order of the STARTSECTION within the topic. It also
2267	removes all the SECTION tags from the text, and returns the text
2268	and the array of sections.
2269
2270	Each section is a =Foswiki::Attrs= object, which contains the attributes
2271	{type, name, start, end}
2272	where start and end are character offsets in the
2273	string after all section tags have been removed. All sections
2274	are required to be uniquely named; if a section is unnamed, it
2275	will be given a generated name. Sections may overlap or nest.
2276
2277	See test/unit/Fn_SECTION.pm for detailed testcases that
2278	round out the spec.
2279
2280	=cut
2281
2282	sub parseSections {
2283
2284	#my( $text _ = @_;
2285	my %sections;
2286	my @list = ();
2287
2288	my $seq = 0;
2289	my $ntext = '';
2290	my $offset = 0;
2291	foreach my $bit ( split( /(%(?:START\|END)SECTION(?:{.*?})?%)/, $_[0] ) ) {
2292	if ( $bit =~ /^%STARTSECTION(?:{(.*)})?%$/ ) {
2293	require Foswiki::Attrs;
2294
2295	# SMELL: unchecked implicit untaint?
2296	my $attrs = new Foswiki::Attrs($1);
2297	$attrs->{type} \|\|= 'section';
2298	$attrs->{name} =
2299	$attrs->{_DEFAULT}
2300	\|\| $attrs->{name}
2301	\|\| '_SECTION' . $seq++;
2302	delete $attrs->{_DEFAULT};
2303	my $id = $attrs->{type} . ':' . $attrs->{name};
2304	if ( $sections{$id} ) {
2305
2306	# error, this named section already defined, ignore
2307	next;
2308	}
2309
2310	# close open unnamed sections of the same type
2311	foreach my $s (@list) {
2312	if ( $s->{end} < 0
2313	&& $s->{type} eq $attrs->{type}
2314	&& $s->{name} =~ /^_SECTION\d+$/ )
2315	{
2316	$s->{end} = $offset;
2317	}
2318	}
2319	$attrs->{start} = $offset;
2320	$attrs->{end} = -1; # open section
2321	$sections{$id} = $attrs;
2322	push( @list, $attrs );
2323	}
2324	elsif ( $bit =~ /^%ENDSECTION(?:{(.*)})?%$/ ) {
2325	require Foswiki::Attrs;
2326
2327	# SMELL: unchecked implicit untaint?
2328	my $attrs = new Foswiki::Attrs($1);
2329	$attrs->{type} \|\|= 'section';
2330	$attrs->{name} = $attrs->{_DEFAULT} \|\| $attrs->{name} \|\| '';
2331	delete $attrs->{_DEFAULT};
2332	unless ( $attrs->{name} ) {
2333
2334	# find the last open unnamed section of this type
2335	foreach my $s ( reverse @list ) {
2336	if ( $s->{end} == -1
2337	&& $s->{type} eq $attrs->{type}
2338	&& $s->{name} =~ /^_SECTION\d+$/ )
2339	{
2340	$attrs->{name} = $s->{name};
2341	last;
2342	}
2343	}
2344
2345	# ignore it if no matching START found
2346	next unless $attrs->{name};
2347	}
2348	my $id = $attrs->{type} . ':' . $attrs->{name};
2349	if ( !$sections{$id} \|\| $sections{$id}->{end} >= 0 ) {
2350
2351	# error, no such open section, ignore
2352	next;
2353	}
2354	$sections{$id}->{end} = $offset;
2355	}
2356	else {
2357	$ntext .= $bit;
2358	$offset = length($ntext);
2359	}
2360	}
2361
2362	# close open sections
2363	foreach my $s (@list) {
2364	$s->{end} = $offset if $s->{end} < 0;
2365	}
2366
2367	return ( $ntext, \@list );
2368	}
2369
2370	=begin TML
2371
2372	---++ ObjectMethod expandVariablesOnTopicCreation ( $text, $user, $web, $topic ) -> $text
2373
2374	* =$text= - text to expand
2375	* =$user= - This is the user expanded in e.g. %USERNAME. Optional, defaults to logged-in user.
2376	Expand limited set of variables during topic creation. These are variables
2377	expected in templates that must be statically expanded in new content.
2378	* =$web= - name of web
2379	* =$topic= - name of topic
2380
2381	# SMELL: no plugin handler
2382
2383	=cut
2384
2385	sub expandVariablesOnTopicCreation {
2386	my ( $this, $text, $user, $theWeb, $theTopic ) = @_;
2387
2388	$user \|\|= $this->{user};
2389
2390	# Chop out templateonly sections
2391	my ( $ntext, $sections ) = parseSections($text);
2392	if ( scalar(@$sections) ) {
2393
2394	# Note that if named templateonly sections overlap, the behaviour is undefined.
2395	foreach my $s ( reverse @$sections ) {
2396	if ( $s->{type} eq 'templateonly' ) {
2397	$ntext =
2398	substr( $ntext, 0, $s->{start} )
2399	. substr( $ntext, $s->{end}, length($ntext) );
2400	}
2401	else {
2402
2403	# put back non-templateonly sections
2404	my $start = $s->remove('start');
2405	my $end = $s->remove('end');
2406	$ntext =
2407	substr( $ntext, 0, $start )
2408	. '%STARTSECTION{'
2409	. $s->stringify() . '}%'
2410	. substr( $ntext, $start, $end - $start )
2411	. '%ENDSECTION{'
2412	. $s->stringify() . '}%'
2413	. substr( $ntext, $end, length($ntext) );
2414	}
2415	}
2416	$text = $ntext;
2417	}
2418
2419	# Make sure func works, for registered tag handlers
2420	$Foswiki::Plugins::SESSION = $this;
2421
2422	# Note: it may look dangerous to override the user this way, but
2423	# it's actually quite safe, because only a subset of tags are
2424	# expanded during topic creation. if the set of tags expanded is
2425	# extended, then the impact has to be considered.
2426	my $safe = $this->{user};
2427	$this->{user} = $user;
2428	$text = _processTags( $this, $text, \&_expandTagOnTopicCreation, 16 );
2429
2430	# expand all variables for type="expandvariables" sections
2431	( $ntext, $sections ) = parseSections($text);
2432	if ( scalar(@$sections) ) {
2433	$theWeb \|\|= $this->{session}->{webName};
2434	$theTopic \|\|= $this->{session}->{topicName};
2435	foreach my $s ( reverse @$sections ) {
2436	if ( $s->{type} eq 'expandvariables' ) {
2437	my $etext =
2438	substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
2439	expandAllTags( $this, \$etext, $theTopic, $theWeb );
2440	$ntext =
2441	substr( $ntext, 0, $s->{start} )
2442	. $etext
2443	. substr( $ntext, $s->{end}, length($ntext) );
2444	}
2445	else {
2446
2447	# put back non-expandvariables sections
2448	my $start = $s->remove('start');
2449	my $end = $s->remove('end');
2450	$ntext =
2451	substr( $ntext, 0, $start )
2452	. '%STARTSECTION{'
2453	. $s->stringify() . '}%'
2454	. substr( $ntext, $start, $end - $start )
2455	. '%ENDSECTION{'
2456	. $s->stringify() . '}%'
2457	. substr( $ntext, $end, length($ntext) );
2458	}
2459	}
2460	$text = $ntext;
2461	}
2462
2463	# kill markers used to prevent variable expansion
2464	$text =~ s/%NOP%//g;
2465	$this->{user} = $safe;
2466	return $text;
2467	}
2468
2469	=begin TML
2470
2471	---++ StaticMethod entityEncode( $text, $extras ) -> $encodedText
2472
2473	Escape special characters to HTML numeric entities. This is not a generic
2474	encoding, it is tuned specifically for use in Foswiki.
2475
2476	HTML4.0 spec:
2477	"Certain characters in HTML are reserved for use as markup and must be
2478	escaped to appear literally. The "<" character may be represented with
2479	an <em>entity</em>, <strong class=html>&lt;</strong>. Similarly, ">"
2480	is escaped as <strong class=html>&gt;</strong>, and "&" is escaped
2481	as <strong class=html>&amp;</strong>. If an attribute value contains a
2482	double quotation mark and is delimited by double quotation marks, then the
2483	quote should be escaped as <strong class=html>&quot;</strong>.</p>
2484
2485	Other entities exist for special characters that cannot easily be entered
2486	with some keyboards..."
2487
2488	This method encodes HTML special and any non-printable ascii
2489	characters (except for \n and \r) using numeric entities.
2490
2491	FURTHER this method also encodes characters that are special in Foswiki
2492	meta-language.
2493
2494	$extras is an optional param that may be used to include additional
2495	characters in the set of encoded characters. It should be a string
2496	containing the additional chars.
2497
2498	=cut
2499
2500	sub entityEncode {
2501	my ( $text, $extra ) = @_;
2502	$extra \|\|= '';
2503
2504	# encode all non-printable 7-bit chars (< \x1f),
2505	# except \n (\xa) and \r (\xd)
2506	# encode HTML special characters '>', '<', '&', ''' and '"'.
2507	# encode TML special characters '%', '\|', '[', ']', '@', '_',
2508	# '*', and '='
2509	$text =~
2510	s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\\|$extra])/'&#'.ord($1).';'/ge;
2511	return $text;
2512	}
2513
2514	=begin TML
2515
2516	---++ StaticMethod entityDecode ( $encodedText ) -> $text
2517
2518	Decodes all numeric entities (e.g. &#123;). _Does not_ decode
2519	named entities such as &amp; (use HTML::Entities for that)
2520
2521	=cut
2522
2523	sub entityDecode {
2524	my $text = shift;
2525
2526	$text =~ s/&#(\d+);/chr($1)/ge;
2527	return $text;
2528	}
2529
2530	=begin TML
2531
2532	---++ StaticMethod urlEncodeAttachment ( $text )
2533
2534	For attachments, URL-encode specially to 'freeze' any characters >127 in the
2535	site charset (e.g. ISO-8859-1 or KOI8-R), by doing URL encoding into native
2536	charset ($siteCharset) - used when generating attachment URLs, to enable the
2537	web server to serve attachments, including images, directly.
2538
2539	This encoding is required to handle the cases of:
2540
2541	- browsers that generate UTF-8 URLs automatically from site charset URLs - now quite common
2542	- web servers that directly serve attachments, using the site charset for
2543	filenames, and cannot convert UTF-8 URLs into site charset filenames
2544
2545	The aim is to prevent the browser from converting a site charset URL in the web
2546	page to a UTF-8 URL, which is the default. Hence we 'freeze' the URL into the
2547	site character set through URL encoding.
2548
2549	In two cases, no URL encoding is needed: For EBCDIC mainframes, we assume that
2550	site charset URLs will be translated (outbound and inbound) by the web server to/from an
2551	EBCDIC character set. For sites running in UTF-8, there's no need for Foswiki to
2552	do anything since all URLs and attachment filenames are already in UTF-8.
2553
2554	=cut
2555
2556	sub urlEncodeAttachment {
2557	my ($text) = @_;
2558
2559	my $usingEBCDIC = ( 'A' eq chr(193) ); # Only true on EBCDIC mainframes
2560
2561	if (
2562	(
2563	defined( $Foswiki::cfg{Site}{CharSet} )
2564	and $Foswiki::cfg{Site}{CharSet} =~ /^utf-?8$/i
2565	)
2566	or $usingEBCDIC
2567	)
2568	{
2569
2570	# Just let browser do UTF-8 URL encoding
2571	return $text;
2572	}
2573
2574	# Freeze into site charset through URL encoding
2575	return urlEncode($text);
2576	}
2577
2578	=begin TML
2579
2580	---++ StaticMethod urlEncode( $string ) -> encoded string
2581
2582	Encode by converting characters that are illegal in URLs to
2583	their %NN equivalents. This method is used for encoding
2584	strings that must be embedded _verbatim_ in URLs; it cannot
2585	be applied to URLs themselves, as it escapes reserved
2586	characters such as = and ?.
2587
2588	RFC 1738, Dec. '94:
2589	<verbatim>
2590	...Only alphanumerics [0-9a-zA-Z], the special
2591	characters $-_.+!*'(), and reserved characters used for their
2592	reserved purposes may be used unencoded within a URL.
2593	</verbatim>
2594
2595	Reserved characters are $&+,/:;=?@ - these are _also_ encoded by
2596	this method.
2597
2598	This URL-encoding handles all character encodings including ISO-8859-*,
2599	KOI8-R, EUC-* and UTF-8.
2600
2601	This may not handle EBCDIC properly, as it generates an EBCDIC URL-encoded
2602	URL, but mainframe web servers seem to translate this outbound before it hits browser
2603	- see CGI::Util::escape for another approach.
2604
2605	=cut
2606
2607	sub urlEncode {
2608	my $text = shift;
2609
2610	$text =~ s/([^0-9a-zA-Z-_.:~!*'\/])/'%'.sprintf('%02x',ord($1))/ge;
2611
2612	return $text;
2613	}
2614
2615	=begin TML
2616
2617	---++ StaticMethod urlDecode( $string ) -> decoded string
2618
2619	Reverses the encoding done in urlEncode.
2620
2621	=cut
2622
2623	sub urlDecode {
2624	my $text = shift;
2625
2626	$text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
2627
2628	return $text;
2629	}
2630
2631	=begin TML
2632
2633	---++ StaticMethod isTrue( $value, $default ) -> $boolean
2634
2635	Returns 1 if =$value= is true, and 0 otherwise. "true" means set to
2636	something with a Perl true value, with the special cases that "off",
2637	"false" and "no" (case insensitive) are forced to false. Leading and
2638	trailing spaces in =$value= are ignored.
2639
2640	If the value is undef, then =$default= is returned. If =$default= is
2641	not specified it is taken as 0.
2642
2643	=cut
2644
2645	sub isTrue {
2646	my ( $value, $default ) = @_;
2647
2648	$default \|\|= 0;
2649
2650	return $default unless defined($value);
2651
2652	$value =~ s/^\s(.?)\s*$/$1/gi;
2653	$value =~ s/off//gi;
2654	$value =~ s/no//gi;
2655	$value =~ s/false//gi;
2656	return ($value) ? 1 : 0;
2657	}
2658
2659	=begin TML
2660
2661	---++ StaticMethod spaceOutWikiWord( $word, $sep ) -> $string
2662
2663	Spaces out a wiki word by inserting a string (default: one space) between each word component.
2664	With parameter $sep any string may be used as separator between the word components; if $sep is undefined it defaults to a space.
2665
2666	=cut
2667
2668	sub spaceOutWikiWord {
2669	my ( $word, $sep ) = @_;
2670
2671	# Both could have the value 0 so we cannot use simple = \|\| ''
2672	$word = defined($word) ? $word : '';
2673	$sep = defined($sep) ? $sep : ' ';
2674	$word =~
2675	s/([$regex{lowerAlpha}])([$regex{upperAlpha}$regex{numeric}]+)/$1$sep$2/go;
2676	$word =~ s/([$regex{numeric}])([$regex{upperAlpha}])/$1$sep$2/go;
2677	return $word;
2678	}
2679
2680	=begin TML
2681
2682	---++ ObjectMethod expandAllTags(\$text, $topic, $web, $meta)
2683	Expands variables by replacing the variables with their
2684	values. Some example variables: %<nop>TOPIC%, %<nop>SCRIPTURL%,
2685	%<nop>WIKINAME%, etc.
2686	$web and $incs are passed in for recursive include expansion. They can
2687	safely be undef.
2688	The rules for tag expansion are:
2689	1 Tags are expanded left to right, in the order they are encountered.
2690	1 Tags are recursively expanded as soon as they are encountered -
2691	the algorithm is inherently single-pass
2692	1 A tag is not "encountered" until the matching }% has been seen, by
2693	which time all tags in parameters will have been expanded
2694	1 Tag expansions that create new tags recursively are limited to a
2695	set number of hierarchical levels of expansion
2696
2697	=cut
2698
2699	sub expandAllTags {
2700	my $this = shift;
2701	my $text = shift; # reference
2702	my ( $topic, $web, $meta ) = @_;
2703	$web =~ s#\.#/#go;
2704
2705	# push current context
2706	my $memTopic = $this->{SESSION_TAGS}{TOPIC};
2707	my $memWeb = $this->{SESSION_TAGS}{WEB};
2708
2709	$this->{SESSION_TAGS}{TOPIC} = $topic;
2710	$this->{SESSION_TAGS}{WEB} = $web;
2711
2712	# Escape ' !%VARIABLE%'
2713	$$text =~ s/(?<=\s)!%($regex{tagNameRegex})/%$1/g;
2714
2715	# Make sure func works, for registered tag handlers
2716	$Foswiki::Plugins::SESSION = $this;
2717
2718	# NOTE TO DEBUGGERS
2719	# The depth parameter in the following call controls the maximum number
2720	# of levels of expansion. If it is set to 1 then only tags in the
2721	# topic will be expanded; tags that they in turn generate will be
2722	# left unexpanded. If it is set to 2 then the expansion will stop after
2723	# the first recursive inclusion, and so on. This is incredible useful
2724	# when debugging. The default is set to 16
2725	# to match the original limit on search expansion, though this of
2726	# course applies to _all_ tags and not just search.
2727	$$text =
2728	_processTags( $this, $$text, \&_expandTagOnTopicRendering, 16, @_ );
2729
2730	# restore previous context
2731	$this->{SESSION_TAGS}{TOPIC} = $memTopic;
2732	$this->{SESSION_TAGS}{WEB} = $memWeb;
2733	}
2734
2735	# Process Foswiki %TAGS{}% by parsing the input tokenised into
2736	# % separated sections. The parser is a simple stack-based parse,
2737	# sufficient to ensure nesting of tags is correct, but no more
2738	# than that.
2739	# $depth limits the number of recursive expansion steps that
2740	# can be performed on expanded tags.
2741	sub _processTags {
2742	my $this = shift;
2743	my $text = shift;
2744	my $tagf = shift;
2745	my $tell = 0;
2746
2747	return '' if ( ( !defined($text) )
2748	\|\| ( $text eq '' ) );
2749
2750	#no tags to process
2751	return $text unless ( $text =~ /(%)/ );
2752
2753	my $depth = shift;
2754
2755	unless ($depth) {
2756	my $mess = "Max recursive depth reached: $text";
2757	$this->logger->log( 'warning', $mess );
2758
2759	# prevent recursive expansion that just has been detected
2760	# from happening in the error message
2761	$text =~ s/%(.*?)%/$1/go;
2762	return $text;
2763	}
2764
2765	my $verbatim = {};
2766	$text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim );
2767
2768	# See Item1442
2769	#my $percent = ($TranslationToken x 3).'%'.($TranslationToken x 3);
2770
2771	my @queue = split( /(%)/, $text );
2772	my @stack;
2773	my $stackTop = ''; # the top stack entry. Done this way instead of
2774	# referring to the top of the stack for efficiency. This var
2775	# should be considered to be $stack[$#stack]
2776
2777	while ( scalar(@queue) ) {
2778	my $token = shift(@queue);
2779
2780	#print STDERR ' ' x $tell,"PROCESSING $token \n";
2781
2782	# each % sign either closes an existing stacked context, or
2783	# opens a new context.
2784	if ( $token eq '%' ) {
2785
2786	#print STDERR ' ' x $tell,"CONSIDER $stackTop\n";
2787	# If this is a closing }%, try to rejoin the previous
2788	# tokens until we get to a valid tag construct. This is
2789	# a bit of a hack, but it's hard to think of a better
2790	# way to do this without a full parse that takes % signs
2791	# in tag parameters into account.
2792	if ( $stackTop =~ /}$/s ) {
2793	while ( scalar(@stack)
2794	&& $stackTop !~ /^%($regex{tagNameRegex}){.*}$/so )
2795	{
2796	my $top = $stackTop;
2797
2798	#print STDERR ' ' x $tell,"COLLAPSE $top \n";
2799	$stackTop = pop(@stack) . $top;
2800	}
2801	}
2802
2803	# /s so you can have newlines in parameters
2804	if ( $stackTop =~ m/^%(($regex{tagNameRegex})(?:{(.*)})?)$/so ) {
2805
2806	# SMELL: unchecked implicit untaint?
2807	my ( $expr, $tag, $args ) = ( $1, $2, $3 );
2808
2809	#print STDERR ' ' x $tell,"POP $tag\n";
2810	my $e = &$tagf( $this, $tag, $args, @_ );
2811
2812	if ( defined($e) ) {
2813
2814	#print STDERR ' ' x $tell--,"EXPANDED $tag -> $e\n";
2815	$stackTop = pop(@stack);
2816	unless ( $e =~ /(%)/ ) {
2817
2818	#SMELL: this is a profiler speedup found by Sven on the last day of 4.2.1
2819	#TODO: I don't think this parser should be in this section - re-analysis desired.
2820	#print STDERR "no tags to recurse\n";
2821	$stackTop .= $e;
2822	next;
2823	}
2824
2825	# Recursively expand tags in the expansion of $tag
2826	$stackTop .=
2827	_processTags( $this, $e, $tagf, $depth - 1, @_ );
2828	}
2829	else { # expansion failed
2830	#print STDERR ' ' x $tell++,"EXPAND $tag FAILED\n";
2831	# To handle %NOP
2832	# correctly, we have to handle the %VAR% case differently
2833	# to the %VAR{}% case when a variable expansion fails.
2834	# This is so that recursively define variables e.g.
2835	# %A%B%D% expand correctly, but at the same time we ensure
2836	# that a mismatched }% can't accidentally close a context
2837	# that was left open when a tag expansion failed.
2838	# However Cairo didn't do this, so for compatibility
2839	# we have to accept that %NOP can never be fixed. if it
2840	# could, then we could uncomment the following:
2841
2842	#if( $stackTop =~ /}$/ ) {
2843	# # %VAR{...}% case
2844	# # We need to push the unexpanded expression back
2845	# # onto the stack, but we don't want it to match the
2846	# # tag expression again. So we protect the %'s
2847	# $stackTop = $percent.$expr.$percent;
2848	#} else
2849	{
2850
2851	# %VAR% case.
2852	# In this case we do want to match the tag expression
2853	# again, as an embedded %VAR% may have expanded to
2854	# create a valid outer expression. This is directly
2855	# at odds with the %VAR{...}% case.
2856	push( @stack, $stackTop );
2857	$stackTop = '%'; # open new context
2858	}
2859	}
2860	}
2861	else {
2862	push( @stack, $stackTop );
2863	$stackTop = '%'; # push a new context
2864	#$tell++;
2865	}
2866	}
2867	else {
2868	$stackTop .= $token;
2869	}
2870	}
2871
2872	# Run out of input. Gather up everything in the stack.
2873	while ( scalar(@stack) ) {
2874	my $expr = $stackTop;
2875	$stackTop = pop(@stack);
2876	$stackTop .= $expr;
2877	}
2878
2879	#$stackTop =~ s/$percent/%/go;
2880
2881	$this->renderer->putBackBlocks( \$stackTop, $verbatim, 'verbatim' );
2882
2883	#print STDERR "FINAL $stackTop\n";
2884
2885	return $stackTop;
2886	}
2887
2888	# Handle expansion of a tag during topic rendering
2889	# $tag is the tag name
2890	# $args is the bit in the {} (if there are any)
2891	# $topic and $web should be passed for dynamic tags (not needed for
2892	# session or constant tags
2893	sub _expandTagOnTopicRendering {
2894	my $this = shift;
2895	my $tag = shift;
2896	my $args = shift;
2897
2898	# my( $topic, $web, $meta ) = @_;
2899	require Foswiki::Attrs;
2900
2901	my $e = $this->{prefs}->getPreferencesValue($tag);
2902	unless ( defined($e) ) {
2903	$e = $this->{SESSION_TAGS}{$tag};
2904	if ( !defined($e) && defined( $functionTags{$tag} ) ) {
2905	$e = &{ $functionTags{$tag} }(
2906	$this, new Foswiki::Attrs( $args, $contextFreeSyntax{$tag} ), @_
2907	);
2908	}
2909	}
2910	return $e;
2911	}
2912
2913	# Handle expansion of a tag during new topic creation. When creating a
2914	# new topic from a template we only expand a subset of the available legal
2915	# tags, and we expand %NOP% differently.
2916	sub _expandTagOnTopicCreation {
2917	my $this = shift;
2918
2919	# my( $tag, $args, $topic, $web ) = @_;
2920
2921	# Required for Cairo compatibility. Ignore %NOP{...}%
2922	# %NOP% is not ignored until all variable expansion is complete,
2923	# otherwise them inside-out rule would remove it too early e.g.
2924	# %GM%NOP%TIME -> %GMTIME -> 12:00. So we ignore it here and scrape it
2925	# out later. We have to remove %NOP{...}% because it can foul up
2926	# brace-matching.
2927	return '' if $_[0] eq 'NOP' && defined $_[1];
2928
2929	# Only expand a subset of legal tags. Warning: $this->{user} may be
2930	# overridden during this call, when a new user topic is being created.
2931	# This is what we want to make sure new user templates are populated
2932	# correctly, but you need to think about this if you extend the set of
2933	# tags expanded here.
2934	return undef
2935	unless $_[0] =~
2936	/^(URLPARAM\|DATE\|(SERVER\|GM)TIME\|(USER\|WIKI)NAME\|WIKIUSERNAME\|USERINFO)$/;
2937
2938	return _expandTagOnTopicRendering( $this, @_ );
2939	}
2940
2941	=begin TML
2942
2943	---++ ObjectMethod enterContext( $id, $val )
2944
2945	Add the context id $id into the set of active contexts. The $val
2946	can be anything you like, but should always evaluate to boolean
2947	TRUE.
2948
2949	An example of the use of contexts is in the use of tag
2950	expansion. The commonTagsHandler in plugins is called every
2951	time tags need to be expanded, and the context of that expansion
2952	is signalled by the expanding module using a context id. So the
2953	forms module adds the context id "form" before invoking common
2954	tags expansion.
2955
2956	Contexts are not just useful for tag expansion; they are also
2957	relevant when rendering.
2958
2959	Contexts are intended for use mainly by plugins. Core modules can
2960	use $session->inContext( $id ) to determine if a context is active.
2961
2962	=cut
2963
2964	sub enterContext {
2965	my ( $this, $id, $val ) = @_;
2966	$val \|\|= 1;
2967	$this->{context}->{$id} = $val;
2968	}
2969
2970	=begin TML
2971
2972	---++ ObjectMethod leaveContext( $id )
2973
2974	Remove the context id $id from the set of active contexts.
2975	(see =enterContext= for more information on contexts)
2976
2977	=cut
2978
2979	sub leaveContext {
2980	my ( $this, $id ) = @_;
2981	my $res = $this->{context}->{$id};
2982	delete $this->{context}->{$id};
2983	return $res;
2984	}
2985
2986	=begin TML
2987
2988	---++ ObjectMethod inContext( $id )
2989
2990	Return the value for the given context id
2991	(see =enterContext= for more information on contexts)
2992
2993	=cut
2994
2995	sub inContext {
2996	my ( $this, $id ) = @_;
2997	return $this->{context}->{$id};
2998	}
2999
3000	=begin TML
3001
3002	---++ StaticMethod registerTagHandler( $tag, $fnref )
3003
3004	STATIC Add a tag handler to the function tag handlers.
3005	* =$tag= name of the tag e.g. MYTAG
3006	* =$fnref= Function to execute. Will be passed ($session, \%params, $web, $topic )
3007
3008	=cut
3009
3010	sub registerTagHandler {
3011	my ( $tag, $fnref, $syntax ) = @_;
3012	$functionTags{$tag} = \&$fnref;
3013	if ( $syntax && $syntax eq 'context-free' ) {
3014	$contextFreeSyntax{$tag} = 1;
3015	}
3016	}
3017
3018	=begin TML
3019
3020	---++ ObjectMethod handleCommonTags( $text, $web, $topic, $meta ) -> $text
3021
3022	Processes %<nop>VARIABLE%, and %<nop>TOC% syntax; also includes
3023	'commonTagsHandler' plugin hook.
3024
3025	Returns the text of the topic, after file inclusion, variable substitution,
3026	table-of-contents generation, and any plugin changes from commonTagsHandler.
3027
3028	$meta may be undef when, for example, expanding templates, or one-off strings
3029	at a time when meta isn't available.
3030
3031	=cut
3032
3033	sub handleCommonTags {
3034	my ( $this, $text, $theWeb, $theTopic, $meta ) = @_;
3035
3036	ASSERT($theWeb) if DEBUG;
3037	ASSERT($theTopic) if DEBUG;
3038
3039	return $text unless $text;
3040	my $verbatim = {};
3041
3042	# Plugin Hook (for cache Plugins only)
3043	$this->{plugins}
3044	->dispatch( 'beforeCommonTagsHandler', $text, $theTopic, $theWeb, $meta );
3045
3046	#use a "global var", so included topics can extract and putback
3047	#their verbatim blocks safetly.
3048	$text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim );
3049
3050	my $memW = $this->{SESSION_TAGS}{INCLUDINGWEB};
3051	my $memT = $this->{SESSION_TAGS}{INCLUDINGTOPIC};
3052	$this->{SESSION_TAGS}{INCLUDINGWEB} = $theWeb;
3053	$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $theTopic;
3054
3055	expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
3056
3057	$text = $this->renderer->takeOutBlocks( $text, 'verbatim', $verbatim );
3058
3059	# Plugin Hook
3060	$this->{plugins}
3061	->dispatch( 'commonTagsHandler', $text, $theTopic, $theWeb, 0, $meta );
3062
3063	# process tags again because plugin hook may have added more in
3064	expandAllTags( $this, \$text, $theTopic, $theWeb, $meta );
3065
3066	$this->{SESSION_TAGS}{INCLUDINGWEB} = $memW;
3067	$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $memT;
3068
3069	# 'Special plugin tag' TOC hack, must be done after all other expansions
3070	# are complete, and has to reprocess the entire topic.
3071
3072	# We need to keep track of the 'TOC topics' here in order to ensure that each
3073	# of these topics is only processed once (this is due to the fact that the
3074	# renaming of ambiguous anchors has to work context-less and cannot recognize
3075	# whether a particular heading has been converted before)--alternatively, we
3076	# could just clear the 'anchorname memory' and keep reprocessing topics
3077	# (the latter solution is slower if th same TOC is included multiple times)
3078	# current solution: let _TOC() clear the hash which holds the anchornames
3079	$text =~ s/%TOC(?:{(.*?)})?%/$this->_TOC($text, $theTopic, $theWeb, $1)/ge;
3080
3081	# Codev.FormattedSearchWithConditionalOutput: remove <nop> lines,
3082	# possibly introduced by SEARCHes with conditional CALC. This needs
3083	# to be done after CALC and before table rendering in order to join
3084	# table rows properly
3085	$text =~ s/^<nop>\r?\n//gm;
3086
3087	$this->renderer->putBackBlocks( \$text, $verbatim, 'verbatim' );
3088
3089	# Foswiki Plugin Hook (for cache Plugins only)
3090	$this->{plugins}
3091	->dispatch( 'afterCommonTagsHandler', $text, $theTopic, $theWeb, $meta );
3092
3093	return $text;
3094	}
3095
3096	=begin TML
3097
3098	---++ ObjectMethod ADDTOHEAD( $args )
3099
3100	Add =$html= to the HEAD tag of the page currently being generated.
3101
3102	Note that macros may be used in the HEAD. They will be expanded
3103	according to normal variable expansion rules.
3104
3105	---+++ =%<nop>ADDTOHEAD%=
3106	You can write =%ADDTOHEAD{...}%= in a topic or template. This variable accepts the following parameters:
3107	* =_DEFAULT= optional, id of the head block. Used to generate a comment in the output HTML.
3108	* =text= optional, text to use for the head block. Mutually exclusive with =topic=.
3109	* =topic= optional, full Foswiki path name of a topic that contains the full text to use for the head block. Mutually exclusive with =text=. Example: =topic="%WEB%.MyTopic"=.
3110	* =requires= optional, comma-separated list of id's of other head blocks this one depends on.
3111	=%<nop>ADDTOHEAD%= expands in-place to the empty string, unless there is an error in which case the variable expands to an error string.
3112
3113	Use =%<nop>RENDERHEAD%= to generate the sorted head tags.
3114
3115	=cut
3116
3117	sub ADDTOHEAD {
3118	my ( $this, $args, $topic, $web ) = @_;
3119
3120	my $_DEFAULT = $args->{_DEFAULT};
3121	my $text = $args->{text};
3122	$topic = $args->{topic};
3123	my $requires = $args->{requires};
3124	if ( defined $topic ) {
3125	( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
3126
3127	# prevent deep recursion
3128	$web =~ s/\//\./g;
3129	unless ($this->{_addedToHEAD}{"$web.$topic"}) {
3130	my $dummy = undef;
3131	( $dummy, $text ) =
3132	$this->{store}->readTopic( $this->{user}, $web, $topic );
3133	$this->{_addedToHEAD}{"$web.$topic"} = 1;
3134	}
3135	}
3136	$text = $_DEFAULT unless defined $text;
3137	$text = '' unless defined $text;
3138
3139	$this->addToHEAD( $_DEFAULT, $text, $requires );
3140	return '';
3141	}
3142
3143	sub addToHEAD {
3144	my ( $this, $tag, $header, $requires ) = @_;
3145
3146	# Expand macros in the header
3147	$header =
3148	$this->handleCommonTags( $header, $this->{webName}, $this->{topicName} );
3149
3150	$this->{_SORTEDHEADS} \|\|= {};
3151	$tag \|\|= '';
3152
3153	$requires \|\|= '';
3154	my $debug = '';
3155
3156	# Resolve to references to build DAG
3157	my @requires;
3158	foreach my $req ( split( /,\s*/, $requires ) ) {
3159	unless ( $this->{_SORTEDHEADS}->{$req} ) {
3160	$this->{_SORTEDHEADS}->{$req} = {
3161	tag => $req,
3162	requires => [],
3163	header => '',
3164	};
3165	}
3166	push( @requires, $this->{_SORTEDHEADS}->{$req} );
3167	}
3168	my $record = $this->{_SORTEDHEADS}->{$tag};
3169	unless ($record) {
3170	$record = { tag => $tag };
3171	$this->{_SORTEDHEADS}->{$tag} = $record;
3172	}
3173	$record->{requires} = \@requires;
3174	$record->{header} = $header;
3175
3176	# Temporary, for compatibility until %RENDERHEAD% is embedded
3177	# in the skins
3178	$this->{_HTMLHEADERS}{GENERATED_HEADERS} = _genHeaders($this);
3179	}
3180
3181	sub _visit {
3182	my ( $v, $visited, $list ) = @_;
3183	return if $visited->{$v};
3184	$visited->{$v} = 1;
3185	foreach my $r ( @{ $v->{requires} } ) {
3186	_visit( $r, $visited, $list );
3187	}
3188	push( @$list, $v );
3189	}
3190
3191	sub _genHeaders {
3192	my ($this) = @_;
3193	return '' unless $this->{_SORTEDHEADS};
3194
3195	# Loop through the vertices of the graph, in any order, initiating
3196	# a depth-first search for any vertex that has not already been
3197	# visited by a previous search. The desired topological sorting is
3198	# the reverse postorder of these searches. That is, we can construct
3199	# the ordering as a list of vertices, by adding each vertex to the
3200	# start of the list at the time when the depth-first search is
3201	# processing that vertex and has returned from processing all children
3202	# of that vertex. Since each edge and vertex is visited once, the
3203	# algorithm runs in linear time.
3204	my %visited;
3205	my @total;
3206	foreach my $v ( values %{ $this->{_SORTEDHEADS} } ) {
3207	_visit( $v, \%visited, \@total );
3208	}
3209
3210	return join( "\n", map { "<!-- $_->{tag} --> $_->{header}" } @total );
3211	}
3212
3213	=begin TML
3214
3215	---+++ %<nop}RENDERHEAD%
3216	=%RENDERHEAD%= should be written where you want the sorted head tags to be generated. This will normally be in a template. The variable expands to a sorted list of the head blocks added up to the point the RENDERHEAD variable is expanded. Each expanded head block is preceded by an HTML comment that records the ID of the head block.
3217
3218	Head blocks are sorted to satisfy all their =requires= constraints.
3219	The output order of blocks with no =requires= value is undefined. If cycles
3220	exist in the dependency order, the cycles will be broken but the resulting
3221	order of blocks in the cycle is undefined.
3222
3223	=cut
3224
3225	sub RENDERHEAD {
3226	my $this = shift;
3227	return _genHeaders($this);
3228	}
3229
3230	=begin TML
3231
3232	---++ StaticMethod initialize( $pathInfo, $remoteUser, $topic, $url, $query ) -> ($topicName, $webName, $scriptUrlPath, $userName, $dataDir)
3233
3234	Return value: ( $topicName, $webName, $Foswiki::cfg{ScriptUrlPath}, $userName, $Foswiki::cfg{DataDir} )
3235
3236	Static method to construct a new singleton session instance.
3237	It creates a new Foswiki and sets the Plugins $SESSION variable to
3238	point to it, so that Foswiki::Func methods will work.
3239
3240	This method is DEPRECATED but is maintained for script compatibility.
3241
3242	Note that $theUrl, if specified, must be identical to $query->url()
3243
3244	=cut
3245
3246	sub initialize {
3247	my ( $pathInfo, $theRemoteUser, $topic, $theUrl, $query ) = @_;
3248
3249	if ( !$query ) {
3250	$query = new Foswiki::Request( {} );
3251	}
3252	if ( $query->path_info() ne $pathInfo ) {
3253	$query->path_info( "/$0/" . $pathInfo );
3254	}
3255	if ($topic) {
3256	$query->param( -name => 'topic', -value => '' );
3257	}
3258
3259	# can't do much if $theUrl is specified and it is inconsistent with
3260	# the query. We are trying to get to all parameters passed in the
3261	# query.
3262	if ( $theUrl && $theUrl ne $query->url() ) {
3263	die
3264	'Sorry, this version of Foswiki does not support the url parameter to Foswiki::initialize being different to the url in the query';
3265	}
3266	my $session = new Foswiki( $theRemoteUser, $query );
3267
3268	# Force the new session into the plugins context.
3269	$Foswiki::Plugins::SESSION = $session;
3270
3271	return (
3272	$session->{topicName}, $session->{webName},
3273	$session->{scriptUrlPath}, $session->{userName},
3274	$Foswiki::cfg{DataDir}
3275	);
3276	}
3277
3278	=begin TML
3279
3280	---++ StaticMethod readFile( $filename ) -> $text
3281
3282	Returns the entire contents of the given file, which can be specified in any
3283	format acceptable to the Perl open() function. Fast, but inherently unsafe.
3284
3285	WARNING: Never, ever use this for accessing topics or attachments! Use the
3286	Store API for that. This is for global control files only, and should be
3287	used only if there is absolutely no alternative.
3288
3289	=cut
3290
3291	sub readFile {
3292	my $name = shift;
3293	open( IN_FILE, "<$name" ) \|\| return '';
3294	local $/ = undef;
3295	my $data = <IN_FILE>;
3296	close(IN_FILE);
3297	$data = '' unless ( defined($data) );
3298	return $data;
3299	}
3300
3301	=begin TML
3302
3303	---++ StaticMethod expandStandardEscapes($str) -> $unescapedStr
3304
3305	Expands standard escapes used in parameter values to block evaluation. The following escapes
3306	are handled:
3307
3308	\| Escape: \| Expands To: \|
3309	\| =$n= or =$n()= \| New line. Use =$n()= if followed by alphanumeric character, e.g. write =Foo$n()Bar= instead of =Foo$nBar= \|
3310	\| =$nop= or =$nop()= \| Is a "no operation". \|
3311	\| =$quot= \| Double quote (="=) \|
3312	\| =$percnt= \| Percent sign (=%=) \|
3313	\| =$dollar= \| Dollar sign (=$=) \|
3314
3315	=cut
3316
3317	sub expandStandardEscapes {
3318	my $text = shift;
3319	$text =~ s/\$n/\n/gos; # expand '$n()' to new line
3320	$text =~ s/\$n([^$regex{mixedAlpha}]\|$)/\n$1/gos; # expand '$n' to new line
3321	$text =~ s/\$nop()?//gos; # remove filler, useful for nested search
3322	$text =~ s/\$quot()?/\"/gos; # expand double quote
3323	$text =~ s/\$percnt()?/\%/gos; # expand percent
3324	$text =~ s/\$dollar()?/\$/gos; # expand dollar
3325	$text =~ s/\$lt()?/\</gos; # expand less than
3326	$text =~ s/\$gt()?/\>/gos; # expand greater than
3327	$text =~ s/\$amp()?/\&/gos; # expand ampersand
3328	return $text;
3329	}
3330
3331	# generate an include warning
3332	# SMELL: varying number of parameters idiotic to handle for customized $warn
3333	sub _includeWarning {
3334	my $this = shift;
3335	my $warn = shift;
3336	my $message = shift;
3337
3338	if ( $warn eq 'on' ) {
3339	return $this->inlineAlert( 'alerts', $message, @_ );
3340	}
3341	elsif ( isTrue($warn) ) {
3342
3343	# different inlineAlerts need different argument counts
3344	my $argument = '';
3345	if ( $message eq 'topic_not_found' ) {
3346	my ( $web, $topic ) = @_;
3347	$argument = "$web.$topic";
3348	}
3349	else {
3350	$argument = shift;
3351	}
3352	$warn =~ s/\$topic/$argument/go if $argument;
3353	return $warn;
3354	} # else fail silently
3355	return '';
3356	}
3357
3358	#-------------------------------------------------------------------
3359	# Tag Handlers
3360	#-------------------------------------------------------------------
3361
3362	sub FORMFIELD {
3363	my ( $this, $params, $topic, $web ) = @_;
3364	my $cgiQuery = $this->{request};
3365	$params->{rev} = $cgiQuery->param('rev') if ($cgiQuery);
3366	return $this->renderer->renderFORMFIELD( $params, $topic, $web );
3367	}
3368
3369	sub TMPLP {
3370	my ( $this, $params ) = @_;
3371	return $this->templates->tmplP($params);
3372	}
3373
3374	sub VAR {
3375	my ( $this, $params, $topic, $inweb ) = @_;
3376	my $key = $params->{_DEFAULT};
3377	return '' unless $key;
3378	my $web = $params->{web} \|\| $inweb;
3379
3380	# handle %USERSWEB%-type cases
3381	( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
3382
3383	# always return a value, even when the key isn't defined
3384	return $this->{prefs}->getWebPreferencesValue( $key, $web ) \|\| '';
3385	}
3386
3387	sub PLUGINVERSION {
3388	my ( $this, $params ) = @_;
3389	$this->{plugins}->getPluginVersion( $params->{_DEFAULT} );
3390	}
3391
3392	sub IF {
3393	my ( $this, $params, $topic, $web, $meta ) = @_;
3394
3395	unless ($ifParser) {
3396	require Foswiki::If::Parser;
3397	$ifParser = new Foswiki::If::Parser();
3398	}
3399
3400	my $texpr = $params->{_DEFAULT};
3401	my $expr;
3402	my $result;
3403
3404	# Recursion block.
3405	$this->{evaluating_if} \|\|= {};
3406
3407	# Block after 5 levels.
3408	if ( $this->{evaluating_if}->{$texpr}
3409	&& $this->{evaluating_if}->{$texpr} > 5 )
3410	{
3411	delete $this->{evaluating_if}->{$texpr};
3412	return '';
3413	}
3414	$this->{evaluating_if}->{$texpr}++;
3415
3416	try {
3417	$expr = $ifParser->parse($texpr);
3418	unless ($meta) {
3419	require Foswiki::Meta;
3420	$meta = new Foswiki::Meta( $this, $web, $topic );
3421	}
3422	if ( $expr->evaluate( tom => $meta, data => $meta ) ) {
3423	$params->{then} = '' unless defined $params->{then};
3424	$result = expandStandardEscapes( $params->{then} );
3425	}
3426	else {
3427	$params->{else} = '' unless defined $params->{else};
3428	$result = expandStandardEscapes( $params->{else} );
3429	}
3430	}
3431	catch Foswiki::Infix::Error with {
3432	my $e = shift;
3433	$result =
3434	$this->inlineAlert( 'alerts', 'generic', 'IF{', $params->stringify(),
3435	'}:', $e->{-text} );
3436	}
3437	finally {
3438	delete $this->{evaluating_if}->{$texpr};
3439	};
3440	return $result;
3441	}
3442
3443	# Processes a specific instance %<nop>INCLUDE{...}% syntax.
3444	# Returns the text to be inserted in place of the INCLUDE command.
3445	# $topic and $web should be for the immediate parent topic in the
3446	# include hierarchy. Works for both URLs and absolute server paths.
3447	sub INCLUDE {
3448	my ( $this, $params, $includingTopic, $includingWeb ) = @_;
3449
3450	# remember args for the key before mangling the params
3451	my $args = $params->stringify();
3452
3453	# Remove params, so they don't get expanded in the included page
3454	my %control;
3455	for my $p qw(_DEFAULT pattern rev section raw warn) {
3456	$control{$p} = $params->remove($p);
3457	}
3458
3459	$control{warn} \|\|= $this->{prefs}->getPreferencesValue('INCLUDEWARNING');
3460
3461	# make sure we have something to include. If we don't do this, then
3462	# normalizeWebTopicName will default to WebHome. TWikibug:Item2209.
3463	unless ( $control{_DEFAULT} ) {
3464	return _includeWarning( $this, $control{warn}, 'bad_include_path', '' );
3465	}
3466
3467	# Filter out '..' from path to prevent includes of '../../file'
3468	if ( $Foswiki::cfg{DenyDotDotInclude} && $control{_DEFAULT} =~ /\.\./ ) {
3469	return _includeWarning( $this, $control{warn}, 'bad_include_path',
3470	$control{_DEFAULT} );
3471	}
3472
3473	# no sense in considering an empty string as an unfindable section
3474	delete $control{section}
3475	if ( defined( $control{section} ) && $control{section} eq '' );
3476	$control{raw} \|\|= '';
3477	$control{inWeb} = $includingWeb;
3478	$control{inTopic} = $includingTopic;
3479	if ( $control{_DEFAULT} =~ /^([a-z]+):/ ) {
3480	my $handler = $1;
3481	eval 'use Foswiki::IncludeHandlers::' . $handler;
3482	die $@ if ($@);
3483	unless ($@) {
3484	$handler = 'Foswiki::IncludeHandlers::' . $handler;
3485	return $handler->INCLUDE( $this, \%control, $params );
3486	}
3487	}
3488
3489	# No protocol handler; must be a topic reference
3490
3491	my $text = '';
3492	my $meta = '';
3493	my $includedWeb;
3494	my $includedTopic = $control{_DEFAULT};
3495	$includedTopic =~ s/\.txt$//; # strip optional (undocumented) .txt
3496
3497	( $includedWeb, $includedTopic ) =
3498	$this->normalizeWebTopicName( $includingWeb, $includedTopic );
3499
3500	# See Codev.FailedIncludeWarning for the history.
3501	unless ( $this->{store}->topicExists( $includedWeb, $includedTopic ) ) {
3502	return _includeWarning( $this, $control{warn}, 'topic_not_found',
3503	$includedWeb, $includedTopic );
3504	}
3505
3506	# prevent recursive includes. Note that the inclusion of a topic into
3507	# itself is not blocked; however subsequent attempts to include the
3508	# topic will fail. There is a hard block of 99 on any recursive include.
3509	my $key = $includingWeb . '.' . $includingTopic;
3510	my $count = grep( $key, keys %{ $this->{_INCLUDES} } );
3511	$key .= $args;
3512	if ( $this->{_INCLUDES}->{$key} \|\| $count > 99 ) {
3513	return _includeWarning( $this, $control{warn}, 'already_included',
3514	"$includedWeb.$includedTopic", '' );
3515	}
3516
3517	my %saveTags = %{ $this->{SESSION_TAGS} };
3518	my $prefsMark = $this->{prefs}->mark();
3519
3520	$this->{_INCLUDES}->{$key} = 1;
3521	$this->{SESSION_TAGS}{INCLUDINGWEB} = $includingWeb;
3522	$this->{SESSION_TAGS}{INCLUDINGTOPIC} = $includingTopic;
3523
3524	# copy params into session tags
3525	foreach my $k ( keys %$params ) {
3526	$this->{SESSION_TAGS}{$k} = $params->{$k};
3527	}
3528
3529	( $meta, $text ) =
3530	$this->{store}
3531	->readTopic( undef, $includedWeb, $includedTopic, $control{rev} );
3532
3533	# Simplify leading, and remove trailing, newlines. If we don't remove
3534	# trailing, it becomes impossible to %INCLUDE a topic into a table.
3535	$text =~ s/^[\r\n]+/\n/;
3536	$text =~ s/[\r\n]+$//;
3537
3538	unless (
3539	$this->security->checkAccessPermission(
3540	'VIEW', $this->{user}, $text,
3541	$meta, $includedTopic, $includedWeb
3542	)
3543	)
3544	{
3545	if ( isTrue( $control{warn} ) ) {
3546	return $this->inlineAlert( 'alerts', 'access_denied',
3547	"[[$includedWeb.$includedTopic]]" );
3548	} # else fail silently
3549	return '';
3550	}
3551
3552	# remove everything before and after the default include block unless
3553	# a section is explicitly defined
3554	if ( !$control{section} ) {
3555	$text =~ s/.*?%STARTINCLUDE%//s;
3556	$text =~ s/%STOPINCLUDE%.*//s;
3557	}
3558
3559	# handle sections
3560	my ( $ntext, $sections ) = parseSections($text);
3561
3562	my $interesting = ( defined $control{section} );
3563	if ( $interesting \|\| scalar(@$sections) ) {
3564
3565	# Rebuild the text from the interesting sections
3566	$text = '';
3567	foreach my $s (@$sections) {
3568	if ( $control{section}
3569	&& $s->{type} eq 'section'
3570	&& $s->{name} eq $control{section} )
3571	{
3572	$text .= substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
3573	$interesting = 1;
3574	last;
3575	}
3576	elsif ( $s->{type} eq 'include' && !$control{section} ) {
3577	$text .= substr( $ntext, $s->{start}, $s->{end} - $s->{start} );
3578	$interesting = 1;
3579	}
3580	}
3581	}
3582
3583	if ( $interesting and ( length($text) eq 0 ) ) {
3584	return _includeWarning( $this, $control{warn},
3585	'topic_section_not_found', $includedWeb, $includedTopic,
3586	$control{section} );
3587	}
3588
3589	# If there were no interesting sections, restore the whole text
3590	$text = $ntext unless $interesting;
3591
3592	$text = applyPatternToIncludedText( $text, $control{pattern} )
3593	if ( $control{pattern} );
3594
3595	# Do not show TOC in included topic if TOC_HIDE_IF_INCLUDED
3596	# preference has been set
3597	if ( isTrue( $this->{prefs}->getPreferencesValue('TOC_HIDE_IF_INCLUDED') ) )
3598	{
3599	$text =~ s/%TOC(?:{(.*?)})?%//g;
3600	}
3601
3602	expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
3603
3604	# 4th parameter tells plugin that its called for an included file
3605	$this->{plugins}
3606	->dispatch( 'commonTagsHandler', $text, $includedTopic, $includedWeb, 1,
3607	$meta );
3608
3609	# We have to expand tags again, because a plugin may have inserted additional
3610	# tags.
3611	expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
3612
3613	# If needed, fix all 'TopicNames' to 'Web.TopicNames' to get the
3614	# right context so that links continue to work properly
3615	if ( $includedWeb ne $includingWeb ) {
3616	my $removed = {};
3617
3618	$text = $this->renderer->forEachLine(
3619	$text,
3620	\&_fixupIncludedTopic,
3621	{
3622	web => $includedWeb,
3623	pre => 1,
3624	noautolink => 1
3625	}
3626	);
3627
3628	# handle tags again because of plugin hook
3629	expandAllTags( $this, \$text, $includedTopic, $includedWeb, $meta );
3630	}
3631
3632	# restore the tags
3633	delete $this->{_INCLUDES}->{$key};
3634	%{ $this->{SESSION_TAGS} } = %saveTags;
3635
3636	$this->{prefs}->restore($prefsMark);
3637
3638	return $text;
3639	}
3640
3641	sub HTTP {
3642	my ( $this, $params ) = @_;
3643	my $res;
3644	if ( $params->{_DEFAULT} ) {
3645	$res = $this->{request}->http( $params->{_DEFAULT} );
3646	}
3647	$res = '' unless defined($res);
3648	return $res;
3649	}
3650
3651	sub HTTPS {
3652	my ( $this, $params ) = @_;
3653	my $res;
3654	if ( $params->{_DEFAULT} ) {
3655	$res = $this->{request}->https( $params->{_DEFAULT} );
3656	}
3657	$res = '' unless defined($res);
3658	return $res;
3659	}
3660
3661	#deprecated functionality, now implemented using %ENV%
3662	#move to compatibility plugin in Foswiki 2.0
3663	sub HTTP_HOST_deprecated {
3664	return $_[0]->{request}->header('Host') \|\| '';
3665	}
3666
3667	#deprecated functionality, now implemented using %ENV%
3668	#move to compatibility plugin in Foswiki 2.0
3669	sub REMOTE_ADDR_deprecated {
3670	return $_[0]->{request}->remoteAddress() \|\| '';
3671	}
3672
3673	#deprecated functionality, now implemented using %ENV%
3674	#move to compatibility plugin in Foswiki 2.0
3675	sub REMOTE_PORT_deprecated {
3676
3677	# CGI/1.1 (RFC 3875) doesn't specify REMOTE_PORT,
3678	# but some webservers implement it. However, since
3679	# it's not RFC compliant, Foswiki should not rely on
3680	# it. So we get more portability.
3681	return '';
3682	}
3683
3684	#deprecated functionality, now implemented using %ENV%
3685	#move to compatibility plugin in Foswiki
3686	sub REMOTE_USER_deprecated {
3687	return $_[0]->{request}->remoteUser() \|\| '';
3688	}
3689
3690	# Only does simple search for topicmoved at present, can be expanded when required
3691	# SMELL: this violates encapsulation of Store and Meta, by exporting
3692	# the assumption that meta-data is stored embedded inside topic
3693	# text.
3694	sub METASEARCH {
3695	my ( $this, $params ) = @_;
3696
3697	return $this->{store}->searchMetaData($params);
3698	}
3699
3700	sub DATE {
3701	my $this = shift;
3702	return Foswiki::Time::formatTime(
3703	time(),
3704	$Foswiki::cfg{DefaultDateFormat},
3705	$Foswiki::cfg{DisplayTimeValues}
3706	);
3707	}
3708
3709	sub GMTIME {
3710	my ( $this, $params ) = @_;
3711	return Foswiki::Time::formatTime( time(), $params->{_DEFAULT} \|\| '',
3712	'gmtime' );
3713	}
3714
3715	sub SERVERTIME {
3716	my ( $this, $params ) = @_;
3717	return Foswiki::Time::formatTime( time(), $params->{_DEFAULT} \|\| '',
3718	'servertime' );
3719	}
3720
3721	sub DISPLAYTIME {
3722	my ( $this, $params ) = @_;
3723	return Foswiki::Time::formatTime(
3724	time(),
3725	$params->{_DEFAULT} \|\| '',
3726	$Foswiki::cfg{DisplayTimeValues}
3727	);
3728	}
3729
3730	#\| $web \| web and \|
3731	#\| $topic \| topic to display the name for \|
3732	#\| $formatString \| format string (like in search) \|
3733	sub REVINFO {
3734	my ( $this, $params, $theTopic, $theWeb ) = @_;
3735	my $format = $params->{_DEFAULT} \|\| $params->{format};
3736	my $web = $params->{web} \|\| $theWeb;
3737	my $topic = $params->{topic} \|\| $theTopic;
3738	my $cgiQuery = $this->{request};
3739	my $cgiRev = '';
3740	$cgiRev = $cgiQuery->param('rev') if ($cgiQuery);
3741	my $rev = $params->{rev} \|\| $cgiRev \|\| '';
3742
3743	( $web, $topic ) = $this->normalizeWebTopicName( $web, $topic );
3744	if ( $web ne $theWeb \|\| $topic ne $theTopic ) {
3745	unless (
3746	$this->security->checkAccessPermission(
3747	'VIEW', $this->{user}, undef, undef, $topic, $web
3748	)
3749	)
3750	{
3751	return $this->inlineAlert( 'alerts', 'access_denied', $web,
3752	$topic );
3753	}
3754	}
3755
3756	return $this->renderer->renderRevisionInfo( $web, $topic, undef, $rev,
3757	$format );
3758	}
3759
3760	sub REVTITLE {
3761	my ( $this, $params, $theTopic, $theWeb ) = @_;
3762	my $request = $this->{request};
3763	my $out = '';
3764	if ($request) {
3765	my $rev = $request->param('rev');
3766	$out = '(r' . $rev . ')' if ($rev);
3767	}
3768	return $out;
3769	}
3770
3771	sub REVARG {
3772	my ( $this, $params, $theTopic, $theWeb ) = @_;
3773	my $request = $this->{request};
3774	my $out = '';
3775	if ($request) {
3776	my $rev = $request->param('rev');
3777	$out = '&rev=' . $rev if ($rev);
3778	}
3779	return $out;
3780	}
3781
3782	sub ENCODE {
3783	my ( $this, $params ) = @_;
3784	my $type = $params->{type} \|\| 'url';
3785
3786	# Value 0 can be valid input so we cannot use simple = \|\| ''
3787	my $text = defined( $params->{_DEFAULT} ) ? $params->{_DEFAULT} : '';
3788	return _encode( $type, $text );
3789	}
3790
3791	sub _encode {
3792	my ( $type, $text ) = @_;
3793
3794	if ( $type =~ /^entit(y\|ies)$/i ) {
3795	return entityEncode($text);
3796	}
3797	elsif ( $type =~ /^html$/i ) {
3798	return entityEncode( $text, "\n\r" );
3799	}
3800	elsif ( $type =~ /^quotes?$/i ) {
3801
3802	# escape quotes with backslash (Bugs:Item3383 fix)
3803	$text =~ s/\"/\\"/go;
3804	return $text;
3805	}
3806	elsif ( $type =~ /^url$/i ) {
3807	$text =~ s/\r\n\r/<br \/>/; # Legacy.
3808	return urlEncode($text);
3809	}
3810	elsif ( $type =~ /^(off\|none)$/i ) {
3811
3812	# no encoding
3813	return $text;
3814	}
3815	else { # safe or default
3816	# entity encode ' " < > and %
3817	$text =~ s/([<>%'"])/'&#'.ord($1).';'/ge;
3818	return $text;
3819	}
3820	}
3821
3822	sub ENV {
3823	my ( $this, $params ) = @_;
3824
3825	my $key = $params->{_DEFAULT};
3826	return ''
3827	unless $key
3828	&& defined $Foswiki::cfg{AccessibleENV}
3829	&& $key =~ /$Foswiki::cfg{AccessibleENV}/o;
3830	my $val;
3831	if ( $key =~ /^HTTPS?_(\w+)/ ) {
3832	$val = $this->{request}->header($1);
3833	}
3834	elsif ( $key eq 'REQUEST_METHOD' ) {
3835	$val = $this->{request}->method;
3836	}
3837	elsif ( $key eq 'REMOTE_USER' ) {
3838	$val = $this->{request}->remoteUser;
3839	}
3840	elsif ( $key eq 'REMOTE_ADDR' ) {
3841	$val = $this->{request}->remoteAddress;
3842	}
3843	else {
3844
3845	# TSA SMELL: Foswiki::Request doesn't support
3846	# SERVER_\w+, REMOTE_HOST and REMOTE_IDENT.
3847	# Use %ENV as fallback, but for ones above
3848	# wil probably not behave as expected if
3849	# running with non-CGI engine.
3850	$val = $ENV{$key};
3851	}
3852	return defined $val ? $val : 'not set';
3853	}
3854
3855	sub SEARCH {
3856	my ( $this, $params, $topic, $web ) = @_;
3857
3858	# pass on all attrs, and add some more
3859	#$params->{_callback} = undef;
3860	$params->{inline} = 1;
3861	$params->{baseweb} = $web;
3862	$params->{basetopic} = $topic;
3863	$params->{search} = $params->{_DEFAULT} if defined $params->{_DEFAULT};
3864	$params->{type} =
3865	$this->{prefs}->getPreferencesValue('SEARCHVARDEFAULTTYPE')
3866	unless ( $params->{type} );
3867	my $s;
3868	try {
3869	$s = $this->search->searchWeb(%$params);
3870	}
3871	catch Error::Simple with {
3872	my $message = (DEBUG) ? shift->stringify() : shift->{-text};
3873
3874	# Block recursions kicked off by the text being repeated in the
3875	# error message
3876	$message =~ s/%([A-Z]*[{%])/%<nop>$1/g;
3877	$s = $this->inlineAlert( 'alerts', 'bad_search', $message );
3878	};
3879	return $s;
3880	}
3881
3882	sub WEBLIST {
3883	my ( $this, $params ) = @_;
3884	my $format = $params->{_DEFAULT} \|\| $params->{'format'} \|\| '$name';
3885	$format \|\|= '$name';
3886	my $separator = $params->{separator} \|\| "\n";
3887	$separator =~ s/\$n/\n/;
3888	my $web = $params->{web} \|\| '';
3889	my $webs = $params->{webs} \|\| 'public';
3890	my $selection = $params->{selection} \|\| '';
3891	my $showWeb = $params->{subwebs} \|\| '';
3892	$selection =~ s/\,/ /g;
3893	$selection = " $selection ";
3894	my $marker = $params->{marker} \|\| 'selected="selected"';
3895	$web =~ s#\.#/#go;
3896
3897	my @list = ();
3898	my @webslist = split( /,\s*/, $webs );
3899	foreach my $aweb (@webslist) {
3900	if ( $aweb eq 'public' ) {
3901	push( @list,
3902	$this->{store}->getListOfWebs( 'user,public,allowed', $showWeb )
3903	);
3904	}
3905	elsif ( $aweb eq 'webtemplate' ) {
3906	push( @list,
3907	$this->{store}->getListOfWebs( 'template,allowed', $showWeb ) );
3908	}
3909	else {
3910	push( @list, $aweb ) if ( $this->{store}->webExists($aweb) );
3911	}
3912	}
3913
3914	my @items;
3915	my $indent = CGI::span( { class => 'foswikiWebIndent' }, '' );
3916	foreach my $item (@list) {
3917	my $line = $format;
3918	$line =~ s/\$web\b/$web/g;
3919	$line =~ s/\$name\b/$item/g;
3920	$line =~ s/\$qname/"$item"/g;
3921	my $indenteditem = $item;
3922	$indenteditem =~ s#/$##g;
3923	$indenteditem =~ s#\w+/#$indent#g;
3924	$line =~ s/\$indentedname/$indenteditem/g;
3925	my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
3926	$line =~ s/\$marker/$mark/g;
3927	push( @items, $line );
3928	}
3929	return join( $separator, @items );
3930	}
3931
3932	sub TOPICLIST {
3933	my ( $this, $params ) = @_;
3934	my $format = $params->{_DEFAULT} \|\| $params->{'format'} \|\| '$topic';
3935	my $separator = $params->{separator} \|\| "\n";
3936	$separator =~ s/\$n/\n/;
3937	my $web = $params->{web} \|\| $this->{webName};
3938	my $selection = $params->{selection} \|\| '';
3939	$selection =~ s/\,/ /g;
3940	$selection = " $selection ";
3941	my $marker = $params->{marker} \|\| 'selected="selected"';
3942	$web =~ s#\.#/#go;
3943
3944	return ''
3945	if $web ne $this->{webName}
3946	&& $this->{prefs}->getWebPreferencesValue( 'NOSEARCHALL', $web );
3947
3948	my @items;
3949	foreach my $item ( $this->{store}->getTopicNames($web) ) {
3950	my $line = $format;
3951	$line =~ s/\$web\b/$web/g;
3952	$line =~ s/\$topic\b/$item/g;
3953	$line =~ s/\$name\b/$item/g; # Undocumented, DO NOT REMOVE
3954	$line =~ s/\$qname/"$item"/g; # Undocumented, DO NOT REMOVE
3955	my $mark = ( $selection =~ / \Q$item\E / ) ? $marker : '';
3956	$line =~ s/\$marker/$mark/g;
3957	$line = expandStandardEscapes($line);
3958	push( @items, $line );
3959	}
3960	return join( $separator, @items );
3961	}
3962
3963	sub QUERYSTRING {
3964	my $this = shift;
3965	return $this->{request}->queryString();
3966	}
3967
3968	sub QUERYPARAMS {
3969	my ( $this, $params ) = @_;
3970	return '' unless $this->{request};
3971	my $format =
3972	defined $params->{format}
3973	? $params->{format}
3974	: '$name=$value';
3975	my $separator = defined $params->{separator} ? $params->{separator} : "\n";
3976	my $encoding = $params->{encoding} \|\| 'safe';
3977
3978	my @list;
3979	foreach my $name ( $this->{request}->param() ) {
3980
3981	# Issues multi-valued parameters as separate hiddens
3982	my $value = $this->{request}->param($name);
3983	$value = '' unless defined $value;
3984	$name = _encode( $encoding, $name );
3985	$value = _encode( $encoding, $value );
3986
3987	my $entry = $format;
3988	$entry =~ s/\$name/$name/g;
3989	$entry =~ s/\$value/$value/;
3990	push( @list, $entry );
3991	}
3992	return join( $separator, @list );
3993	}
3994
3995	sub URLPARAM {
3996	my ( $this, $params ) = @_;
3997	my $param = $params->{_DEFAULT} \|\| '';
3998	my $newLine = $params->{newline};
3999	my $encode = $params->{encode} \|\| 'safe';
4000	my $multiple = $params->{multiple};
4001	my $separator = $params->{separator};
4002	$separator = "\n" unless ( defined $separator );
4003
4004	my $value;
4005	if ( $this->{request} ) {
4006	if ( Foswiki::isTrue($multiple) ) {
4007	my @valueArray = $this->{request}->param($param);
4008	if (@valueArray) {
4009
4010	# join multiple values properly
4011	unless ( $multiple =~ m/^on$/i ) {
4012	my $item = '';
4013	@valueArray = map {
4014	$item = $_;
4015	$_ = $multiple;
4016	$_ .= $item unless (s/\$item/$item/go);
4017	$_
4018	} @valueArray;
4019	}
4020	$value = join( $separator, @valueArray );
4021	}
4022	}
4023	else {
4024	$value = $this->{request}->param($param);
4025	}
4026	}
4027	if ( defined $value ) {
4028	$value =~ s/\r?\n/$newLine/go if ( defined $newLine );
4029	if ( $encode =~ /^entit(y\|ies)$/i ) {
4030	$value = entityEncode($value);
4031	}
4032	elsif ( $encode =~ /^quotes?$/i ) {
4033	$value =~
4034	s/\"/\\"/go; # escape quotes with backslash (Bugs:Item3383 fix)
4035	}
4036	elsif ( $encode =~ /^(off\|none)$/i ) {
4037
4038	# no encoding
4039	}
4040	elsif ( $encode =~ /^url$/i ) {
4041	$value =~ s/\r\n\r/<br \/>/; # Legacy
4042	$value = urlEncode($value);
4043	}
4044	else { # safe or default
4045	# entity encode ' " < > and %
4046	$value =~ s/([<>%'"])/'&#'.ord($1).';'/ge;
4047	}
4048	}
4049	unless ( defined $value ) {
4050	$value = $params->{default};
4051	$value = '' unless defined $value;
4052	}
4053
4054	# Block expansion of %URLPARAM in the value to prevent recursion
4055	$value =~ s/%URLPARAM{/%<nop>URLPARAM{/g;
4056	return $value;
4057	}
4058
4059	# This routine was introduced to URL encode Mozilla UTF-8 POST URLs in the
4060	# TWiki Feb2003 release - encoding is no longer needed since UTF-URLs are now
4061	# directly supported, but it is provided for backward compatibility with
4062	# skins that may still be using the deprecated %INTURLENCODE%.
4063	sub INTURLENCODE_deprecated {
4064	my ( $this, $params ) = @_;
4065
4066	# Just strip double quotes, no URL encoding - Mozilla UTF-8 URLs
4067	# directly supported now
4068	return $params->{_DEFAULT} \|\| '';
4069	}
4070
4071	# This routine is deprecated as of DakarRelease,
4072	# and is maintained only for backward compatibility.
4073	# Spacing of WikiWords is now done with %SPACEOUT%
4074	# (and the private routine _SPACEOUT).
4075	# Move to compatibility module in Foswiki 2.0
4076	sub SPACEDTOPIC_deprecated {
4077	my ( $this, $params, $theTopic ) = @_;
4078	my $topic = spaceOutWikiWord($theTopic);
4079	$topic =~ s/ / */g;
4080	return urlEncode($topic);
4081	}
4082
4083	sub SPACEOUT {
4084	my ( $this, $params ) = @_;
4085	my $spaceOutTopic = $params->{_DEFAULT};
4086	my $sep = $params->{'separator'};
4087	$spaceOutTopic = spaceOutWikiWord( $spaceOutTopic, $sep );
4088	return $spaceOutTopic;
4089	}
4090
4091	sub ICON {
4092	my ( $this, $params ) = @_;
4093	my $file = $params->{_DEFAULT} \|\| '';
4094
4095	# Try to map the file name to see if there is a matching filetype image
4096	# If no mapping could be found, use the file name that was passed
4097	my $iconFileName = $this->mapToIconFileName( $file, $file );
4098	return CGI::img(
4099	{
4100	src => $this->getIconUrl( 0, $iconFileName ),
4101	width => 16,
4102	height => 16,
4103	align => 'top',
4104	alt => $iconFileName,
4105	border => 0
4106	}
4107	);
4108	}
4109
4110	sub ICONURL {
4111	my ( $this, $params ) = @_;
4112	my $file = ( $params->{_DEFAULT} \|\| '' );
4113
4114	return $this->getIconUrl( 1, $file );
4115	}
4116
4117	sub ICONURLPATH {
4118	my ( $this, $params ) = @_;
4119	my $file = ( $params->{_DEFAULT} \|\| '' );
4120
4121	return $this->getIconUrl( 0, $file );
4122	}
4123
4124	sub RELATIVETOPICPATH {
4125	my ( $this, $params, $theTopic, $web ) = @_;
4126	my $topic = $params->{_DEFAULT};
4127
4128	return '' unless $topic;
4129
4130	my $theRelativePath;
4131
4132	# if there is no dot in $topic, no web has been specified
4133	if ( index( $topic, '.' ) == -1 ) {
4134
4135	# add local web
4136	$theRelativePath = $web . '/' . $topic;
4137	}
4138	else {
4139	$theRelativePath = $topic; #including dot
4140	}
4141
4142	# replace dot by slash is not necessary; System.MyTopic is a valid url
4143	# add ../ if not already present to make a relative file reference
4144	if ( $theRelativePath !~ m!^../! ) {
4145	$theRelativePath = "../$theRelativePath";
4146	}
4147	return $theRelativePath;
4148	}
4149
4150	sub ATTACHURLPATH {
4151	my ( $this, $params, $topic, $web ) = @_;
4152	return $this->getPubUrl( 0, $web, $topic );
4153	}
4154
4155	sub ATTACHURL {
4156	my ( $this, $params, $topic, $web ) = @_;
4157	return $this->getPubUrl( 1, $web, $topic );
4158	}
4159
4160	sub LANGUAGE {
4161	my $this = shift;
4162	return $this->i18n->language();
4163	}
4164
4165	sub LANGUAGES {
4166	my ( $this, $params ) = @_;
4167	my $format = $params->{format} \|\| " * \$langname";
4168	my $separator = $params->{separator} \|\| "\n";
4169	$separator =~ s/\\n/\n/g;
4170	my $selection = $params->{selection} \|\| '';
4171	$selection =~ s/\,/ /g;
4172	$selection = " $selection ";
4173	my $marker = $params->{marker} \|\| 'selected="selected"';
4174
4175	# $languages is a hash reference:
4176	my $languages = $this->i18n->enabled_languages();
4177
4178	my @tags = sort( keys( %{$languages} ) );
4179
4180	my $result = '';
4181	my $i = 0;
4182	foreach my $lang (@tags) {
4183	my $item = $format;
4184	my $name = ${$languages}{$lang};
4185	$item =~ s/\$langname/$name/g;
4186	$item =~ s/\$langtag/$lang/g;
4187	my $mark = ( $selection =~ / \Q$lang\E / ) ? $marker : '';
4188	$item =~ s/\$marker/$mark/g;
4189	$result .= $separator if $i;
4190	$result .= $item;
4191	$i++;
4192	}
4193
4194	return $result;
4195	}
4196
4197	sub MAKETEXT {
4198	my ( $this, $params ) = @_;
4199
4200	my $str = $params->{_DEFAULT} \|\| $params->{string} \|\| "";
4201	return "" unless $str;
4202
4203	# escape everything:
4204	$str =~ s/\[/~[/g;
4205	$str =~ s/\]/~]/g;
4206
4207	# restore already escaped stuff:
4208	$str =~ s/~~\[/~[/g;
4209	$str =~ s/~~\]/~]/g;
4210
4211	# unescape parameters and calculate highest parameter number:
4212	my $max = 0;
4213	$str =~ s/~\[(\_(\d+))~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
4214	$str =~
4215	s/~\[(\*,\_(\d+),[^,]+(,([^,]+))?)~\]/ $max = $2 if ($2 > $max); "[$1]"/ge;
4216
4217	# get the args to be interpolated.
4218	my $argsStr = $params->{args} \|\| "";
4219
4220	my @args = split( /\s,\s/, $argsStr );
4221
4222	# fill omitted args with zeros
4223	while ( ( scalar @args ) < $max ) {
4224	push( @args, 0 );
4225	}
4226
4227	# do the magic:
4228	my $result = $this->i18n->maketext( $str, @args );
4229
4230	# replace accesskeys:
4231	$result =~
4232	s#(^\|[^&])&([a-zA-Z])#$1<span class='foswikiAccessKey'>$2</span>#g;
4233
4234	# replace escaped amperstands:
4235	$result =~ s/&&/\&/g;
4236
4237	return $result;
4238	}
4239
4240	sub SCRIPTNAME {
4241	return $_[0]->{request}->action;
4242	}
4243
4244	sub SCRIPTURL {
4245	my ( $this, $params, $topic, $web ) = @_;
4246	my $script = $params->{_DEFAULT} \|\| '';
4247
4248	return $this->getScriptUrl( 1, $script );
4249	}
4250
4251	sub SCRIPTURLPATH {
4252	my ( $this, $params, $topic, $web ) = @_;
4253	my $script = $params->{_DEFAULT} \|\| '';
4254
4255	return $this->getScriptUrl( 0, $script );
4256	}
4257
4258	sub PUBURL {
4259	my $this = shift;
4260	return $this->getPubUrl(1);
4261	}
4262
4263	sub PUBURLPATH {
4264	my $this = shift;
4265	return $this->getPubUrl(0);
4266	}
4267
4268	sub ALLVARIABLES {
4269	return shift->{prefs}->stringify();
4270	}
4271
4272	sub META {
4273	my ( $this, $params, $topic, $web ) = @_;
4274
4275	my $meta = $this->inContext('can_render_meta');
4276
4277	return '' unless $meta;
4278
4279	my $option = $params->{_DEFAULT} \|\| '';
4280
4281	if ( $option eq 'form' ) {
4282
4283	# META:FORM and META:FIELD
4284	return $meta->renderFormForDisplay( $this->templates );
4285	}
4286	elsif ( $option eq 'formfield' ) {
4287
4288	# a formfield from within topic text
4289	return $meta->renderFormFieldForDisplay( $params->get('name'), '$value',
4290	$params );
4291	}
4292	elsif ( $option eq 'attachments' ) {
4293
4294	# renders attachment tables
4295	return $this->attach->renderMetaData( $web, $topic, $meta, $params );
4296	}
4297	elsif ( $option eq 'moved' ) {
4298	return $this->renderer->renderMoved( $web, $topic, $meta, $params );
4299	}
4300	elsif ( $option eq 'parent' ) {
4301
4302	# Only parent parameter has the format option and should do std escapes
4303	return expandStandardEscapes(
4304	$this->renderer->renderParent( $web, $topic, $meta, $params ) );
4305	}
4306
4307	# return nothing if invalid parameter
4308	return '';
4309	}
4310
4311	# Remove NOP tag in template topics but show content. Used in template
4312	# _topics_ (not templates, per se, but topics used as templates for new
4313	# topics)
4314	sub NOP {
4315	my ( $this, $params, $topic, $web ) = @_;
4316
4317	return '<nop>' unless $params->{_RAW};
4318
4319	return $params->{_RAW};
4320	}
4321
4322	# Shortcut to %TMPL:P{"sep"}%
4323	sub SEP {
4324	my $this = shift;
4325	return $this->templates->expandTemplate('sep');
4326	}
4327
4328	#deprecated functionality, now implemented using %USERINFO%
4329	#move to compatibility plugin in Foswiki 2.0
4330	sub WIKINAME_deprecated {
4331	my ( $this, $params ) = @_;
4332
4333	$params->{format} = $this->{prefs}->getPreferencesValue('WIKINAME')
4334	\|\| '$wikiname';
4335
4336	return $this->USERINFO($params);
4337	}
4338
4339	#deprecated functionality, now implemented using %USERINFO%
4340	#move to compatibility plugin in Foswiki 2.0
4341	sub USERNAME_deprecated {
4342	my ( $this, $params ) = @_;
4343
4344	$params->{format} = $this->{prefs}->getPreferencesValue('USERNAME')
4345	\|\| '$username';
4346
4347	return $this->USERINFO($params);
4348	}
4349
4350	#deprecated functionality, now implemented using %USERINFO%
4351	#move to compatibility plugin in Foswiki 2.0
4352	sub WIKIUSERNAME_deprecated {
4353	my ( $this, $params ) = @_;
4354
4355	$params->{format} = $this->{prefs}->getPreferencesValue('WIKIUSERNAME')
4356	\|\| '$wikiusername';
4357
4358	return $this->USERINFO($params);
4359	}
4360
4361	sub USERINFO {
4362	my ( $this, $params ) = @_;
4363	my $format = $params->{format} \|\| '$username, $wikiusername, $emails';
4364
4365	my $user = $this->{user};
4366
4367	if ( $params->{_DEFAULT} ) {
4368	$user = $params->{_DEFAULT};
4369	return '' if !$user;
4370
4371	# map wikiname to a login name
4372	$user = $this->{users}->getCanonicalUserID($user);
4373	return '' unless $user;
4374	return ''
4375	if ( $Foswiki::cfg{AntiSpam}{HideUserDetails}
4376	&& !$this->{users}->isAdmin( $this->{user} )
4377	&& $user ne $this->{user} );
4378	}
4379
4380	return '' unless $user;
4381
4382	my $info = $format;
4383
4384	if ( $info =~ /\$username/ ) {
4385	my $username = $this->{users}->getLoginName($user);
4386	$username = 'unknown' unless defined $username;
4387	$info =~ s/\$username/$username/g;
4388	}
4389	if ( $info =~ /\$wikiname/ ) {
4390	my $wikiname = $this->{users}->getWikiName($user);
4391	$wikiname = 'UnknownUser' unless defined $wikiname;
4392	$info =~ s/\$wikiname/$wikiname/g;
4393	}
4394	if ( $info =~ /\$wikiusername/ ) {
4395	my $wikiusername = $this->{users}->webDotWikiName($user);
4396	$wikiusername = "$Foswiki::cfg{UsersWebName}.UnknownUser"
4397	unless defined $wikiusername;
4398	$info =~ s/\$wikiusername/$wikiusername/g;
4399	}
4400	if ( $info =~ /\$emails/ ) {
4401	my $emails = join( ', ', $this->{users}->getEmails($user) );
4402	$info =~ s/\$emails/$emails/g;
4403	}
4404	if ( $info =~ /\$groups/ ) {
4405	my @groupNames;
4406	my $it = $this->{users}->eachMembership($user);
4407	while ( $it->hasNext() ) {
4408	my $group = $it->next();
4409	push( @groupNames, $group );
4410	}
4411	my $groups = join( ', ', @groupNames );
4412	$info =~ s/\$groups/$groups/g;
4413	}
4414	if ( $info =~ /\$cUID/ ) {
4415	my $cUID = $user;
4416	$info =~ s/\$cUID/$cUID/g;
4417	}
4418	if ( $info =~ /\$admin/ ) {
4419	my $admin = $this->{users}->isAdmin($user) ? 'true' : 'false';
4420	$info =~ s/\$admin/$admin/g;
4421	}
4422
4423	return $info;
4424	}
4425
4426	sub GROUPS {
4427	my ( $this, $params ) = @_;
4428
4429	my $groups = $this->{users}->eachGroup();
4430	my @table;
4431	while ( $groups->hasNext() ) {
4432	my $group = $groups->next();
4433
4434	# Nop it to prevent wikiname expansion unless the topic exists.
4435	my $groupLink = "<nop>$group";
4436	$groupLink = '[[' . $Foswiki::cfg{UsersWebName} . ".$group][$group]]"
4437	if (
4438	$this->{store}->topicExists( $Foswiki::cfg{UsersWebName}, $group )
4439	);
4440	my $descr = "\| $groupLink \|";
4441	my $it = $this->{users}->eachGroupMember($group);
4442	my $limit_output = 32;
4443	while ( $it->hasNext() ) {
4444	my $user = $it->next();
4445	$descr .= ' [['
4446	. $this->{users}->webDotWikiName($user) . ']['
4447	. $this->{users}->getWikiName($user) . ']]';
4448	if ( $limit_output == 0 ) {
4449	$descr .= '<div>%MAKETEXT{"user list truncated"}%</div>';
4450	last;
4451	}
4452	$limit_output--;
4453	}
4454	push( @table, "$descr \|" );
4455	}
4456
4457	return '\| Group \| Members \|' . "\n" . join( "\n", sort @table );
4458	}
4459
4460	1;
4461	__DATA__
4462	# Foswiki - The Free and Open Source Wiki, http://foswiki.org/
4463	#
4464	# Copyright (C) 2008 Foswiki Contributors. Foswiki Contributors
4465	# are listed in the AUTHORS file in the root of this distribution.
4466	# NOTE: Please extend that file, not this notice.
4467	#
4468	# Additional copyrights apply to some or all of the code in this
4469	# file as follows:
4470	#
4471	# Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
4472	# and TWiki Contributors. All Rights Reserved. TWiki Contributors
4473	# are listed in the AUTHORS file in the root of this distribution.
4474	# Based on parts of Ward Cunninghams original Wiki and JosWiki.
4475	# Copyright (C) 1998 Markus Peter - SPiN GmbH (warpi@spin.de)
4476	# Some changes by Dave Harris (drh@bhresearch.co.uk) incorporated
4477	#
4478	# This program is free software; you can redistribute it and/or
4479	# modify it under the terms of the GNU General Public License
4480	# as published by the Free Software Foundation; either version 2
4481	# of the License, or (at your option) any later version. For
4482	# more details read LICENSE in the root of this distribution.
4483	#
4484	# This program is distributed in the hope that it will be useful,
4485	# but WITHOUT ANY WARRANTY; without even the implied warranty of
4486	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
4487	#
4488	# As per the GPL, removal of this notice is prohibited.

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: branches/Release01x00/core/lib/Foswiki.pm @ 8969

Download in other formats: