# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
#
# Copyright (C) 2001-2007 Peter Thoeny, peter@thoeny.org
# and TWiki Contributors. All Rights Reserved. TWiki Contributors
# are listed in the AUTHORS file in the root of this distribution.
# NOTE: Please extend that file, not this notice.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version. For
# more details read LICENSE in the root of this distribution.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# As per the GPL, removal of this notice is prohibited.
=pod
---+ package TWiki::Render
This module provides most of the actual HTML rendering code in TWiki.
=cut
package TWiki::Render;
use strict;
use Assert;
# Use -any to force creation of functions for unrecognised tags, like del and ins,
# on earlier releases of CGI.pm (pre 2.79)
use CGI qw( -any );
use TWiki::Plurals ();
use TWiki::Attach ();
use TWiki::Attrs ();
use TWiki::Time ();
# Used to generate unique placeholders for when we lift blocks out of the
# text during rendering.
use vars qw( $placeholderMarker );
$placeholderMarker = 0;
# defaults for trunctation of summary text
my $TMLTRUNC = 162;
my $PLAINTRUNC = 70;
my $MINTRUNC = 16;
# max number of lines in a summary (best to keep it even)
my $SUMMARYLINES = 6;
# limiting lookbehind and lookahead for wikiwords and emphasis
# use like \b
#SMELL: they really limit the number of places emphasis can happen.
my $STARTWW = qr/^|(?<=[\s\(])/m;
my $ENDWW = qr/$|(?=[\s,.;:!?)])/m;
BEGIN {
# Do a dynamic 'use locale' for this module
if( $TWiki::cfg{UseLocale} ) {
require locale;
import locale();
}
}
=pod
---++ ClassMethod new ($session)
Creates a new renderer with initial state from preference values
(NEWTOPICBGCOLOR, NEWTOPICFONTCOLOR NEWTOPICLINKSYMBOL
LINKTOOLTIPINFO)
=cut
sub new {
my ( $class, $session ) = @_;
my $this = bless( {}, $class );
ASSERT($session->isa( 'TWiki')) if DEBUG;
$this->{session} = $session;
$this->{NEWTOPICBGCOLOR} =
$session->{prefs}->getPreferencesValue('NEWTOPICBGCOLOR')
|| '#FFFFCE';
$this->{NEWTOPICFONTCOLOR} =
$session->{prefs}->getPreferencesValue('NEWTOPICFONTCOLOR')
|| '#0000FF';
$this->{NEWLINKSYMBOL} =
$session->{prefs}->getPreferencesValue('NEWTOPICLINKSYMBOL')
|| CGI::sup('?');
$this->{NEWLINKFORMAT} =
$session->{prefs}->getPreferencesValue('NEWLINKFORMAT')
|| '$text'.
'$linksymbol';
# tooltip init
$this->{LINKTOOLTIPINFO} =
$session->{prefs}->getPreferencesValue('LINKTOOLTIPINFO')
|| '';
$this->{LINKTOOLTIPINFO} = '$username - $date - r$rev: $summary'
if( TWiki::isTrue( $this->{LINKTOOLTIPINFO} ));
return $this;
}
=pod
---++ ObjectMethod renderParent($web, $topic, $meta, $params) -> $text
Render parent meta-data
=cut
sub renderParent {
my( $this, $web, $topic, $meta, $ah ) = @_;
my $dontRecurse = $ah->{dontrecurse} || 0;
my $noWebHome = $ah->{nowebhome} || 0;
my $prefix = $ah->{prefix} || '';
my $suffix = $ah->{suffix} || '';
my $usesep = $ah->{separator} || ' > ';
my $format = $ah->{format} || '[[$web.$topic][$topic]]';
return '' unless $web && $topic;
my %visited;
$visited{$web.'.'.$topic} = 1;
my $pWeb = $web;
my $pTopic;
my $text = '';
my $parentMeta = $meta->get( 'TOPICPARENT' );
my $parent;
my $store = $this->{session}->{store};
$parent = $parentMeta->{name} if $parentMeta;
my @stack;
while( $parent ) {
( $pWeb, $pTopic ) =
$this->{session}->normalizeWebTopicName( $pWeb, $parent );
$parent = $pWeb.'.'.$pTopic;
last if( $noWebHome &&
( $pTopic eq $TWiki::cfg{HomeTopicName} ) ||
$visited{$parent} );
$visited{$parent} = 1;
$text = $format;
$text =~ s/\$web/$pWeb/g;
$text =~ s/\$topic/$pTopic/g;
unshift( @stack, $text );
last if $dontRecurse;
$parent = $store->getTopicParent( $pWeb, $pTopic );
}
$text = join( $usesep, @stack );
if( $text) {
$text = $prefix.$text if ( $prefix );
$text .= $suffix if ( $suffix );
}
return $text;
}
=pod
---++ ObjectMethod renderMoved($web, $topic, $meta, $params) -> $text
Render moved meta-data
=cut
sub renderMoved {
my( $this, $web, $topic, $meta, $params ) = @_;
my $text = '';
my $moved = $meta->get( 'TOPICMOVED' );
$web =~ s#\.#/#go;
if( $moved ) {
my( $fromWeb, $fromTopic ) =
$this->{session}->normalizeWebTopicName( $web, $moved->{from} );
my( $toWeb, $toTopic ) =
$this->{session}->normalizeWebTopicName( $web, $moved->{to} );
my $by = $moved->{by};
my $u = $this->{session}->{users}->findUser( $by );
$by = $u->webDotWikiName() if $u;
my $date = TWiki::Time::formatTime( $moved->{date}, '', 'gmtime' );
# Only allow put back if current web and topic match stored information
my $putBack = '';
if( $web eq $toWeb && $topic eq $toTopic ) {
$putBack = ' - '.
CGI::a( { title=>($this->{session}->{i18n}->maketext(
'Click to move topic back to previous location, with option to change references.')
),
href => $this->{session}->getScriptUrl
( 0, 'rename', $web, $topic,
newweb => $fromWeb,
newtopic => $fromTopic,
confirm => 'on',
nonwikiword => 'checked' ),
rel => 'nofollow'
},
$this->{session}->{i18n}->maketext('put it back') );
}
$text = CGI::i(
$this->{session}->{i18n}->maketext("[_1] moved from [_2] on [_3] by [_4]",
"$toWeb.$toTopic",
"$fromWeb.$fromTopic",
$date,
$by)) . $putBack;
}
return $text;
}
=pod
---++ ObjectMethod renderFormField($web, $topic, $meta, $params) -> $text
Render meta-data for a single formfield
=cut
sub renderFormField {
my( $this, $meta, $attrs ) = @_;
my $text = '';
my $name = $attrs->{name};
$text = renderFormFieldArg( $meta, $name ) if( $name );
my $newline = $attrs->{newline};
if ( defined $newline ) {
$newline =~ s/\$n/\n/gos;
} else {
$newline = "
";
}
my $bar = $attrs->{bar} || "|";
# change any new line character sequences to
$text =~ s/\r?\n/$newline/gos;
# escape "|" to HTML entity
$text =~ s/\|/$bar/gos;
return $text;
}
# Add a list item, of the given type and indent depth. The list item may
# cause the opening or closing of lists currently being handled.
sub _addListItem {
my( $this, $result, $theType, $theElement, $theIndent, $theOlType ) = @_;
$theIndent =~ s/ /\t/g;
my $depth = length( $theIndent );
my $size = scalar( @{$this->{LIST}} );
# The whitespaces either side of the tags are required for the
# emphasis REs to work.
if( $size < $depth ) {
my $firstTime = 1;
while( $size < $depth ) {
push( @{$this->{LIST}}, { type=>$theType, element=>$theElement } );
$$result .= ' <'.$theElement.">\n" unless( $firstTime );
$$result .= ' <'.$theType.">\n";
$firstTime = 0;
$size++;
}
} else {
while( $size > $depth ) {
my $tags = pop( @{$this->{LIST}} );
$$result .= "\n".$tags->{element}.'>'.$tags->{type}.'> ';
$size--;
}
if( $size ) {
$$result .= "\n".$this->{LIST}->[$size-1]->{element}.'> ';
} else {
$$result .= "\n" if $$result;
}
}
if ( $size ) {
my $oldt = $this->{LIST}->[$size-1];
if( $oldt->{type} ne $theType ) {
$$result .= ' '.$oldt->{type}.'><'.$theType.">\n";
pop( @{$this->{LIST}} );
push( @{$this->{LIST}}, { type=>$theType, element=>$theElement } );
}
}
}
sub _emitTR {
my ( $this, $thePre, $theRow, $insideTABLE ) = @_;
unless( $insideTABLE ) {
$thePre .=
CGI::start_table({ class=>'twikiTable',
border => 1,
cellspacing => 0,
cellpadding => 0 });
}
$theRow =~ s/\t/ /g; # change tabs to space
$theRow =~ s/\s*$//; # remove trailing spaces
$theRow =~ s/(\|\|+)/$TWiki::TranslationToken.length($1).'|'/ge; # calc COLSPAN
my $cells = '';
foreach( split( /\|/, $theRow ) ) {
my @attr;
# Avoid matching single columns
if ( s/$TWiki::TranslationToken([0-9]+)//o ) {
push( @attr, colspan => $1 );
}
s/^\s+$/ /;
my( $l1, $l2 ) = ( 0, 0 );
if( /^(\s*).*?(\s*)$/ ) {
$l1 = length( $1 );
$l2 = length( $2 );
}
if( $l1 >= 2 ) {
if( $l2 <= 1 ) {
push( @attr, align => 'right' );
} else {
push( @attr, align => 'center' );
}
}
if( /^\s*\*(.*)\*\s*$/ ) {
push( @attr, bgcolor => '#99CCCC' );
$cells .= CGI::th( { @attr }, CGI::strong( " $1 " ))."\n";
} else {
$cells .= CGI::td( { @attr }, " $_ " )."\n";
}
}
return $thePre.CGI::Tr( $cells );
}
sub _fixedFontText {
my( $theText, $theDoBold ) = @_;
# preserve white space, so replace it by ' ' patterns
$theText =~ s/\t/ /g;
$theText =~ s|((?:[\s]{2})+)([^\s])|' ' x (length($1) / 2) . $2|eg;
$theText = CGI::b( $theText ) if $theDoBold;
return CGI::code( $theText );
}
# Build an HTML <Hn> element with suitable anchor for linking from %TOC%
sub _makeAnchorHeading {
my( $this, $text, $theLevel ) = @_;
$text =~ s/^\s*(.*?)\s*$/$1/;
# - Build ' heading
' markup
# - Initial '' is needed to prevent subsequent matches.
# - filter out $TWiki::regex{headerPatternNoTOC} ( '!!' and '%NOTOC%' )
my $anchorName = $this->makeAnchorName( $text, 0 );
my $compatAnchorName = $this->makeAnchorName( $text, 1 );
# filter '!!', '%NOTOC%'
$text =~ s/$TWiki::regex{headerPatternNoTOC}//o;
my $html = '';
$html .= CGI::a( { name=>$anchorName }, '' );
$html .= CGI::a( { name=>$compatAnchorName }, '')
if( $compatAnchorName ne $anchorName );
$html .= ' '.$text.' ';
return $html;
}
=pod
---++ ObjectMethod makeAnchorName($anchorName, $compatibilityMode) -> $anchorName
* =$anchorName= -
* =$compatibilityMode= -
Build a valid HTML anchor name
=cut
sub makeAnchorName {
my( $this, $anchorName, $compatibilityMode ) = @_;
ASSERT($this->isa( 'TWiki::Render')) if DEBUG;
if( !$compatibilityMode &&
$anchorName =~ /^$TWiki::regex{anchorRegex}$/ ) {
# accept, already valid -- just remove leading #
return substr($anchorName, 1);
}
# strip out potential links so they don't get rendered.
# remove double bracket link
$anchorName =~ s/\s*\[\s*\[.*?\]\s*\[(.*?)\]\s*\]/$1/go;
$anchorName =~ s/\s*\[\s*\[\s*(.*?)\s*\]\s*\]/$1/go;
# add an _ before bare WikiWords
$anchorName =~ s/($TWiki::regex{wikiWordRegex})/_$1/go;
if( $compatibilityMode ) {
# remove leading/trailing underscores first, allowing them to be
# reintroduced
$anchorName =~ s/^[\s\#\_]*//;
$anchorName =~ s/[\s\_]*$//;
}
$anchorName =~ s/<[\/]?\w[^>]*>//gi; # remove HTML tags
$anchorName =~ s/\&\#?[a-zA-Z0-9]*;//g; # remove HTML entities
$anchorName =~ s/\&//g; # remove &
# filter TOC excludes if not at beginning
$anchorName =~ s/^(.+?)\s*$TWiki::regex{headerPatternNoTOC}.*/$1/o;
# filter '!!', '%NOTOC%'
$anchorName =~ s/$TWiki::regex{headerPatternNoTOC}//o;
# For most common alphabetic-only character encodings (i.e. iso-8859-*),
# remove non-alpha characters
if( defined($TWiki::cfg{Site}{CharSet}) &&
$TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?/i ) {
$anchorName =~ s/[^$TWiki::regex{mixedAlphaNum}]+/_/g;
}
$anchorName =~ s/__+/_/g; # remove excessive '_' chars
if ( !$compatibilityMode ) {
$anchorName =~ s/^[\s\#\_]*//; # no leading space nor '#', '_'
}
$anchorName =~ s/^(.{32})(.*)$/$1/; # limit to 32 chars - FIXME: Use Unicode chars before truncate
if ( !$compatibilityMode ) {
$anchorName =~ s/[\s\_]*$//; # no trailing space, nor '_'
}
# No need to encode 8-bit characters in anchor due to UTF-8 URL support
return $anchorName;
}
# Returns =title='...'= tooltip info in case LINKTOOLTIPINFO perferences variable is set.
# Warning: Slower performance if enabled.
sub _linkToolTipInfo {
my( $this, $theWeb, $theTopic ) = @_;
return '' unless( $this->{LINKTOOLTIPINFO} );
return '' if( $this->{LINKTOOLTIPINFO} =~ /^off$/i );
return '' unless( $this->{session}->inContext( 'view' ));
# FIXME: This is slow, it can be improved by caching topic rev info and summary
my $store = $this->{session}->{store};
# SMELL: we ought not to have to fake this. Topic object model, please!!
my $meta = new TWiki::Meta( $this->{session}, $theWeb, $theTopic );
my( $date, $user, $rev ) = $meta->getRevisionInfo();
my $text = $this->{LINKTOOLTIPINFO};
$text =~ s/\$web/$theWeb/g;
$text =~ s/\$topic/$theTopic/g;
$text =~ s/\$rev/1.$rev/g;
$text =~ s/\$date/TWiki::Time::formatTime( $date )/ge;
$text =~ s/\$username/$user->login()/ge; # 'jsmith'
$text =~ s/\$wikiname/$user->wikiName()/ge; # 'JohnSmith'
$text =~ s/\$wikiusername/$user->webDotWikiName()/ge; # 'Main.JohnSmith'
if( $text =~ /\$summary/ ) {
my $summary = $store->readTopicRaw
( undef, $theWeb, $theTopic, undef );
$summary = $this->makeTopicSummary( $summary, $theTopic, $theWeb );
$summary =~ s/[\"\']//g; # remove quotes (not allowed in title attribute)
$text =~ s/\$summary/$summary/g;
}
return $text;
}
=pod
---++ ObjectMethod internalLink ( $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb ) -> $html
Generate a link.
Note: Topic names may be spaced out. Spaced out names are converted to WikWords,
for example, "spaced topic name" points to "SpacedTopicName".
* =$theWeb= - the web containing the topic
* =$theTopic= - the topic to be lunk
* =$theLinkText= - text to use for the link
* =$theAnchor= - the link anchor, if any
* =$doLinkToMissingPages= - boolean: false means suppress link for non-existing pages
* =$doKeepWeb= - boolean: true to keep web prefix (for non existing Web.TOPIC)
Called by _handleWikiWord and _handleSquareBracketedLink and by Func::internalLink
Calls _renderWikiWord, which in turn will use Plurals.pm to match fold plurals to equivalency with their singular form
SMELL: why is this available to Func?
=cut
sub internalLink {
my( $this, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLinkToMissingPages, $doKeepWeb ) = @_;
ASSERT($this->isa( 'TWiki::Render')) if DEBUG;
# SMELL - shouldn't it be callable by TWiki::Func as well?
#PN: Webname/Subweb/ -> Webname/Subweb
$theWeb =~ s/\/\Z//o;
if($theLinkText eq $theWeb) {
$theLinkText =~ s/\//\./go;
}
#WebHome links to tother webs render as the WebName
if (($theLinkText eq $TWiki::cfg{HomeTopicName}) &&
($theWeb ne $this->{session}->{webName})) {
$theLinkText = $theWeb;
}
# Get rid of leading/trailing spaces in topic name
$theTopic =~ s/^\s*//o;
$theTopic =~ s/\s*$//o;
# Turn spaced-out names into WikiWords - upper case first letter of
# whole link, and first of each word. TODO: Try to turn this off,
# avoiding spaces being stripped elsewhere
$theTopic =~ s/^(.)/\U$1/;
$theTopic =~ s/\s([$TWiki::regex{mixedAlphaNum}])/\U$1/go;
# Add before WikiWord inside link text to prevent double links
$theLinkText =~ s/(?<=[\s\(])([$TWiki::regex{upperAlpha}])/$1/go;
return _renderWikiWord($this, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLinkToMissingPages, $doKeepWeb);
}
# TODO: this should be overridable by plugins.
sub _renderWikiWord {
my ($this, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLinkToMissingPages, $doKeepWeb) = @_;
# added by RSP to resolve links to user WikiNames
my $username = $this->{session}->{users}->{usermappingmanager}->lookupLoginName($theTopic);
if ($username) {
return _renderUserWikiName($this, $theWeb,
$theTopic, $theLinkText, $theAnchor);
}
my $store = $this->{session}->{store};
my $topicExists = $store->topicExists( $theWeb, $theTopic );
my $singular = '';
unless( $topicExists ) {
# topic not found - try to singularise
$singular = TWiki::Plurals::singularForm($theWeb, $theTopic);
if( $singular ) {
$topicExists = $store->topicExists( $theWeb, $singular );
$theTopic = $singular if $topicExists;
}
}
if( $topicExists) {
return _renderExistingWikiWord($this, $theWeb,
$theTopic, $theLinkText, $theAnchor);
}
if( $doLinkToMissingPages ) {
# CDot: disabled until SuggestSingularNotPlural is resolved
# if ($singular && $singular ne $theTopic) {
# #unshift( @topics, $singular);
# }
return _renderNonExistingWikiWord($this, $theWeb, $theTopic,
$theLinkText);
}
if( $doKeepWeb ) {
return $theWeb.'.'.$theLinkText;
}
return $theLinkText;
}
#
# added by RSP to resolve links to user WikiNames
#
sub _renderUserWikiName {
my ($this, $web, $topic, $text, $anchor) = @_;
my $currentWebHome = '';
$currentWebHome = 'twikiCurrentWebHomeLink '
if (($web eq $this->{session}->{webName}) &&
($topic eq $TWiki::cfg{HomeTopicName} ));
my $currentTopic = '';
$currentTopic = 'twikiCurrentTopicLink '
if (($web eq $this->{session}->{webName}) &&
($topic eq $this->{session}->{topicName}));
my @attrs;
my $href = $TWiki::cfg{TdwgUserPageUrl}."$topic";
my $tooltip = $this->_linkToolTipInfo( $web, $topic );
push( @attrs, class => $currentTopic.$currentWebHome.'twikiAnchorLink', href => $href.'#'.$anchor );
push( @attrs, title => $tooltip ) if( $tooltip );
my $link = CGI::a( { @attrs }, $text );
return $link;
}
sub _renderExistingWikiWord {
my ($this, $web, $topic, $text, $anchor) = @_;
my $currentWebHome = '';
$currentWebHome = 'twikiCurrentWebHomeLink ' if (($web eq $this->{session}->{webName}) &&
($topic eq $TWiki::cfg{HomeTopicName} ));
my $currentTopic = '';
$currentTopic = 'twikiCurrentTopicLink ' if (($web eq $this->{session}->{webName}) &&
($topic eq $this->{session}->{topicName}));
my @attrs;
my $href = $this->{session}->getScriptUrl( 0, 'view', $web, $topic );
if( $anchor ) {
$anchor = $this->makeAnchorName( $anchor );
push( @attrs, class => $currentTopic.$currentWebHome.'twikiAnchorLink', href => $href.'#'.$anchor );
} else {
push( @attrs, class => $currentTopic.$currentWebHome.'twikiLink', href => $href );
}
my $tooltip = $this->_linkToolTipInfo( $web, $topic );
push( @attrs, title => $tooltip ) if( $tooltip );
my $link = CGI::a( { @attrs }, $text );
# When we pass the tooltip text to CGI::a it may contain
# s, and CGI::a will convert the < to <. This is a
# basic problem with .
$link =~ s/<nop>//g;
return $link;
}
sub _renderNonExistingWikiWord {
my ($this, $theWeb, $theTopic, $theLinkText) = @_;
my $ans = $this->{NEWLINKFORMAT};
$ans =~ s/\$web/$theWeb/g;
$ans =~ s/\$topic/$theTopic/g;
$ans =~ s/\$text/$theLinkText/g;
$ans =~ s/\$linksymbol/$this->{NEWLINKSYMBOL}/g;
$ans = $this->{session}->handleCommonTags($ans,
$this->{session}{webName}, $this->{session}{topicName});
return $ans;
}
# _handleWikiWord is called by the TWiki Render routine when it sees a
# wiki word that needs linking.
# Handle the various link constructions. e.g.:
# WikiWord
# Web.WikiWord
# Web.WikiWord#anchor
#
# This routine adds missing parameters before passing off to internallink
sub _handleWikiWord {
my ( $this, $theWeb, $web, $topic, $anchor ) = @_;
my $linkIfAbsent = 1;
my $keepWeb = 0;
my $text;
$web = $theWeb unless (defined($web));
if( defined( $anchor )) {
ASSERT(($anchor =~ m/\#.*/)) if DEBUG; # must include a hash.
} else {
$anchor = '' ;
}
if ( defined( $anchor ) ) {
# 'Web.TopicName#anchor' or 'Web.ABBREV#anchor' link
$text = $topic.$anchor;
} else {
$anchor = '';
# 'Web.TopicName' or 'Web.ABBREV' link:
if ( $topic eq $TWiki::cfg{HomeTopicName} &&
$web ne $this->{session}->{webName} ) {
$text = $web;
} else {
$text = $topic;
}
}
# Allow spacing out, etc
$text = $this->{session}->{plugins}->renderWikiWordHandler( $text ) || $text;
# =$doKeepWeb= boolean: true to keep web prefix (for non existing Web.TOPIC)
# (Necessary to leave "web part" of ABR.ABR.ABR intact if topic not found)
$keepWeb = ( $topic =~ /^$TWiki::regex{abbrevRegex}$/o && $web ne $this->{session}->{webName} );
# false means suppress link for non-existing pages
$linkIfAbsent = ( $topic !~ /^$TWiki::regex{abbrevRegex}$/o );
# SMELL - it seems $linkIfAbsent, $keepWeb are always inverses of each
# other
# TODO: check the spec of doKeepWeb vs $doLinkToMissingPages
return $this->internalLink( $web, $topic, $text, $anchor,
$linkIfAbsent, $keepWeb );
}
# Handle SquareBracketed links mentioned on page $theWeb.$theTopic
# format: [[$text]]
# format: [[$link][$text]]
sub _handleSquareBracketedLink {
my( $this, $web, $topic, $link, $text ) = @_;
# Strip leading/trailing spaces
$link =~ s/^\s+//;
$link =~ s/\s+$//;
# Explicit external [[$link][$text]]-style can be handled directly
if( $link =~ m!^($TWiki::regex{linkProtocolPattern}\:|/)! ) {
if (defined $text) {
# [[][]] style - protect text:
# Prevent automatic WikiWord or CAPWORD linking in explicit links
$text =~ s/(?<=[\s\(])($TWiki::regex{wikiWordRegex}|[$TWiki::regex{upperAlpha}])/$1/go;
}
else {
# [[]] style - take care for legacy:
# Prepare special case of '[[URL#anchor display text]]' link
if ( $link =~ /^(\S+)\s+(.*)$/ ) {
# '[[URL#anchor display text]]' link:
$link = $1;
$text = $2;
$text =~ s/(?<=[\s\(])($TWiki::regex{wikiWordRegex}|[$TWiki::regex{upperAlpha}])/$1/go;
}
}
return $this->_externalLink( $link, $text );
}
$text ||= $link;
# Extract '#anchor'
# $link =~ s/(\#[a-zA-Z_0-9\-]*$)//;
my $anchor = '';
if( $link =~ s/($TWiki::regex{anchorRegex}$)// ) {
$anchor = $1;
}
# filter out &any; entities (legacy)
$link =~ s/\&[a-z]+\;//gi;
# filter out { entities (legacy)
$link =~ s/\&\#[0-9]+\;//g;
# Filter junk
$link =~ s/$TWiki::cfg{NameFilter}+/ /g;
# Capitalise first word
$link =~ s/^(.)/\U$1/;
# Collapse spaces and capitalise following letter
$link =~ s/\s([$TWiki::regex{mixedAlphaNum}])/\U$1/go;
# Get rid of remaining spaces, i.e. spaces in front of -'s and ('s
$link =~ s/\s//go;
$topic = $link if( $link );
# Topic defaults to the current topic
($web, $topic) = $this->{session}->normalizeWebTopicName( $web, $topic );
return $this->internalLink( $web, $topic, $text, $anchor, 1, undef );
}
# Handle an external link typed directly into text. If it's an image
# (as indicated by the file type), and no text is specified, then use
# an img tag, otherwise generate a link.
sub _externalLink {
my( $this, $url, $text ) = @_;
if( $url =~ /\.(gif|jpg|jpeg|png)$/i && !$text) {
my $filename = $url;
$filename =~ s@.*/([^/]*)@$1@go;
return CGI::img( { src => $url, alt => $filename } );
}
my $opt = '';
if( $url =~ /^urn:lsid:/i ) {
$text = $url;
$url = 'http://lsid.tdwg.org/summary/'.$url;
} elsif( $url =~ /^mailto:/i ) {
if( $TWiki::cfg{AntiSpam}{EmailPadding} ) {
$url =~ s/(\@[\w\_\-\+]+)(\.)/$1$TWiki::cfg{AntiSpam}{EmailPadding}$2/;
if ($text) {
$text =~ s/(\@[\w\_\-\+]+)(\.)/$1$TWiki::cfg{AntiSpam}{EmailPadding}$2/;
}
}
if( $TWiki::cfg{AntiSpam}{HideUserDetails} ) {
# Much harder obfuscation scheme. For link text we only encode '@'
# See also Item2928 and Item3430 before touching this
$url =~ s/(\W)/''.ord($1).';'/ge;
if ($text) {
$text =~ s/\@/''.ord('@').';'/ge;
}
}
} else {
$opt = ' target="_top"';
}
$text ||= $url;
# SMELL: Can't use CGI::a here, because it encodes ampersands in
# the link, and those have already been encoded once in the
# rendering loop (they are identified as "stand-alone"). One
# encoding works; two is too many. None would be better for everyone!
return ''.$text.'';
}
# Generate a "mailTo" link
sub _mailLink {
my( $this, $text ) = @_;
my $url = $text;
$url = 'mailto:'.$url unless $url =~ /^mailto:/i;
return $this->_externalLink( $url, $text );
}
=pod
---++ ObjectMethod renderFORMFIELD ( %params, $topic, $web ) -> $html
Returns the fully rendered expansion of a %FORMFIELD{}% tag.
=cut
sub renderFORMFIELD {
my ( $this, $params, $topic, $web ) = @_;
ASSERT($this->isa( 'TWiki::Render')) if DEBUG;
my $formField = $params->{_DEFAULT};
my $formTopic = $params->{topic};
my $altText = $params->{alttext};
my $default = $params->{default};
my $rev = $params->{rev};
my $format = $params->{'format'};
unless ( $format ) {
# if null format explicitly set, return empty
# SMELL: it's not clear what this does; the implication
# is that it does something that violates TWiki tag syntax,
# so I've had to comment it out....
# return '' if ( $args =~ m/format\s*=/o);
# Otherwise default to value
$format = '$value';
}
my $formWeb;
if ( $formTopic ) {
if ($topic =~ /^([^.]+)\.([^.]+)/o) {
( $formWeb, $topic ) = ( $1, $2 );
} else {
# SMELL: Undocumented feature, 'web' parameter
$formWeb = $params->{web};
}
$formWeb = $web unless $formWeb;
} else {
$formWeb = $web;
$formTopic = $topic;
}
my $meta = $this->{ffCache}{$formWeb.'.'.$formTopic};
my $store = $this->{session}->{store};
unless ( $meta ) {
my $dummyText;
( $meta, $dummyText ) =
$store->readTopic( $this->{session}->{user}, $formWeb, $formTopic, $rev );
$this->{ffCache}{$formWeb.'.'.$formTopic} = $meta;
}
my $text = '';
my $found = 0;
my $title = '';
if ( $meta ) {
my @fields = $meta->find( 'FIELD' );
foreach my $field ( @fields ) {
my $name = $field->{name};
$title = $field->{title} || $name;
if( $title eq $formField || $name eq $formField ) {
$found = 1;
my $value = $field->{value};
if (length $value) {
$text = $format;
$text =~ s/\$value/$value/go;
} elsif ( defined $default ) {
$text = $default;
}
last; #one hit suffices
}
}
}
unless ( $found ) {
$text = $altText || '';
}
$text =~ s/\$title/$title/go;
return $text;
}
=pod
---++ ObjectMethod getRenderedVersion ( $text, $theWeb, $theTopic ) -> $html
The main rendering function.
=cut
sub getRenderedVersion {
my( $this, $text, $theWeb, $theTopic ) = @_;
ASSERT($this->isa( 'TWiki::Render')) if DEBUG;
return '' unless $text; # nothing to do
$theTopic ||= $this->{session}->{topicName};
$theWeb ||= $this->{session}->{webName};
my $session = $this->{session};
my $plugins = $session->{plugins};
my $prefs = $session->{prefs};
@{$this->{LIST}} = ();
# Initial cleanup
$text =~ s/\r//g;
# whitespace before \n/s;
# Maps of placeholders to tag parameters and text
my $removed = {};
my $removedComments = {};
my $removedScript = {};
my $removedHead = {};
my $removedVerbatim = {};
my $removedLiterals = {};
$text = $this->takeOutBlocks( $text, 'literal', $removedLiterals );
$text = $this->takeOutBlocks( $text, 'verbatim', $removedVerbatim );
$text = $this->takeOutProtected( $text, qr/<\?([^?]*)\?>/s,
$removedComments );
$text = $this->takeOutProtected( $text, qr/]*)>?/mi,
$removedComments );
$text = $this->takeOutProtected( $text, qr//si,
$removedHead );
$text = $this->takeOutProtected( $text, qr/