1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
2 #
3 # Copyright (C) 2001-2004 Peter Thoeny, peter@thoeny.com
4 #
5 # For licensing info read license.txt file in the TWiki root.
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License
8 # as published by the Free Software Foundation; either version 2
9 # of the License, or (at your option) any later version.
10 #
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details, published at
15 # http://www.gnu.org/copyleft/gpl.html
16 #
17 # Notes:
18 # - Latest version at http://twiki.org/
19 # - Installation instructions in $dataDir/Main/TWikiDocumentation.txt
20 # - Customize variables in TWiki.cfg when installing TWiki.
21 # - Optionally change TWiki.pm for custom extensions of rendering rules.
22 rizwank 1.1 # - Upgrading TWiki is easy as long as you do not customize TWiki.pm.
23 # - Check web server error logs for errors, i.e. % tail /var/log/httpd/error_log
24 #
25 # Jun 2001 - written by John Talintyre, jet@cheerful.com
26
27 =begin twiki
28
29 ---+ TWiki::Render Module
30
31 This module provides most of the actual HTML rendering code in TWiki.
32
33 =cut
34
35 package TWiki::Render;
36
37 use strict;
38
39 use TWiki qw(:renderflags %regex $TranslationToken);
40
41 # ===========================
42 # Read the configuration file at compile time in order to set locale
43 rizwank 1.1 BEGIN {
44 # Do a dynamic 'use locale' for this module
45 if( $TWiki::useLocale ) {
46 require locale;
47 import locale ();
48 }
49 }
50
51 # Globals used in rendering
52 use vars qw(
53 $isList @listTypes @listElements
54 $newTopicFontColor $newTopicBgColor $linkToolTipInfo $noAutoLink
55 $newLinkSymbol %ffCache
56
57 );
58
59
60 $noAutoLink = 0;
61
62 =pod
63
64 rizwank 1.1 ---++ sub initialize ()
65
66 Initializes global render module state from preference values (NEWTOPICBGCOLOR, NEWTOPICFONTCOLOR NEWTOPICLINKSYMBOL LINKTOOLTIPINFO NOAUTOLINK)
67
68 Clears the FORMFIELD metadata cache preparatory to expanding %FORMFIELD
69 tags.
70
71 =cut
72
73 sub initialize
74 {
75 # Add background color and font color (AlWilliams - 18 Sep 2000)
76 # PTh: Moved from internalLink to initialize ('cause of performance)
77 $newTopicBgColor = TWiki::Prefs::getPreferencesValue("NEWTOPICBGCOLOR") || "#FFFFCE";
78 $newTopicFontColor = TWiki::Prefs::getPreferencesValue("NEWTOPICFONTCOLOR") || "#0000FF";
79 $newLinkSymbol = TWiki::Prefs::getPreferencesValue("NEWTOPICLINKSYMBOL") || "<sup>?</sup>";
80 # tooltip init
81 $linkToolTipInfo = TWiki::Prefs::getPreferencesValue("LINKTOOLTIPINFO") || "";
82 $linkToolTipInfo = '$username - $date - r$rev: $summary' if( $linkToolTipInfo =~ /^on$/ );
83 # Prevent autolink of WikiWords
84 $noAutoLink = TWiki::Prefs::getPreferencesValue("NOAUTOLINK") || 0;
85 rizwank 1.1
86 undef %ffCache;
87 }
88
89 =pod
90
91 ---++ sub renderParent ( $web, $topic, $meta, $args )
92
93 Not yet documented.
94
95 =cut
96
97 sub renderParent
98 {
99 my( $web, $topic, $meta, $args ) = @_;
100
101 my $text = "";
102
103 my $dontRecurse = 0;
104 my $noWebHome = 0;
105 my $prefix = "";
106 rizwank 1.1 my $suffix = "";
107 my $usesep = "";
108
109 if( $args ) {
110 $dontRecurse = TWiki::extractNameValuePair( $args, "dontrecurse" );
111 $noWebHome = TWiki::extractNameValuePair( $args, "nowebhome" );
112 $prefix = TWiki::extractNameValuePair( $args, "prefix" );
113 $suffix = TWiki::extractNameValuePair( $args, "suffix" );
114 $usesep = TWiki::extractNameValuePair( $args, "separator" );
115 }
116
117 if( ! $usesep ) {
118 $usesep = " > ";
119 }
120
121 my %visited = ();
122 $visited{"$web.$topic"} = 1;
123
124 my $sep = "";
125 my $cWeb = $web;
126
127 rizwank 1.1 while( 1 ) {
128 my %parent = $meta->findOne( "TOPICPARENT" );
129 if( %parent ) {
130 my $name = $parent{"name"};
131 my $pWeb = $cWeb;
132 my $pTopic = $name;
133 if( $name =~ /^(.*)\.(.*)$/ ) {
134 $pWeb = $1;
135 $pTopic = $2;
136 }
137 if( $noWebHome && ( $pTopic eq $mainTopicname ) ) {
138 last; # exclude "WebHome"
139 }
140 $text = "[[$pWeb.$pTopic][$pTopic]]$sep$text";
141 $sep = $usesep;
142 if( $dontRecurse || ! $name ) {
143 last;
144 } else {
145 my $dummy;
146 if( $visited{"$pWeb.$pTopic"} ) {
147 last;
148 rizwank 1.1 } else {
149 $visited{"$pWeb.$pTopic"} = 1;
150 }
151 if( TWiki::Store::topicExists( $pWeb, $pTopic ) ) {
152 ( $meta, $dummy ) = TWiki::Store::readTopMeta( $pWeb, $pTopic );
153 } else {
154 last;
155 }
156 $cWeb = $pWeb;
157 }
158 } else {
159 last;
160 }
161 }
162
163 if( $text && $prefix ) {
164 $text = "$prefix$text";
165 }
166
167 if( $text && $suffix ) {
168 $text .= $suffix;
169 rizwank 1.1 }
170
171 return $text;
172 }
173
174 # ========================
175 =pod
176
177 ---++ sub renderMoved ( $web, $topic, $meta )
178
179 Not yet documented.
180
181 =cut
182
183 sub renderMoved
184 {
185 my( $web, $topic, $meta ) = @_;
186
187 my $text = "";
188
189 my %moved = $meta->findOne( "TOPICMOVED" );
190 rizwank 1.1
191 if( %moved ) {
192 my $from = $moved{"from"};
193 $from =~ /(.*)\.(.*)/;
194 my $fromWeb = $1;
195 my $fromTopic = $2;
196 my $to = $moved{"to"};
197 $to =~ /(.*)\.(.*)/;
198 my $toWeb = $1;
199 my $toTopic = $2;
200 my $by = $moved{"by"};
201 $by = TWiki::userToWikiName( $by );
202 my $date = $moved{"date"};
203 $date = TWiki::formatTime( $date, "", "gmtime" );
204
205 # Only allow put back if current web and topic match stored information
206 my $putBack = "";
207 if( $web eq $toWeb && $topic eq $toTopic ) {
208 $putBack = " - <a title=\"Click to move topic back to previous location, with option to change references.\"";
209 $putBack .= " href=\"$dispScriptUrlPath/rename$scriptSuffix/$web/$topic?newweb=$fromWeb&newtopic=$fromTopic&";
210 $putBack .= "confirm=on\">put it back</a>";
211 rizwank 1.1 }
212 $text = "<i><nop>$to moved from <nop>$from on $date by $by </i>$putBack";
213 }
214
215 return $text;
216 }
217
218
219 # ========================
220 =pod
221
222 ---++ sub renderFormField ( $meta, $args )
223
224 Not yet documented.
225
226 =cut
227
228 sub renderFormField
229 {
230 my( $meta, $args ) = @_;
231 my $text = "";
232 rizwank 1.1 if( $args ) {
233 my $name = TWiki::extractNameValuePair( $args, "name" );
234 $text = TWiki::Search::getMetaFormField( $meta, $name ) if( $name );
235 }
236 return $text;
237 }
238
239 # =========================
240 =pod
241
242 ---++ sub renderFormData ( $web, $topic, $meta )
243
244 Not yet documented.
245
246 =cut
247
248 sub renderFormData
249 {
250 my( $web, $topic, $meta ) = @_;
251
252 my $metaText = "";
253 rizwank 1.1
254 my %form = $meta->findOne( "FORM" );
255 if( %form ) {
256 my $name = $form{"name"};
257 $metaText = "<div class=\"twikiForm\">\n";
258 $metaText .= "<p></p>\n"; # prefix empty line
259 $metaText .= "|*[[$name]]*||\n"; # table header
260 my @fields = $meta->find( "FIELD" );
261 foreach my $field ( @fields ) {
262 my $title = $field->{"title"};
263 my $value = $field->{"value"};
264 $value =~ s/\n/<br \/>/g; # undo expansion
265 $metaText .= "| $title:|$value |\n";
266 }
267 $metaText .= "\n</div>";
268 }
269
270 return $metaText;
271 }
272
273 # Before including topic text in a hidden field in web form, encode
274 rizwank 1.1 # characters that would break the field
275 =pod
276
277 ---++ sub encodeSpecialChars ( $text )
278
279 Not yet documented.
280
281 =cut
282
283 sub encodeSpecialChars
284 {
285 my( $text ) = @_;
286
287 $text =~ s/&/%_A_%/g;
288 $text =~ s/\"/%_Q_%/g;
289 $text =~ s/>/%_G_%/g;
290 $text =~ s/</%_L_%/g;
291 # PTh, JoachimDurchholz 22 Nov 2001: Fix for Codev.OperaBrowserDoublesEndOfLines
292 $text =~ s/(\r*\n|\r)/%_N_%/g;
293
294 return $text;
295 rizwank 1.1 }
296
297 =pod
298
299 ---++ sub decodeSpecialChars ( $text )
300
301 Not yet documented.
302
303 =cut
304
305 sub decodeSpecialChars
306 {
307 my( $text ) = @_;
308
309 $text =~ s/%_N_%/\r\n/g;
310 $text =~ s/%_L_%/</g;
311 $text =~ s/%_G_%/>/g;
312 $text =~ s/%_Q_%/\"/g;
313 $text =~ s/%_A_%/&/g;
314
315 return $text;
316 rizwank 1.1 }
317
318
319 # =========================
320 # Render bulleted and numbered lists, including nesting.
321 # Called from several places. Accumulates @listTypes and @listElements
322 # to track nested lists.
323 =pod
324
325 ---++ sub emitList ( $theType, $theElement, $theDepth, $theOlType )
326
327 Not yet documented.
328
329 =cut
330
331 sub emitList {
332 my( $theType, $theElement, $theDepth, $theOlType ) = @_;
333
334 my $result = "";
335 $isList = 1;
336
337 rizwank 1.1 # Ordered list type
338 $theOlType = "" unless( $theOlType );
339 $theOlType =~ s/^(.).*/$1/;
340 $theOlType = "" if( $theOlType eq "1" );
341
342 if( @listTypes < $theDepth ) {
343 my $firstTime = 1;
344 while( @listTypes < $theDepth ) {
345 push( @listTypes, $theType );
346 push( @listElements, $theElement );
347 $result .= "<$theElement>\n" unless( $firstTime );
348 if( $theOlType ) {
349 $result .= "<$theType type=\"$theOlType\">\n";
350 } else {
351 $result .= "<$theType>\n";
352 }
353 $firstTime = 0;
354 }
355
356 } elsif( @listTypes > $theDepth ) {
357 while( @listTypes > $theDepth ) {
358 rizwank 1.1 local($_) = pop @listElements;
359 $result .= "</$_>\n";
360 local($_) = pop @listTypes;
361 $result .= "</$_>\n";
362 }
363 $result .= "</$listElements[$#listElements]>\n" if( @listElements );
364
365 } elsif( @listElements ) {
366 $result = "</$listElements[$#listElements]>\n";
367 }
368
369 if( ( @listTypes ) && ( $listTypes[$#listTypes] ne $theType ) ) {
370 $result .= "</$listTypes[$#listTypes]>\n<$theType>\n";
371 $listTypes[$#listTypes] = $theType;
372 $listElements[$#listElements] = $theElement;
373 }
374
375 return $result;
376 }
377
378 # ========================
379 rizwank 1.1 =pod
380
381 ---++ sub emitTR ( $thePre, $theRow, $insideTABLE )
382
383 Not yet documented.
384
385 =cut
386
387 sub emitTR {
388 my ( $thePre, $theRow, $insideTABLE ) = @_;
389
390 my $text = "";
391 my $attr = "";
392 my $l1 = 0;
393 my $l2 = 0;
394 if( $insideTABLE ) {
395 $text = "$thePre<tr>";
396 } else {
397 $text = "$thePre<table border=\"1\" cellspacing=\"0\" cellpadding=\"1\"> <tr>";
398 }
399 $theRow =~ s/\t/ /g; # change tabs to space
400 rizwank 1.1 $theRow =~ s/\s*$//; # remove trailing spaces
401 $theRow =~ s/(\|\|+)/$TranslationToken . length($1) . "\|"/ge; # calc COLSPAN
402
403 foreach( split( /\|/, $theRow ) ) {
404 $attr = "";
405 #AS 25-5-01 Fix to avoid matching also single columns
406 if ( s/$TranslationToken([0-9]+)//o ) {
407 $attr = " colspan=\"$1\"" ;
408 }
409 s/^\s+$/ /;
410 /^(\s*).*?(\s*)$/;
411 $l1 = length( $1 || "" );
412 $l2 = length( $2 || "" );
413 if( $l1 >= 2 ) {
414 if( $l2 <= 1 ) {
415 $attr .= ' align="right"';
416 } else {
417 $attr .= ' align="center"';
418 }
419 }
420 if( /^\s*(\*.*\*)\s*$/ ) {
421 rizwank 1.1 $text .= "<th$attr bgcolor=\"#99CCCC\"> $1 </th>";
422 } else {
423 $text .= "<td$attr> $_ </td>";
424 }
425 }
426 $text .= "</tr>";
427 return $text;
428 }
429
430 # =========================
431 =pod
432
433 ---++ sub fixedFontText ( $theText, $theDoBold )
434
435 Not yet documented.
436
437 =cut
438
439 sub fixedFontText
440 {
441 my( $theText, $theDoBold ) = @_;
442 rizwank 1.1 # preserve white space, so replace it by " " patterns
443 $theText =~ s/\t/ /g;
444 $theText =~ s|((?:[\s]{2})+)([^\s])|' ' x (length($1) / 2) . "$2"|eg;
445 if( $theDoBold ) {
446 return "<code><b>$theText</b></code>";
447 } else {
448 return "<code>$theText</code>";
449 }
450 }
451
452 # =========================
453 # Build an HTML <Hn> element with suitable anchor for linking from %<nop>TOC%
454 =pod
455
456 ---++ sub makeAnchorHeading ( $theText, $theLevel )
457
458 Not yet documented.
459
460 =cut
461
462 sub makeAnchorHeading
463 rizwank 1.1 {
464 my( $theHeading, $theLevel ) = @_;
465
466 # - Build '<nop><h1><a name="atext"></a> heading </h1>' markup
467 # - Initial '<nop>' is needed to prevent subsequent matches.
468 # - filter out $regex{headerPatternNoTOC} ( '!!' and '%NOTOC%' )
469 # CODE_SMELL: Empty anchor tags seem not to be allowed, but validators and browsers tolerate them
470
471 my $anchorName = makeAnchorName( $theHeading, 0 );
472 my $compatAnchorName = makeAnchorName( $theHeading, 1 );
473 $theHeading =~ s/$regex{headerPatternNoTOC}//o; # filter '!!', '%NOTOC%'
474 my $text = "<nop><h$theLevel>";
475 $text .= "<a name=\"$anchorName\"> </a>";
476 $text .= "<a name=\"$compatAnchorName\"> </a>" if( $compatAnchorName ne $anchorName );
477 $text .= " $theHeading </h$theLevel>";
478
479 return $text;
480 }
481
482 # =========================
483 # Build a valid HTML anchor name
484 rizwank 1.1 =pod
485
486 ---++ sub makeAnchorName ( $anchorName, $compatibilityMode )
487
488 Not yet documented.
489
490 =cut
491
492 sub makeAnchorName
493 {
494 my( $anchorName, $compatibilityMode ) = @_;
495
496 if ( ! $compatibilityMode && $anchorName =~ /^$regex{anchorRegex}$/ ) {
497 # accept, already valid -- just remove leading #
498 return substr($anchorName, 1);
499 }
500
501 if ( $compatibilityMode ) {
502 # remove leading/trailing underscores first, allowing them to be
503 # reintroduced
504 $anchorName =~ s/^[\s\#\_]*//;
505 rizwank 1.1 $anchorName =~ s/[\s\_]*$//;
506 }
507 $anchorName =~ s/<\w[^>]*>//gi; # remove HTML tags
508 $anchorName =~ s/\&\#?[a-zA-Z0-9]*;//g; # remove HTML entities
509 $anchorName =~ s/\&//g; # remove &
510 $anchorName =~ s/^(.+?)\s*$regex{headerPatternNoTOC}.*/$1/o; # filter TOC excludes if not at beginning
511 $anchorName =~ s/$regex{headerPatternNoTOC}//o; # filter '!!', '%NOTOC%'
512 # FIXME: More efficient to match with '+' on next line:
513 $anchorName =~ s/$regex{singleMixedNonAlphaNumRegex}/_/g; # only allowed chars
514 $anchorName =~ s/__+/_/g; # remove excessive '_'
515 if ( !$compatibilityMode ) {
516 $anchorName =~ s/^[\s\#\_]*//; # no leading space nor '#', '_'
517 }
518 $anchorName =~ s/^(.{32})(.*)$/$1/; # limit to 32 chars - FIXME: Use Unicode chars before truncate
519 if ( !$compatibilityMode ) {
520 $anchorName =~ s/[\s\_]*$//; # no trailing space, nor '_'
521 }
522
523 # No need to encode 8-bit characters in anchor due to UTF-8 URL support
524
525 return $anchorName;
526 rizwank 1.1 }
527
528 # =========================
529 =pod
530
531 ---++ sub linkToolTipInfo ( $theWeb, $theTopic )
532
533 Returns =title="..."= tooltip info in case LINKTOOLTIPINFO perferences variable is set.
534 Warning: Slower performance if enabled.
535
536 =cut
537
538 sub linkToolTipInfo
539 {
540 my( $theWeb, $theTopic ) = @_;
541 return "" unless( $linkToolTipInfo );
542 return "" if( $linkToolTipInfo =~ /^off$/i );
543
544 # FIXME: This is slow, it can be improved by caching topic rev info and summary
545 my( $date, $user, $rev ) = TWiki::Store::getRevisionInfo( $theWeb, $theTopic );
546 my $text = $linkToolTipInfo;
547 rizwank 1.1 $text =~ s/\$web/<nop>$theWeb/g;
548 $text =~ s/\$topic/<nop>$theTopic/g;
549 $text =~ s/\$rev/1.$rev/g;
550 $text =~ s/\$date/&TWiki::formatTime( $date )/ge;
551 $text =~ s/\$username/<nop>$user/g; # "jsmith"
552 $text =~ s/\$wikiname/"<nop>" . &TWiki::userToWikiName( $user, 1 )/ge; # "JohnSmith"
553 $text =~ s/\$wikiusername/"<nop>" . &TWiki::userToWikiName( $user )/ge; # "Main.JohnSmith"
554 if( $text =~ /\$summary/ ) {
555 my $summary = &TWiki::Store::readFileHead( "$TWiki::dataDir/$theWeb/$theTopic.txt", 16 );
556 $summary = &TWiki::makeTopicSummary( $summary, $theTopic, $theWeb );
557 $summary =~ s/[\"\']/<nop>/g; # remove quotes (not allowed in title attribute)
558 $text =~ s/\$summary/$summary/g;
559 }
560 return " title=\"$text\"";
561 }
562
563 # =========================
564 =pod
565
566 ---++ sub internalLink ( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb )
567
568 rizwank 1.1 Not yet documented.
569
570 =cut
571
572 sub internalLink {
573 my( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb ) = @_;
574 # $thePreamble is text used before the TWiki link syntax
575 # $doLink is boolean: false means suppress link for non-existing pages
576 # $doKeepWeb is boolean: true to keep web prefix (for non existing Web.TOPIC)
577
578 # Get rid of leading/trailing spaces in topic name
579 $theTopic =~ s/^\s*//;
580 $theTopic =~ s/\s*$//;
581
582 # Turn spaced-out names into WikiWords - upper case first letter of
583 # whole link, and first of each word. TODO: Try to turn this off,
584 # avoiding spaces being stripped elsewhere - e.g. $doPreserveSpacedOutWords
585 $theTopic =~ s/^(.)/\U$1/;
586 $theTopic =~ s/\s($regex{singleMixedAlphaNumRegex})/\U$1/go;
587
588 # Add <nop> before WikiWord inside link text to prevent double links
589 rizwank 1.1 $theLinkText =~ s/([\s\(])($regex{singleUpperAlphaRegex})/$1<nop>$2/go;
590
591 # Allow spacing out, etc
592 if (TWiki::isWikiName($theLinkText)) {
593 $theLinkText = TWiki::Plugins::renderWikiWordHandler( $theLinkText ) || $theLinkText;
594 }
595
596 my $exist = &TWiki::Store::topicExists( $theWeb, $theTopic );
597 # I18N - Only apply plural processing if site language is English, or
598 # if a built-in English-language web (Main, TWiki or Plugins). Plurals
599 # apply to names ending in 's', where topic doesn't exist with plural
600 # name.
601 if( ( $doPluralToSingular ) and ( $siteLang eq 'en'
602 or $theWeb eq $mainWebname
603 or $theWeb eq $twikiWebname
604 or $theWeb eq 'Plugins'
605 )
606 and ( $theTopic =~ /s$/ ) and not ( $exist ) ) {
607 # Topic name is plural in form and doesn't exist as written
608 my $tmp = $theTopic;
609 $tmp =~ s/ies$/y/; # plurals like policy / policies
610 rizwank 1.1 $tmp =~ s/sses$/ss/; # plurals like address / addresses
611 $tmp =~ s/([Xx])es$/$1/; # plurals like box / boxes
612 $tmp =~ s/([A-Za-rt-z])s$/$1/; # others, excluding ending ss like address(es)
613 if( &TWiki::Store::topicExists( $theWeb, $tmp ) ) {
614 $theTopic = $tmp;
615 $exist = 1;
616 }
617 }
618
619 my $text = $thePreamble;
620 if( $exist) {
621 if( $theAnchor ) {
622 my $anchor = makeAnchorName( $theAnchor );
623 $text .= "<a class=\"twikiAnchorLink\" href=\"$dispScriptUrlPath$dispViewPath"
624 . "$scriptSuffix/$theWeb/$theTopic\#$anchor\""
625 . &linkToolTipInfo( $theWeb, $theTopic )
626 . ">$theLinkText</a>";
627 return $text;
628 } else {
629 $text .= "<a class=\"twikiLink\" href=\"$dispScriptUrlPath$dispViewPath"
630 . "$scriptSuffix/$theWeb/$theTopic\""
631 rizwank 1.1 . &linkToolTipInfo( $theWeb, $theTopic )
632 . ">$theLinkText</a>";
633 return $text;
634 }
635
636 } elsif( $doLink ) {
637 $text .= "<span class=\"twikiNewLink\" style='background : $newTopicBgColor;'>"
638 . "<font color=\"$newTopicFontColor\">$theLinkText</font>"
639 . "<a href=\"$dispScriptUrlPath/edit$scriptSuffix/$theWeb/$theTopic?topicparent=$TWiki::webName.$TWiki::topicName\">$newLinkSymbol</a></span>";
640 return $text;
641
642 } elsif( $doKeepWeb ) {
643 $text .= "$theWeb.$theLinkText";
644 return $text;
645
646 } else {
647 $text .= $theLinkText;
648 return $text;
649 }
650 }
651
652 rizwank 1.1 # =========================
653 =pod
654
655 ---++ sub internalCrosswebLink ( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink )
656
657 Not yet documented.
658
659 =cut
660
661 sub internalCrosswebLink
662 {
663 my( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink ) = @_;
664 if ( $theTopic eq $TWiki::mainTopicname && $theWeb ne $TWiki::webName ) {
665 return internalLink( $thePreamble, $theWeb, $theTopic, $theWeb, $theAnchor, $doLink );
666 } else {
667 return internalLink( $thePreamble, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink );
668 }
669 }
670
671 # =========================
672 # Handle most internal and external links
673 rizwank 1.1 =pod
674
675 ---++ sub specificLink ( $thePreamble, $theWeb, $theTopic, $theText, $theLink )
676
677 Not yet documented.
678
679 =cut
680
681 sub specificLink
682 {
683 my( $thePreamble, $theWeb, $theTopic, $theText, $theLink ) = @_;
684
685 # format: $thePreamble[[$theText]]
686 # format: $thePreamble[[$theLink][$theText]]
687 #
688 # Current page's $theWeb and $theTopic are also used
689
690 # Strip leading/trailing spaces
691 $theLink =~ s/^\s*//;
692 $theLink =~ s/\s*$//;
693
694 rizwank 1.1 if( $theLink =~ /^$regex{linkProtocolPattern}\:/ ) {
695
696 # External link: add <nop> before WikiWord and ABBREV
697 # inside link text, to prevent double links
698 $theText =~ s/([\s\(])($regex{singleUpperAlphaRegex})/$1<nop>$2/go;
699 return "$thePreamble<a href=\"$theLink\" target=\"_top\">$theText</a>";
700
701 } else {
702
703 # Internal link: get any 'Web.' prefix, or use current web
704 $theLink =~ s/^($regex{webNameRegex}|$regex{defaultWebNameRegex})\.//;
705 my $web = $1 || $theWeb;
706 (my $baz = "foo") =~ s/foo//; # reset $1, defensive coding
707
708 # Extract '#anchor'
709 # FIXME and NOTE: Had '-' as valid anchor character, removed
710 # $theLink =~ s/(\#[a-zA-Z_0-9\-]*$)//;
711 $theLink =~ s/($regex{anchorRegex}$)//;
712 my $anchor = $1 || "";
713
714 # Get the topic name
715 rizwank 1.1 my $topic = $theLink || $theTopic; # remaining is topic
716 $topic =~ s/\&[a-z]+\;//gi; # filter out &any; entities
717 $topic =~ s/\&\#[0-9]+\;//g; # filter out { entities
718 $topic =~ s/[\\\/\#\&\(\)\{\}\[\]\<\>\!\=\:\,\.]//g;
719 $topic =~ s/$securityFilter//go; # filter out suspicious chars
720 if( ! $topic ) {
721 return "$thePreamble$theText"; # no link if no topic
722 }
723
724 return internalLink( $thePreamble, $web, $topic, $theText, $anchor, 1 );
725 }
726
727 }
728
729 # =========================
730 =pod
731
732 ---++ sub externalLink ( $pre, $url )
733
734 Not yet documented.
735
736 rizwank 1.1 =cut
737
738 sub externalLink
739 {
740 my( $pre, $url ) = @_;
741 if( $url =~ /\.(gif|jpg|jpeg|png)$/i ) {
742 my $filename = $url;
743 $filename =~ s@.*/([^/]*)@$1@go;
744 return "$pre<img src=\"$url\" alt=\"$filename\" />";
745 }
746
747 return "$pre<a href=\"$url\" target=\"_top\">$url</a>";
748 }
749
750 # =========================
751 =pod
752
753 ---++ sub mailtoLink ( $theAccount, $theSubDomain, $theTopDomain )
754
755 Not yet documented.
756
757 rizwank 1.1 =cut
758
759 sub mailtoLink
760 {
761 my( $theAccount, $theSubDomain, $theTopDomain ) = @_;
762
763 my $addr = "$theAccount\@$theSubDomain$TWiki::noSpamPadding\.$theTopDomain";
764 return "<a href=\"mailto\:$addr\">$addr</a>";
765 }
766
767 # =========================
768 =pod
769
770 ---++ sub mailtoLinkFull ( $theAccount, $theSubDomain, $theTopDomain, $theLinkText )
771
772 Not yet documented.
773
774 =cut
775
776 sub mailtoLinkFull
777 {
778 rizwank 1.1 my( $theAccount, $theSubDomain, $theTopDomain, $theLinkText ) = @_;
779
780 my $addr = "$theAccount\@$theSubDomain$TWiki::noSpamPadding\.$theTopDomain";
781 return "<a href=\"mailto\:$addr\">$theLinkText</a>";
782 }
783
784 # =========================
785 =pod
786
787 ---++ sub mailtoLinkSimple ( $theMailtoString, $theLinkText )
788
789 Not yet documented.
790
791 =cut
792
793 sub mailtoLinkSimple
794 {
795 # Does not do any anti-spam padding, because address will not include '@'
796 my( $theMailtoString, $theLinkText ) = @_;
797
798 # Defensive coding
799 rizwank 1.1 if ($theMailtoString =~ s/@//g ) {
800 writeWarning("mailtoLinkSimple called with an '\@' in string - internal TWiki error");
801 }
802 return "<a href=\"mailto\:$theMailtoString\">$theLinkText</a>";
803 }
804
805 =pod
806
807 ---++ sub getFormField ( $web, $topic, $args )
808
809 +Returns the expansion of a %FORMFIELD{}% tag.
810
811 =cut
812
813 sub getFormField
814 {
815 my( $web, $topic, $args ) = @_;
816
817 my $formField = TWiki::extractNameValuePair( $args );
818 my $formTopic = TWiki::extractNameValuePair( $args, "topic" );
819 my $altText = TWiki::extractNameValuePair( $args, "alttext" );
820 rizwank 1.1 my $default = TWiki::extractNameValuePair( $args, "default" ) || undef;
821 my $format = TWiki::extractNameValuePair( $args, "format" );
822
823 unless ( $format ) {
824 # if null format explicitly set, return empty
825 return "" if ( $args =~ m/format\s*=/o);
826 # Otherwise default to value
827 $format = "\$value";
828 }
829
830 my $formWeb;
831 if ( $formTopic ) {
832 if ($topic =~ /^([^.]+)\.([^.]+)/o) {
833 ( $formWeb, $topic ) = ( $1, $2 );
834 } else {
835 # SMELL: Undocumented feature, "web" parameter
836 $formWeb = TWiki::extractNameValuePair( $args, "web" );
837 }
838 $formWeb = $web unless $formWeb;
839 } else {
840 $formWeb = $web;
841 rizwank 1.1 $formTopic = $topic;
842 }
843
844 my $meta = $ffCache{"$formWeb.$formTopic"};
845 unless ( $meta ) {
846 my $dummyText;
847 ( $meta, $dummyText ) =
848 TWiki::Store::readTopic( $formWeb, $formTopic );
849 $ffCache{"$formWeb.$formTopic"} = $meta;
850 }
851
852 my $text = "";
853 my $found = 0;
854 if ( $meta ) {
855 my @fields = $meta->find( "FIELD" );
856 foreach my $field ( @fields ) {
857 my $title = $field->{"title"};
858 my $name = $field->{"name"};
859 if( $title eq $formField || $name eq $formField ) {
860 $found = 1;
861 my $value = $field->{"value"};
862 rizwank 1.1 if (length $value) {
863 $text = $format;
864 $text =~ s/\$value/$value/go;
865 } elsif ( defined $default ) {
866 $text = $default;
867 }
868 last; #one hit suffices
869 }
870 }
871 }
872
873 unless ( $found ) {
874 $text = $altText;
875 }
876
877 return "" unless $text;
878
879 return getRenderedVersion( $text, $web );
880 }
881
882 =pod
883 rizwank 1.1
884 ---++ sub getRenderedVersion ( $text, $theWeb, $meta )
885
886 Not yet documented.
887
888 =cut
889
890 sub getRenderedVersion
891 {
892 my( $text, $theWeb, $meta ) = @_;
893 my( $head, $result, $extraLines, $insidePRE, $insideTABLE, $insideNoAutoLink );
894
895 return "" unless $text; # nothing to do
896
897 # FIXME: Get $theTopic from parameter to handle [[#anchor]] correctly
898 # (fails in %INCLUDE%, %SEARCH%)
899 my $theTopic = $TWiki::topicName;
900
901 # PTh 22 Jul 2000: added $theWeb for correct handling of %INCLUDE%, %SEARCH%
902 if( !$theWeb ) {
903 $theWeb = $TWiki::webName;
904 rizwank 1.1 }
905
906 $head = "";
907 $result = "";
908 $insidePRE = 0;
909 $insideTABLE = 0;
910 $insideNoAutoLink = 0; # PTh 02 Feb 2001: Added Codev.DisableWikiWordLinks
911 $isList = 0;
912 @listTypes = ();
913 @listElements = ();
914
915 # Initial cleanup
916 $text =~ s/\r//g;
917 $text =~ s/(\n?)$/\n<nop>\n/s; # clutch to enforce correct rendering at end of doc
918 # Convert any occurrences of token (very unlikely - details in
919 # Codev.NationalCharTokenClash)
920 $text =~ s/$TranslationToken/!/go;
921
922 my @verbatim = ();
923 $text = TWiki::takeOutVerbatim( $text, \@verbatim );
924 $text =~ s/\\\n//g; # Join lines ending in "\"
925 rizwank 1.1
926 # do not render HTML head, style sheets and scripts
927 if( $text =~ m/<body[\s\>]/i ) {
928 my $bodyTag = "";
929 my $bodyText = "";
930 ( $head, $bodyTag, $bodyText ) = split( /(<body)/i, $text, 3 );
931 $text = $bodyTag . $bodyText;
932 }
933
934 # Wiki Plugin Hook
935 &TWiki::Plugins::startRenderingHandler( $text, $theWeb, $meta );
936
937 # $isList is tested and set by this loop and 'emitList' function
938 $isList = 0; # True when within a list
939
940 foreach( split( /\n/, $text ) ) {
941
942 # change state:
943 m|<pre>|i && ( $insidePRE = 1 );
944 m|</pre>|i && ( $insidePRE = 0 );
945 m|<noautolink>|i && ( $insideNoAutoLink = 1 );
946 rizwank 1.1 m|</noautolink>|i && ( $insideNoAutoLink = 0 );
947
948 if( $insidePRE ) {
949 # inside <PRE>
950
951 # close list tags if any
952 if( @listTypes ) {
953 $result .= &emitList( "", "", 0 );
954 $isList = 0;
955 }
956
957 # Wiki Plugin Hook
958 &TWiki::Plugins::insidePREHandler( $_ );
959
960 s/(.*)/$1\n/;
961 s/\t/ /g; # Three spaces
962 $result .= $_;
963
964 } else {
965 # normal state, do Wiki rendering
966
967 rizwank 1.1 # Wiki Plugin Hook
968 &TWiki::Plugins::outsidePREHandler( $_ );
969 $extraLines = undef; # Plugins might introduce extra lines
970 do { # Loop over extra lines added by plugins
971 $_ = $extraLines if( defined $extraLines );
972 s/^(.*?)\n(.*)$/$1/s;
973 $extraLines = $2; # Save extra lines, need to parse each separately
974
975 # Escape rendering: Change " !AnyWord" to " <nop>AnyWord", for final " AnyWord" output
976 s/(^|[\s\(])\!(?=[\w\*\=])/$1<nop>/g;
977
978 # Blockquoted email (indented with '> ')
979 s/^>(.*?)$/> <cite> $1 <\/cite><br \/>/g;
980
981 # Embedded HTML
982 s/\<(\!\-\-)/$TranslationToken$1/g; # Allow standalone "<!--"
983 s/(\-\-)\>/$1$TranslationToken/g; # Allow standalone "-->"
984 # FIXME: next 2 lines are redundant since s///g's below do same
985 # thing
986 s/(\<\<+)/"<\;" x length($1)/ge;
987 s/(\>\>+)/">\;" x length($1)/ge;
988 rizwank 1.1 s/\<nop\>/nopTOKEN/g; # defuse <nop> inside HTML tags
989 s/\<(\S.*?)\>/$TranslationToken$1$TranslationToken/g;
990 s/</<\;/g;
991 s/>/>\;/g;
992 s/$TranslationToken(\S.*?)$TranslationToken/\<$1\>/go;
993 s/nopTOKEN/\<nop\>/g;
994 s/(\-\-)$TranslationToken/$1\>/go;
995 s/$TranslationToken(\!\-\-)/\<$1/go;
996
997 # Handle embedded URLs
998 s!(^|[\-\*\s\(])($regex{linkProtocolPattern}\:([^\s\<\>\"]+[^\s\.\,\!\?\;\:\)\<]))!&externalLink($1,$2)!geo;
999
1000 # Entities
1001 s/&(\w+?)\;/$TranslationToken$1\;/g; # "&abc;"
1002 s/&(\#[0-9]+)\;/$TranslationToken$1\;/g; # "{"
1003 s/&/&/g; # escape standalone "&"
1004 s/$TranslationToken/&/go;
1005
1006 # Headings
1007 # '<h6>...</h6>' HTML rule
1008 s/$regex{headerPatternHt}/&makeAnchorHeading($2,$1)/geoi;
1009 rizwank 1.1 # '\t+++++++' rule
1010 s/$regex{headerPatternSp}/&makeAnchorHeading($2,(length($1)))/geo;
1011 # '----+++++++' rule
1012 s/$regex{headerPatternDa}/&makeAnchorHeading($2,(length($1)))/geo;
1013
1014 # Horizontal rule
1015 s/^---+/<hr \/>/;
1016 s!^([a-zA-Z0-9]+)----*!<table width=\"100%\"><tr><td valign=\"bottom\"><h2>$1</h2></td><td width=\"98%\" valign=\"middle\"><hr /></td></tr></table>!o;
1017
1018 # Table of format: | cell | cell |
1019 # PTh 25 Jan 2001: Forgiving syntax, allow trailing white space
1020 if( $_ =~ /^(\s*)\|.*\|\s*$/ ) {
1021 s/^(\s*)\|(.*)/&emitTR($1,$2,$insideTABLE)/e;
1022 $insideTABLE = 1;
1023 } elsif( $insideTABLE ) {
1024 $result .= "</table>\n";
1025 $insideTABLE = 0;
1026 }
1027
1028 # Lists and paragraphs
1029 s/^\s*$/<p \/>/o && ( $isList = 0 );
1030 rizwank 1.1 m/^(\S+?)/o && ( $isList = 0 );
1031 # Definition list
1032 s/^(\t+)\$\s(([^:]+|:[^\s]+)+?):\s/<dt> $2 <\/dt><dd> /o && ( $result .= &emitList( "dl", "dd", length $1 ) );
1033 s/^(\t+)(\S+?):\s/<dt> $2<\/dt><dd> /o && ( $result .= &emitList( "dl", "dd", length $1 ) );
1034 # Unnumbered list
1035 s/^(\t+)\* /<li> /o && ( $result .= &emitList( "ul", "li", length $1 ) );
1036 # Numbered list
1037 s/^(\t+)([1AaIi]\.|\d+\.?) ?/<li> /o && ( $result .= &emitList( "ol", "li", length $1, $2 ) );
1038 # Finish the list
1039 if( ! $isList ) {
1040 $result .= &emitList( "", "", 0 );
1041 $isList = 0;
1042 }
1043
1044 # '#WikiName' anchors
1045 s/^(\#)($regex{wikiWordRegex})/ '<a name="' . &makeAnchorName( $2 ) . '"><\/a>'/ge;
1046
1047 # enclose in white space for the regex that follow
1048 s/(.*)/\n$1\n/;
1049
1050 # Emphasizing
1051 rizwank 1.1 # PTh 25 Sep 2000: More relaxed rules, allow leading '(' and trailing ',.;:!?)'
1052 s/([\s\(])==([^\s]+?|[^\s].*?[^\s])==([\s\,\.\;\:\!\?\)])/$1 . &fixedFontText( $2, 1 ) . $3/ge;
1053 s/([\s\(])__([^\s]+?|[^\s].*?[^\s])__([\s\,\.\;\:\!\?\)])/$1<strong><em>$2<\/em><\/strong>$3/g;
1054 s/([\s\(])\*([^\s]+?|[^\s].*?[^\s])\*([\s\,\.\;\:\!\?\)])/$1<strong>$2<\/strong>$3/g;
1055 s/([\s\(])_([^\s]+?|[^\s].*?[^\s])_([\s\,\.\;\:\!\?\)])/$1<em>$2<\/em>$3/g;
1056 s/([\s\(])=([^\s]+?|[^\s].*?[^\s])=([\s\,\.\;\:\!\?\)])/$1 . &fixedFontText( $2, 0 ) . $3/ge;
1057
1058 # Mailto
1059 # Email addresses must always be 7-bit, even within I18N sites
1060
1061 # RD 27 Mar 02: Mailto improvements - FIXME: check security...
1062 # Explicit [[mailto:... ]] link without an '@' - hence no
1063 # anti-spam padding needed.
1064 # '[[mailto:string display text]]' link (no '@' in 'string'):
1065 s/\[\[mailto\:([^\s\@]+)\s+(.+?)\]\]/&mailtoLinkSimple( $1, $2 )/ge;
1066
1067 # Explicit [[mailto:... ]] link including '@', with anti-spam
1068 # padding, so match name@subdom.dom.
1069 # '[[mailto:string display text]]' link
1070 s/\[\[mailto\:([a-zA-Z0-9\-\_\.\+]+)\@([a-zA-Z0-9\-\_\.]+)\.(.+?)(\s+|\]\[)(.*?)\]\]/&mailtoLinkFull( $1, $2, $3, $5 )/ge;
1071
1072 rizwank 1.1 # Normal mailto:foo@example.com ('mailto:' part optional)
1073 # FIXME: Should be '?' after the 'mailto:'...
1074 s/([\s\(])(?:mailto\:)*([a-zA-Z0-9\-\_\.\+]+)\@([a-zA-Z0-9\-\_\.]+)\.([a-zA-Z0-9\-\_]+)(?=[\s\.\,\;\:\!\?\)])/$1 . &mailtoLink( $2, $3, $4 )/ge;
1075
1076 # Make internal links
1077 # Escape rendering: Change " ![[..." to " [<nop>[...", for final unrendered " [[..." output
1078 s/(\s)\!\[\[/$1\[<nop>\[/g;
1079 # Spaced-out Wiki words with alternative link text
1080 # '[[Web.odd wiki word#anchor][display text]]' link:
1081 s/\[\[([^\]]+)\]\[([^\]]+)\]\]/&specificLink("",$theWeb,$theTopic,$2,$1)/ge;
1082 # RD 25 Mar 02: Codev.EasierExternalLinking
1083 # '[[URL#anchor display text]]' link:
1084 s/\[\[([a-z]+\:\S+)\s+(.*?)\]\]/&specificLink("",$theWeb,$theTopic,$2,$1)/ge;
1085 # Spaced-out Wiki words
1086 # '[[Web.odd wiki word#anchor]]' link:
1087 s/\[\[([^\]]+)\]\]/&specificLink("",$theWeb,$theTopic,$1,$1)/ge;
1088
1089 # do normal WikiWord link if not disabled by <noautolink> or NOAUTOLINK preferences variable
1090 unless( $noAutoLink || $insideNoAutoLink ) {
1091
1092 # 'Web.TopicName#anchor' link:
1093 rizwank 1.1 s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})($regex{anchorRegex})/&internalLink($1,$2,$3,"$TranslationToken$3$4$TranslationToken",$4,1)/geo;
1094 # 'Web.TopicName' link:
1095 s/([\s\(])($regex{webNameRegex})\.($regex{wikiWordRegex})/&internalCrosswebLink($1,$2,$3,"$TranslationToken$3$TranslationToken","",1)/geo;
1096
1097 # 'TopicName#anchor' link:
1098 s/([\s\(])($regex{wikiWordRegex})($regex{anchorRegex})/&internalLink($1,$theWeb,$2,"$TranslationToken$2$3$TranslationToken",$3,1)/geo;
1099
1100 # 'TopicName' link:
1101 s/([\s\(])($regex{wikiWordRegex})/&internalLink($1,$theWeb,$2,$2,"",1)/geo;
1102
1103 # Handle acronyms/abbreviations of three or more letters
1104 # 'Web.ABBREV' link:
1105 s/([\s\(])($regex{webNameRegex})\.($regex{abbrevRegex})/&internalLink($1,$2,$3,$3,"",0,1)/geo;
1106 # 'ABBREV' link:
1107 s/([\s\(])($regex{abbrevRegex})/&internalLink($1,$theWeb,$2,$2,"",0)/geo;
1108 # (deprecated <link> moved to DefaultPlugin)
1109
1110 s/$TranslationToken(\S.*?)$TranslationToken/$1/go;
1111 }
1112
1113 s/^\n//;
1114 rizwank 1.1 s/\t/ /g;
1115 $result .= $_;
1116
1117 } while( defined( $extraLines ) ); # extra lines produced by plugins
1118 }
1119 }
1120 if( $insideTABLE ) {
1121 $result .= "</table>\n";
1122 }
1123 $result .= &emitList( "", "", 0 );
1124 if( $insidePRE ) {
1125 $result .= "</pre>\n";
1126 }
1127
1128 # Wiki Plugin Hook
1129 &TWiki::Plugins::endRenderingHandler( $result );
1130
1131 $result = TWiki::putBackVerbatim( $result, "pre", @verbatim );
1132
1133 $result =~ s|\n?<nop>\n$||o; # clean up clutch
1134 return "$head$result";
1135 rizwank 1.1 }
1136
1137 =end twiki
1138
1139 =cut
1140
1141 1;
|
Return to
Render.pm
CVS log
Up to [RizwankCVS] / geekymedia_web / twiki / lib / TWiki