lib/TWiki/Render.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
permissions -rw-r--r--
RELEASE 4.2.0 freetown
colas@0
     1
# See bottom of file for license and copyright information
colas@0
     2
package TWiki::Render;
colas@0
     3
colas@0
     4
=pod
colas@0
     5
colas@0
     6
---+ package TWiki::Render
colas@0
     7
colas@0
     8
This module provides most of the actual HTML rendering code in TWiki.
colas@0
     9
colas@0
    10
=cut
colas@0
    11
colas@0
    12
use strict;
colas@0
    13
use Assert;
colas@0
    14
use Error qw(:try);
colas@0
    15
colas@0
    16
require TWiki::Time;
colas@0
    17
colas@0
    18
# Used to generate unique placeholders for when we lift blocks out of the
colas@0
    19
# text during rendering. 
colas@0
    20
use vars qw( $placeholderMarker );
colas@0
    21
$placeholderMarker = 0;
colas@0
    22
colas@0
    23
# defaults for trunctation of summary text
colas@0
    24
my $TMLTRUNC = 162;
colas@0
    25
my $PLAINTRUNC = 70;
colas@0
    26
my $MINTRUNC = 16;
colas@0
    27
# max number of lines in a summary (best to keep it even)
colas@0
    28
my $SUMMARYLINES = 6;
colas@0
    29
colas@0
    30
# limiting lookbehind and lookahead for wikiwords and emphasis
colas@0
    31
# use like \b
colas@0
    32
#SMELL: they really limit the number of places emphasis can happen.
colas@0
    33
my $STARTWW = qr/^|(?<=[\s\(])/m;
colas@0
    34
my $ENDWW = qr/$|(?=[\s,.;:!?)])/m;
colas@0
    35
colas@0
    36
# marker used to tage the start of a table
colas@0
    37
my $TABLEMARKER = "\0\1\2TABLE\2\1\0";
colas@0
    38
# Marker used to indicate table rows that are valid header/footer rows
colas@0
    39
my $TRMARK = "is\1all\1th";
colas@0
    40
colas@0
    41
BEGIN {
colas@0
    42
    # Do a dynamic 'use locale' for this module
colas@0
    43
    if( $TWiki::cfg{UseLocale} ) {
colas@0
    44
        require locale;
colas@0
    45
        import locale();
colas@0
    46
    }
colas@0
    47
}
colas@0
    48
colas@0
    49
=pod
colas@0
    50
colas@0
    51
---++ ClassMethod new ($session)
colas@0
    52
colas@0
    53
Creates a new renderer
colas@0
    54
colas@0
    55
=cut
colas@0
    56
colas@0
    57
sub new {
colas@0
    58
    my ( $class, $session ) = @_;
colas@0
    59
    my $this = bless( { session => $session }, $class );
colas@0
    60
colas@0
    61
    return $this;
colas@0
    62
}
colas@0
    63
colas@0
    64
=begin twiki
colas@0
    65
colas@0
    66
---++ ObjectMethod finish()
colas@0
    67
Break circular references.
colas@0
    68
colas@0
    69
=cut
colas@0
    70
colas@0
    71
# Note to developers; please undef *all* fields in the object explicitly,
colas@0
    72
# whether they are references or not. That way this method is "golden
colas@0
    73
# documentation" of the live fields in the object.
colas@0
    74
sub finish {
colas@0
    75
    my $this = shift;
colas@0
    76
    undef $this->{NEWLINKFORMAT};
colas@0
    77
    undef $this->{LINKTOOLTIPINFO};
colas@0
    78
    undef $this->{LIST};
colas@0
    79
    undef $this->{ffCache};
colas@0
    80
    undef $this->{session};
colas@0
    81
}
colas@0
    82
colas@0
    83
sub _newLinkFormat {
colas@0
    84
    my $this = shift;
colas@0
    85
    unless( $this->{NEWLINKFORMAT} ) {
colas@0
    86
        $this->{NEWLINKFORMAT} =
colas@0
    87
          $this->{session}->{prefs}->getPreferencesValue('NEWLINKFORMAT')
colas@0
    88
            || '<span class="twikiNewLink">$text<a href="%SCRIPTURLPATH{edit}%/$web/$topic?topicparent=%WEB%.%TOPIC%" '.
colas@0
    89
              'rel="nofollow" title="%MAKETEXT{"Create this topic"}%">'.
colas@0
    90
                '?</a></span>';
colas@0
    91
    }
colas@0
    92
    return $this->{NEWLINKFORMAT};
colas@0
    93
}
colas@0
    94
colas@0
    95
=pod
colas@0
    96
colas@0
    97
---++ ObjectMethod renderParent($web, $topic, $meta, $params) -> $text
colas@0
    98
colas@0
    99
Render parent meta-data
colas@0
   100
colas@0
   101
=cut
colas@0
   102
colas@0
   103
sub renderParent {
colas@0
   104
    my( $this, $web, $topic, $meta, $ah ) = @_;
colas@0
   105
    my $dontRecurse = $ah->{dontrecurse} || 0;
colas@0
   106
    my $noWebHome =   $ah->{nowebhome} || 0;
colas@0
   107
    my $prefix =      $ah->{prefix} || '';
colas@0
   108
    my $suffix =      $ah->{suffix} || '';
colas@0
   109
    my $usesep =      $ah->{separator} || ' &gt; ';
colas@0
   110
    my $format =      $ah->{format} || '[[$web.$topic][$topic]]';
colas@0
   111
colas@0
   112
    return '' unless $web && $topic;
colas@0
   113
colas@0
   114
    my %visited;
colas@0
   115
    $visited{$web.'.'.$topic} = 1;
colas@0
   116
colas@0
   117
    my $pWeb = $web;
colas@0
   118
    my $pTopic;
colas@0
   119
    my $text = '';
colas@0
   120
    my $parentMeta = $meta->get( 'TOPICPARENT' );
colas@0
   121
    my $parent;
colas@0
   122
    my $store = $this->{session}->{store};
colas@0
   123
colas@0
   124
    $parent = $parentMeta->{name} if $parentMeta;
colas@0
   125
colas@0
   126
    my @stack;
colas@0
   127
colas@0
   128
    while( $parent ) {
colas@0
   129
        ( $pWeb, $pTopic ) =
colas@0
   130
          $this->{session}->normalizeWebTopicName( $pWeb, $parent );
colas@0
   131
        $parent = $pWeb.'.'.$pTopic;
colas@0
   132
        last if( $noWebHome &&
colas@0
   133
                 ( $pTopic eq $TWiki::cfg{HomeTopicName} ) ||
colas@0
   134
                 $visited{$parent} );
colas@0
   135
        $visited{$parent} = 1;
colas@0
   136
        $text = $format;
colas@0
   137
        $text =~ s/\$web/$pWeb/g;
colas@0
   138
        $text =~ s/\$topic/$pTopic/g;
colas@0
   139
        unshift( @stack, $text );
colas@0
   140
        last if $dontRecurse;
colas@0
   141
        $parent = $store->getTopicParent( $pWeb, $pTopic );
colas@0
   142
    }
colas@0
   143
    $text = join( $usesep, @stack );
colas@0
   144
colas@0
   145
    if( $text) {
colas@0
   146
        $text = $prefix.$text if ( $prefix );
colas@0
   147
        $text .= $suffix if ( $suffix );
colas@0
   148
    }
colas@0
   149
colas@0
   150
    return $text;
colas@0
   151
}
colas@0
   152
colas@0
   153
=pod
colas@0
   154
colas@0
   155
---++ ObjectMethod renderMoved($web, $topic, $meta, $params) -> $text
colas@0
   156
colas@0
   157
Render moved meta-data
colas@0
   158
colas@0
   159
=cut
colas@0
   160
colas@0
   161
sub renderMoved {
colas@0
   162
    my( $this, $web, $topic, $meta, $params ) = @_;
colas@0
   163
    my $text = '';
colas@0
   164
    my $moved = $meta->get( 'TOPICMOVED' );
colas@0
   165
    $web =~ s#\.#/#go;
colas@0
   166
colas@0
   167
    if( $moved ) {
colas@0
   168
        my( $fromWeb, $fromTopic ) =
colas@0
   169
          $this->{session}->normalizeWebTopicName( $web, $moved->{from} );
colas@0
   170
        my( $toWeb, $toTopic ) =
colas@0
   171
          $this->{session}->normalizeWebTopicName( $web, $moved->{to} );
colas@0
   172
        my $by = $moved->{by};
colas@0
   173
        my $u = $by;
colas@0
   174
        my $users = $this->{session}->{users};
colas@0
   175
        $by = $users->webDotWikiName($u) if $u;
colas@0
   176
        my $date = TWiki::Time::formatTime( $moved->{date}, '', 'gmtime' );
colas@0
   177
colas@0
   178
        # Only allow put back if current web and topic match stored information
colas@0
   179
        my $putBack = '';
colas@0
   180
        if( $web eq $toWeb && $topic eq $toTopic ) {
colas@0
   181
            $putBack  = ' - '.
colas@0
   182
              CGI::a( { title=>($this->{session}->i18n->maketext(
colas@0
   183
                                  'Click to move topic back to previous location, with option to change references.')
colas@0
   184
                               ),
colas@0
   185
                        href => $this->{session}->getScriptUrl
colas@0
   186
                        ( 0, 'rename', $web, $topic,
colas@0
   187
                         newweb => $fromWeb,
colas@0
   188
                         newtopic => $fromTopic,
colas@0
   189
                         confirm => 'on',
colas@0
   190
                         nonwikiword => 'checked' ),
colas@0
   191
                        rel => 'nofollow'
colas@0
   192
                      },
colas@0
   193
                      $this->{session}->i18n->maketext('put it back') );
colas@0
   194
        }
colas@0
   195
        $text = CGI::i(
colas@0
   196
          $this->{session}->i18n->maketext("[_1] moved from [_2] on [_3] by [_4]",
colas@0
   197
                                             "<nop>$toWeb.<nop>$toTopic",
colas@0
   198
                                             "<nop>$fromWeb.<nop>$fromTopic",
colas@0
   199
                                             $date,
colas@0
   200
                                             $by)) . $putBack;
colas@0
   201
    }
colas@0
   202
    return $text;
colas@0
   203
}
colas@0
   204
colas@0
   205
# Add a list item, of the given type and indent depth. The list item may
colas@0
   206
# cause the opening or closing of lists currently being handled.
colas@0
   207
sub _addListItem {
colas@0
   208
    my( $this, $result, $type, $element, $indent ) = @_;
colas@0
   209
colas@0
   210
    $indent =~ s/   /\t/g;
colas@0
   211
    my $depth = length( $indent );
colas@0
   212
colas@0
   213
    my $size = scalar( @{$this->{LIST}} );
colas@0
   214
colas@0
   215
    # The whitespaces either side of the tags are required for the
colas@0
   216
    # emphasis REs to work.
colas@0
   217
    if( $size < $depth ) {
colas@0
   218
        my $firstTime = 1;
colas@0
   219
        while( $size < $depth ) {
colas@0
   220
            push( @{$this->{LIST}}, { type=>$type, element=>$element } );
colas@0
   221
            push @$result, ' <'.$element.">\n" unless( $firstTime );
colas@0
   222
            push @$result, ' <'.$type.">\n";
colas@0
   223
            $firstTime = 0;
colas@0
   224
            $size++;
colas@0
   225
        }
colas@0
   226
    } else {
colas@0
   227
        while( $size > $depth ) {
colas@0
   228
            my $tags = pop( @{$this->{LIST}} );
colas@0
   229
            push @$result, "\n</".$tags->{element}.'></'.$tags->{type}.'> ';
colas@0
   230
            $size--;
colas@0
   231
        }
colas@0
   232
        if( $size ) {
colas@0
   233
            push @$result, "\n</".$this->{LIST}->[$size-1]->{element}.'> ';
colas@0
   234
        } else {
colas@0
   235
            push @$result, "\n";
colas@0
   236
        }
colas@0
   237
    }
colas@0
   238
colas@0
   239
    if ( $size ) {
colas@0
   240
        my $oldt = $this->{LIST}->[$size-1];
colas@0
   241
        if( $oldt->{type} ne $type ) {
colas@0
   242
            push @$result, ' </'.$oldt->{type}.'><'.$type.">\n";
colas@0
   243
            pop( @{$this->{LIST}} );
colas@0
   244
            push( @{$this->{LIST}}, { type=>$type, element=>$element } );
colas@0
   245
        }
colas@0
   246
    }
colas@0
   247
}
colas@0
   248
colas@0
   249
# Given that we have just seen the end of a table, work out the thead,
colas@0
   250
# tbody and tfoot sections
colas@0
   251
sub _addTHEADandTFOOT {
colas@0
   252
    my( $lines ) = @_;
colas@0
   253
    # scan back to the head of the table
colas@0
   254
    my $i = scalar( @$lines ) - 1;
colas@0
   255
    my @thRows;
colas@0
   256
    my $inFoot = 1;
colas@0
   257
    my $footLines = 0;
colas@0
   258
    my $headLines = 0;
colas@0
   259
    while( $i >= 0 && $lines->[$i] ne $TABLEMARKER ) {
colas@0
   260
        if( $lines->[$i] =~ /^\s*$/ ) {
colas@0
   261
            # Remove blank lines in tables; they generate spurious <p>'s
colas@0
   262
            splice( @$lines, $i, 1 );
colas@0
   263
        }
colas@0
   264
        elsif( $lines->[$i] =~ s/$TRMARK=(["'])(.*?)\1//i) {
colas@0
   265
            if( $2 ) {
colas@0
   266
                if( $inFoot ) {
colas@0
   267
                    $footLines++;
colas@0
   268
                } else {
colas@0
   269
                    $headLines++;
colas@0
   270
                }
colas@0
   271
            } else {
colas@0
   272
                $inFoot = 0;
colas@0
   273
                $headLines = 0;
colas@0
   274
            }
colas@0
   275
        }
colas@0
   276
        $i--;
colas@0
   277
    }
colas@0
   278
    $lines->[$i] = CGI::start_table(
colas@0
   279
        { class=>'twikiTable',
colas@0
   280
          border => 1, cellspacing => 0, cellpadding => 0 });
colas@0
   281
    if( $footLines && !$headLines) {
colas@0
   282
        $headLines = $footLines;
colas@0
   283
        $footLines = 0;
colas@0
   284
    }
colas@0
   285
    if( $footLines ) {
colas@0
   286
        push( @$lines, '</tfoot>');
colas@0
   287
        my $firstFoot = scalar( @$lines ) - $footLines;
colas@0
   288
        splice( @$lines, $firstFoot, 0, '</tbody><tfoot>');
colas@0
   289
    } else {
colas@0
   290
        push( @$lines, '</tbody>');
colas@0
   291
    }
colas@0
   292
    if( $headLines ) {
colas@0
   293
        splice( @$lines, $i + 1 + $headLines, 0, '</thead><tbody>');
colas@0
   294
        splice( @$lines, $i + 1, 0, '<thead>');
colas@0
   295
    } else {
colas@0
   296
        splice( @$lines, $i + 1, 0, '<tbody>');
colas@0
   297
    }
colas@0
   298
}
colas@0
   299
colas@0
   300
sub _emitTR {
colas@0
   301
    my ( $this, $theRow ) = @_;
colas@0
   302
colas@0
   303
    $theRow =~ s/\t/   /g;  # change tabs to space
colas@0
   304
    $theRow =~ s/\s*$//;    # remove trailing spaces
colas@0
   305
    $theRow =~ s/(\|\|+)/'colspan'.$TWiki::TranslationToken.length($1).'|'/ge;  # calc COLSPAN
colas@0
   306
    my $cells = '';
colas@0
   307
    my $containsTableHeader;
colas@0
   308
    my $isAllTH = 1;
colas@0
   309
    foreach( split( /\|/, $theRow ) ) {
colas@0
   310
        my @attr;
colas@0
   311
colas@0
   312
        # Avoid matching single columns
colas@0
   313
        if ( s/colspan$TWiki::TranslationToken([0-9]+)//o ) {
colas@0
   314
            push( @attr, colspan => $1 );
colas@0
   315
        }
colas@0
   316
        s/^\s+$/ &nbsp; /;
colas@0
   317
        my( $l1, $l2 ) = ( 0, 0 );
colas@0
   318
        if( /^(\s*).*?(\s*)$/ ) {
colas@0
   319
            $l1 = length( $1 );
colas@0
   320
            $l2 = length( $2 );
colas@0
   321
        }
colas@0
   322
        if( $l1 >= 2 ) {
colas@0
   323
            if( $l2 <= 1 ) {
colas@0
   324
                push( @attr, align => 'right' );
colas@0
   325
            } else {
colas@0
   326
                push( @attr, align => 'center' );
colas@0
   327
            }
colas@0
   328
        }
colas@0
   329
        if( /^\s*\*(.*)\*\s*$/ ) {
colas@0
   330
            $cells .= CGI::th( { @attr }, CGI::strong( " $1 " ))."\n";
colas@0
   331
        } else {
colas@0
   332
            $cells .= CGI::td( { @attr }, " $_ " )."\n";
colas@0
   333
            $isAllTH = 0;
colas@0
   334
        }
colas@0
   335
    }
colas@0
   336
    return CGI::Tr({ $TRMARK => $isAllTH }, $cells );
colas@0
   337
}
colas@0
   338
colas@0
   339
sub _fixedFontText {
colas@0
   340
    my( $theText, $theDoBold ) = @_;
colas@0
   341
    # preserve white space, so replace it by '&nbsp; ' patterns
colas@0
   342
    $theText =~ s/\t/   /g;
colas@0
   343
    $theText =~ s|((?:[\s]{2})+)([^\s])|'&nbsp; ' x (length($1) / 2) . $2|eg;
colas@0
   344
    $theText = CGI::b( $theText ) if $theDoBold;
colas@0
   345
    return CGI::code( $theText );
colas@0
   346
}
colas@0
   347
colas@0
   348
# Build an HTML &lt;Hn> element with suitable anchor for linking from %<nop>TOC%
colas@0
   349
sub _makeAnchorHeading {
colas@0
   350
    my( $this, $text, $theLevel ) = @_;
colas@0
   351
colas@0
   352
    $text =~ s/^\s*(.*?)\s*$/$1/;
colas@0
   353
colas@0
   354
    # - Build '<nop><h1><a name='atext'></a> heading </h1>' markup
colas@0
   355
    # - Initial '<nop>' is needed to prevent subsequent matches.
colas@0
   356
    # - filter out $TWiki::regex{headerPatternNoTOC} ( '!!' and '%NOTOC%' )
colas@0
   357
    my $anchorName =       $this->makeAnchorName( $text, 0 );
colas@0
   358
    my $compatAnchorName = $this->makeAnchorName( $text, 1 );
colas@0
   359
    # filter '!!', '%NOTOC%'
colas@0
   360
    $text =~ s/$TWiki::regex{headerPatternNoTOC}//o;
colas@0
   361
    my $html = '<nop><h'.$theLevel.'>';
colas@0
   362
    $html .= CGI::a( { name => $anchorName }, '' );
colas@0
   363
    $html .= CGI::a( { name => $compatAnchorName }, '')
colas@0
   364
      if( $compatAnchorName ne $anchorName );
colas@0
   365
    $html .= ' '.$text.' </h'.$theLevel.'>';
colas@0
   366
colas@0
   367
    return $html;
colas@0
   368
}
colas@0
   369
colas@0
   370
=pod
colas@0
   371
colas@0
   372
---++ ObjectMethod makeAnchorName($anchorName, $compatibilityMode) -> $anchorName
colas@0
   373
colas@0
   374
   * =$anchorName= - the unprocessed anchor name
colas@0
   375
   * =$compatibilityMode= - SMELL: compatibility with *what*?? Who knows. :-(
colas@0
   376
colas@0
   377
Build a valid HTML anchor name
colas@0
   378
colas@0
   379
=cut
colas@0
   380
colas@0
   381
sub makeAnchorName {
colas@0
   382
    my( $this, $anchorName, $compatibilityMode ) = @_;
colas@0
   383
colas@0
   384
    if( !$compatibilityMode &&
colas@0
   385
          $anchorName =~ /^$TWiki::regex{anchorRegex}$/ ) {
colas@0
   386
        # accept, already valid -- just remove leading #
colas@0
   387
        return substr($anchorName, 1);
colas@0
   388
    }
colas@0
   389
colas@0
   390
    # strip out potential links so they don't get rendered.
colas@0
   391
    # remove double bracket link
colas@0
   392
    $anchorName =~ s/\[(?:\[.*?\])?\[(.*?)\]\s*\]/$1/g;
colas@0
   393
    # add an _ before bare WikiWords
colas@0
   394
    $anchorName =~ s/($TWiki::regex{wikiWordRegex})/_$1/go;
colas@0
   395
colas@0
   396
    if( $compatibilityMode ) {
colas@0
   397
        # remove leading/trailing underscores first, allowing them to be
colas@0
   398
        # reintroduced
colas@0
   399
        $anchorName =~ s/^[\s#_]*//;
colas@0
   400
        $anchorName =~ s/[\s_]*$//;
colas@0
   401
    }
colas@0
   402
    $anchorName =~ s/<\/?[a-zA-Z][^>]*>//gi;  # remove HTML tags
colas@0
   403
    $anchorName =~ s/&#?[a-zA-Z0-9]+;//g; # remove HTML entities
colas@0
   404
    $anchorName =~ s/&//g;                # remove &
colas@0
   405
    # filter TOC excludes if not at beginning
colas@0
   406
    $anchorName =~ s/^(.+?)\s*$TWiki::regex{headerPatternNoTOC}.*/$1/o;
colas@0
   407
    # filter '!!', '%NOTOC%'
colas@0
   408
    $anchorName =~ s/$TWiki::regex{headerPatternNoTOC}//o;
colas@0
   409
colas@0
   410
    # For most common alphabetic-only character encodings (i.e. iso-8859-*),
colas@0
   411
    # remove non-alpha characters 
colas@0
   412
    if( !defined($TWiki::cfg{Site}{CharSet}) ||
colas@0
   413
          $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?/i ) {
colas@0
   414
        $anchorName =~ s/[^$TWiki::regex{mixedAlphaNum}]+/_/g;
colas@0
   415
    }
colas@0
   416
    $anchorName =~ s/__+/_/g;           # remove excessive '_' chars
colas@0
   417
    if ( !$compatibilityMode ) {
colas@0
   418
        $anchorName =~ s/^[\s#_]+//;  # no leading space nor '#', '_'
colas@0
   419
    }
colas@0
   420
    $anchorName =~ s/^(.{32})(.*)$/$1/; # limit to 32 chars - FIXME: Use Unicode chars before truncate
colas@0
   421
    if ( !$compatibilityMode ) {
colas@0
   422
        $anchorName =~ s/[\s_]+$//;    # no trailing space, nor '_'
colas@0
   423
    }
colas@0
   424
colas@0
   425
    # No need to encode 8-bit characters in anchor due to UTF-8 URL support
colas@0
   426
colas@0
   427
    return $anchorName;
colas@0
   428
}
colas@0
   429
colas@0
   430
# Returns =title='...'= tooltip info in case LINKTOOLTIPINFO perferences variable is set. 
colas@0
   431
# Warning: Slower performance if enabled.
colas@0
   432
sub _linkToolTipInfo {
colas@0
   433
    my( $this, $theWeb, $theTopic ) = @_;
colas@0
   434
    unless( defined( $this->{LINKTOOLTIPINFO} )) {
colas@0
   435
        $this->{LINKTOOLTIPINFO} =
colas@0
   436
          $this->{session}->{prefs}->getPreferencesValue('LINKTOOLTIPINFO')
colas@0
   437
            || '';
colas@0
   438
        $this->{LINKTOOLTIPINFO} = '$username - $date - r$rev: $summary'
colas@0
   439
          if( TWiki::isTrue( $this->{LINKTOOLTIPINFO} ));
colas@0
   440
    }
colas@0
   441
    return '' unless( $this->{LINKTOOLTIPINFO} );
colas@0
   442
    return '' if( $this->{LINKTOOLTIPINFO} =~ /^off$/i );
colas@0
   443
    return '' unless( $this->{session}->inContext( 'view' ));
colas@0
   444
colas@0
   445
    # FIXME: This is slow, it can be improved by caching topic rev info and summary
colas@0
   446
    my $store = $this->{session}->{store};
colas@0
   447
    my $users = $this->{session}->{users};
colas@0
   448
    # SMELL: we ought not to have to fake this. Topic object model, please!!
colas@0
   449
    require TWiki::Meta;
colas@0
   450
    my $meta = new TWiki::Meta( $this->{session}, $theWeb, $theTopic );
colas@0
   451
    my( $date, $user, $rev ) = $meta->getRevisionInfo();
colas@0
   452
    my $text = $this->{LINKTOOLTIPINFO};
colas@0
   453
    $text =~ s/\$web/<nop>$theWeb/g;
colas@0
   454
    $text =~ s/\$topic/<nop>$theTopic/g;
colas@0
   455
    $text =~ s/\$rev/1.$rev/g;
colas@0
   456
    $text =~ s/\$date/TWiki::Time::formatTime( $date )/ge;
colas@0
   457
    $text =~ s/\$username/$users->getLoginName($user)/ge;       # 'jsmith'
colas@0
   458
    $text =~ s/\$wikiname/$users->getWikiName($user)/ge;  # 'JohnSmith'
colas@0
   459
    $text =~ s/\$wikiusername/$users->webDotWikiName($user)/ge; # 'Main.JohnSmith'
colas@0
   460
    if( $text =~ /\$summary/ ) {
colas@0
   461
        my $summary = $store->readTopicRaw
colas@0
   462
          ( undef, $theWeb, $theTopic, undef );
colas@0
   463
        $summary = $this->makeTopicSummary( $summary, $theTopic, $theWeb );
colas@0
   464
        $summary =~ s/[\"\']//g;       # remove quotes (not allowed in title attribute)
colas@0
   465
        $text =~ s/\$summary/$summary/g;
colas@0
   466
    }
colas@0
   467
    return $text;
colas@0
   468
}
colas@0
   469
colas@0
   470
=pod
colas@0
   471
colas@0
   472
---++ ObjectMethod internalLink ( $theWeb, $theTopic, $theLinkText, $theAnchor, $doLink, $doKeepWeb, $hasExplicitLinkLabel ) -> $html
colas@0
   473
colas@0
   474
Generate a link. 
colas@0
   475
colas@0
   476
Note: Topic names may be spaced out. Spaced out names are converted to <nop>WikWords,
colas@0
   477
for example, "spaced topic name" points to "SpacedTopicName".
colas@0
   478
   * =$theWeb= - the web containing the topic
colas@0
   479
   * =$theTopic= - the topic to be link
colas@0
   480
   * =$theLinkText= - text to use for the link
colas@0
   481
   * =$theAnchor= - the link anchor, if any
colas@0
   482
   * =$doLinkToMissingPages= - boolean: false means suppress link for non-existing pages
colas@0
   483
   * =$doKeepWeb= - boolean: true to keep web prefix (for non existing Web.TOPIC)
colas@0
   484
   * =$hasExplicitLinkLabel= - boolean: true in case of [[TopicName][explicit link label]] 
colas@0
   485
colas@0
   486
Called by _handleWikiWord and _handleSquareBracketedLink and by Func::internalLink
colas@0
   487
colas@0
   488
Calls _renderWikiWord, which in turn will use Plurals.pm to match fold plurals to equivalency with their singular form 
colas@0
   489
colas@0
   490
SMELL: why is this available to Func?
colas@0
   491
colas@0
   492
=cut
colas@0
   493
colas@0
   494
sub internalLink {
colas@0
   495
    my( $this, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLinkToMissingPages, $doKeepWeb, $hasExplicitLinkLabel ) = @_;
colas@0
   496
    # SMELL - shouldn't it be callable by TWiki::Func as well?
colas@0
   497
colas@0
   498
    #PN: Webname/Subweb/ -> Webname/Subweb
colas@0
   499
    $theWeb =~ s/\/\Z//o;
colas@0
   500
colas@0
   501
    if($theLinkText eq $theWeb) {
colas@0
   502
      $theLinkText =~ s/\//\./go;
colas@0
   503
    }
colas@0
   504
colas@0
   505
    #WebHome links to tother webs render as the WebName
colas@0
   506
    if (($theLinkText eq $TWiki::cfg{HomeTopicName}) && 
colas@0
   507
        ($theWeb ne $this->{session}->{webName})) {
colas@0
   508
            $theLinkText = $theWeb;
colas@0
   509
    }
colas@0
   510
    
colas@0
   511
    # Get rid of leading/trailing spaces in topic name
colas@0
   512
    $theTopic =~ s/^\s*//o;
colas@0
   513
    $theTopic =~ s/\s*$//o;
colas@0
   514
colas@0
   515
    # Allow spacing out, etc.
colas@0
   516
    # Plugin authors use $hasExplicitLinkLabel to determine if the link label
colas@0
   517
    # should be rendered differently even if the topic author has used a
colas@0
   518
    # specific link label.
colas@0
   519
    $theLinkText = $this->{session}->{plugins}->renderWikiWordHandler( $theLinkText, $hasExplicitLinkLabel, $theWeb, $theTopic ) || $theLinkText;
colas@0
   520
    
colas@0
   521
    # Turn spaced-out names into WikiWords - upper case first letter of
colas@0
   522
    # whole link, and first of each word. TODO: Try to turn this off,
colas@0
   523
    # avoiding spaces being stripped elsewhere
colas@0
   524
    $theTopic =~ s/^(.)/\U$1/;
colas@0
   525
    $theTopic =~ s/\s([$TWiki::regex{mixedAlphaNum}])/\U$1/go;
colas@0
   526
colas@0
   527
    # Add <nop> before WikiWord inside link text to prevent double links
colas@0
   528
    $theLinkText =~ s/(?<=[\s\(])([$TWiki::regex{upperAlpha}])/<nop>$1/go;
colas@0
   529
    
colas@0
   530
    return _renderWikiWord($this, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLinkToMissingPages, $doKeepWeb);
colas@0
   531
}
colas@0
   532
colas@0
   533
# TODO: this should be overridable by plugins.
colas@0
   534
sub _renderWikiWord {
colas@0
   535
    my ($this, $theWeb, $theTopic, $theLinkText, $theAnchor, $doLinkToMissingPages, $doKeepWeb) = @_;
colas@0
   536
    my $store = $this->{session}->{store};
colas@0
   537
    my $topicExists = $store->topicExists( $theWeb, $theTopic );
colas@0
   538
colas@0
   539
    my $singular = '';
colas@0
   540
    unless( $topicExists ) {
colas@0
   541
        # topic not found - try to singularise
colas@0
   542
        require TWiki::Plurals;
colas@0
   543
        $singular = TWiki::Plurals::singularForm($theWeb, $theTopic);
colas@0
   544
        if( $singular ) {
colas@0
   545
            $topicExists = $store->topicExists( $theWeb, $singular );
colas@0
   546
            $theTopic = $singular if $topicExists;
colas@0
   547
        }
colas@0
   548
    }
colas@0
   549
colas@0
   550
    if( $topicExists) {
colas@0
   551
        return _renderExistingWikiWord($this, $theWeb,
colas@0
   552
                                       $theTopic, $theLinkText, $theAnchor);
colas@0
   553
    }
colas@0
   554
    if( $doLinkToMissingPages ) {
colas@0
   555
        # CDot: disabled until SuggestSingularNotPlural is resolved
colas@0
   556
        # if ($singular && $singular ne $theTopic) {
colas@0
   557
        #     #unshift( @topics, $singular);
colas@0
   558
        # }
colas@0
   559
        return _renderNonExistingWikiWord($this, $theWeb, $theTopic,
colas@0
   560
                                          $theLinkText);
colas@0
   561
    }
colas@0
   562
    if( $doKeepWeb ) {
colas@0
   563
        return $theWeb.'.'.$theLinkText;
colas@0
   564
    }
colas@0
   565
colas@0
   566
    return $theLinkText;
colas@0
   567
}
colas@0
   568
colas@0
   569
sub _renderExistingWikiWord {
colas@0
   570
    my ($this, $web, $topic, $text, $anchor) = @_;
colas@0
   571
colas@0
   572
    my $currentWebHome = '';
colas@0
   573
    $currentWebHome = 'twikiCurrentWebHomeLink ' if (($web eq $this->{session}->{webName}) &&
colas@0
   574
                                      ($topic eq $TWiki::cfg{HomeTopicName} ));
colas@0
   575
colas@0
   576
    my $currentTopic = '';
colas@0
   577
    $currentTopic = 'twikiCurrentTopicLink ' if (($web eq $this->{session}->{webName}) &&
colas@0
   578
                                       ($topic eq $this->{session}->{topicName}));
colas@0
   579
colas@0
   580
    my @attrs;
colas@0
   581
    my $href = $this->{session}->getScriptUrl( 0, 'view', $web, $topic );
colas@0
   582
    if( $anchor ) {
colas@0
   583
        $anchor = $this->makeAnchorName( $anchor );
colas@0
   584
        push( @attrs, class => $currentTopic.$currentWebHome.'twikiAnchorLink', href => $href.'#'.$anchor );
colas@0
   585
    } else {
colas@0
   586
        push( @attrs, class => $currentTopic.$currentWebHome.'twikiLink', href => $href );
colas@0
   587
    }
colas@0
   588
    my $tooltip = _linkToolTipInfo( $this, $web, $topic );
colas@0
   589
    push( @attrs, title => $tooltip ) if( $tooltip );
colas@0
   590
    
colas@0
   591
    my $link = CGI::a( { @attrs }, $text );
colas@0
   592
    # When we pass the tooltip text to CGI::a it may contain
colas@0
   593
    # <nop>s, and CGI::a will convert the < to &lt;. This is a
colas@0
   594
    # basic problem with <nop>.
colas@0
   595
    $link =~ s/&lt;nop&gt;/<nop>/g;
colas@0
   596
    return $link;
colas@0
   597
}
colas@0
   598
colas@0
   599
sub _renderNonExistingWikiWord {
colas@0
   600
    my ($this, $web, $topic, $text) = @_;
colas@0
   601
colas@0
   602
    my $ans = $this->_newLinkFormat;
colas@0
   603
    $ans =~ s/\$web/$web/g;
colas@0
   604
    $ans =~ s/\$topic/$topic/g;
colas@0
   605
    $ans =~ s/\$text/$text/g;
colas@0
   606
    $ans = $this->{session}->handleCommonTags(
colas@0
   607
        $ans, $this->{session}{webName}, $this->{session}{topicName});
colas@0
   608
    return $ans;
colas@0
   609
}
colas@0
   610
colas@0
   611
# _handleWikiWord is called by the TWiki Render routine when it sees a 
colas@0
   612
# wiki word that needs linking.
colas@0
   613
# Handle the various link constructions. e.g.:
colas@0
   614
# WikiWord
colas@0
   615
# Web.WikiWord
colas@0
   616
# Web.WikiWord#anchor
colas@0
   617
#
colas@0
   618
# This routine adds missing parameters before passing off to internallink
colas@0
   619
sub _handleWikiWord {
colas@0
   620
    my ( $this, $theWeb, $web, $topic, $anchor ) = @_;
colas@0
   621
colas@0
   622
    my $linkIfAbsent = 1;
colas@0
   623
    my $keepWeb = 0;
colas@0
   624
    my $text;
colas@0
   625
colas@0
   626
    $web = $theWeb unless (defined($web));
colas@0
   627
    if( defined( $anchor )) {
colas@0
   628
        ASSERT(($anchor =~ m/\#.*/)) if DEBUG; # must include a hash.
colas@0
   629
    } else {
colas@0
   630
        $anchor = '' ;
colas@0
   631
    }
colas@0
   632
colas@0
   633
    if ( defined( $anchor ) ) {
colas@0
   634
        # 'Web.TopicName#anchor' or 'Web.ABBREV#anchor' link
colas@0
   635
        $text = $topic.$anchor;
colas@0
   636
    } else {
colas@0
   637
        $anchor = '';
colas@0
   638
colas@0
   639
        # 'Web.TopicName' or 'Web.ABBREV' link:
colas@0
   640
        if ( $topic eq $TWiki::cfg{HomeTopicName} &&
colas@0
   641
             $web ne $this->{session}->{webName} ) {
colas@0
   642
            $text = $web;
colas@0
   643
        } else {
colas@0
   644
            $text = $topic;
colas@0
   645
        }
colas@0
   646
    }
colas@0
   647
colas@0
   648
    # =$doKeepWeb= boolean: true to keep web prefix (for non existing Web.TOPIC)
colas@0
   649
    # (Necessary to leave "web part" of ABR.ABR.ABR intact if topic not found)
colas@0
   650
    $keepWeb = ( $topic =~ /^$TWiki::regex{abbrevRegex}$/o && $web ne $this->{session}->{webName} );
colas@0
   651
colas@0
   652
    # false means suppress link for non-existing pages
colas@0
   653
    $linkIfAbsent = ( $topic !~ /^$TWiki::regex{abbrevRegex}$/o );
colas@0
   654
colas@0
   655
    # SMELL - it seems $linkIfAbsent, $keepWeb are always inverses of each
colas@0
   656
    # other
colas@0
   657
    # TODO: check the spec of doKeepWeb vs $doLinkToMissingPages
colas@0
   658
colas@0
   659
    return $this->internalLink( $web, $topic, $text, $anchor,
colas@0
   660
                                $linkIfAbsent, $keepWeb, undef );
colas@0
   661
}
colas@0
   662
colas@0
   663
colas@0
   664
# Handle SquareBracketed links mentioned on page $theWeb.$theTopic
colas@0
   665
# format: [[$link]]
colas@0
   666
# format: [[$link][$text]]
colas@0
   667
sub _handleSquareBracketedLink {
colas@0
   668
    my( $this, $web, $topic, $link, $text ) = @_;
colas@0
   669
   
colas@0
   670
    # Strip leading/trailing spaces
colas@0
   671
    $link =~ s/^\s+//;
colas@0
   672
    $link =~ s/\s+$//;
colas@0
   673
colas@0
   674
    my $hasExplicitLinkLabel = $text ? 1 : undef;
colas@0
   675
colas@0
   676
    # Explicit external [[$link][$text]]-style can be handled directly
colas@0
   677
    if( $link =~ m!^($TWiki::regex{linkProtocolPattern}\:|/)! ) {
colas@0
   678
        if (defined $text) {
colas@0
   679
            # [[][]] style - protect text:
colas@0
   680
            # Prevent automatic WikiWord or CAPWORD linking in explicit links
colas@0
   681
            $text =~ s/(?<=[\s\(])($TWiki::regex{wikiWordRegex}|[$TWiki::regex{upperAlpha}])/<nop>$1/go;
colas@0
   682
        }
colas@0
   683
        else {
colas@0
   684
            # [[]] style - take care for legacy:
colas@0
   685
            # Prepare special case of '[[URL#anchor display text]]' link
colas@0
   686
            if ( $link =~ /^(\S+)\s+(.*)$/ ) {
colas@0
   687
                # '[[URL#anchor display text]]' link:
colas@0
   688
                $link = $1;
colas@0
   689
                $text = $2;
colas@0
   690
                $text =~ s/(?<=[\s\(])($TWiki::regex{wikiWordRegex}|[$TWiki::regex{upperAlpha}])/<nop>$1/go;
colas@0
   691
            }
colas@0
   692
        }
colas@0
   693
        return _externalLink( $this, $link, $text );
colas@0
   694
    }
colas@0
   695
colas@0
   696
    $text ||= $link;
colas@0
   697
colas@0
   698
    # Extract '#anchor'
colas@0
   699
    # $link =~ s/(\#[a-zA-Z_0-9\-]*$)//;
colas@0
   700
    my $anchor = '';
colas@0
   701
    if( $link =~ s/($TWiki::regex{anchorRegex}$)// ) {
colas@0
   702
        $anchor = $1;
colas@0
   703
    }
colas@0
   704
colas@0
   705
    # filter out &any; entities (legacy)
colas@0
   706
    $link =~ s/\&[a-z]+\;//gi;
colas@0
   707
    # filter out &#123; entities (legacy)
colas@0
   708
    $link =~ s/\&\#[0-9]+\;//g;
colas@0
   709
    # Filter junk
colas@0
   710
    $link =~ s/$TWiki::cfg{NameFilter}+/ /g;
colas@0
   711
    # Capitalise first word
colas@0
   712
    $link =~ s/^(.)/\U$1/;
colas@0
   713
    # Collapse spaces and capitalise following letter
colas@0
   714
    $link =~ s/\s([$TWiki::regex{mixedAlphaNum}])/\U$1/go;
colas@0
   715
    # Get rid of remaining spaces, i.e. spaces in front of -'s and ('s
colas@0
   716
    $link =~ s/\s//go;
colas@0
   717
colas@0
   718
    $topic = $link if( $link );
colas@0
   719
colas@0
   720
    # Topic defaults to the current topic
colas@0
   721
    ($web, $topic) = $this->{session}->normalizeWebTopicName( $web, $topic );
colas@0
   722
colas@0
   723
    return $this->internalLink( $web, $topic, $text, $anchor, 1, undef, $hasExplicitLinkLabel );
colas@0
   724
}
colas@0
   725
colas@0
   726
# Handle an external link typed directly into text. If it's an image
colas@0
   727
# (as indicated by the file type), and no text is specified, then use
colas@0
   728
# an img tag, otherwise generate a link.
colas@0
   729
sub _externalLink {
colas@0
   730
    my( $this, $url, $text ) = @_;
colas@0
   731
colas@0
   732
    if( $url =~ /^[^?]*\.(gif|jpg|jpeg|png)$/i && !$text) {
colas@0
   733
        my $filename = $url;
colas@0
   734
        $filename =~ s@.*/([^/]*)@$1@go;
colas@0
   735
        return CGI::img( { src => $url, alt => $filename } );
colas@0
   736
    }
colas@0
   737
    my $opt = '';
colas@0
   738
    if( $url =~ /^mailto:/i ) {
colas@0
   739
        if( $TWiki::cfg{AntiSpam}{EmailPadding} ) {
colas@0
   740
            $url =~  s/(\@[\w\_\-\+]+)(\.)/$1$TWiki::cfg{AntiSpam}{EmailPadding}$2/;
colas@0
   741
            if ($text) {
colas@0
   742
                $text =~ s/(\@[\w\_\-\+]+)(\.)/$1$TWiki::cfg{AntiSpam}{EmailPadding}$2/;
colas@0
   743
            }
colas@0
   744
        }
colas@0
   745
        if( $TWiki::cfg{AntiSpam}{HideUserDetails} ) {
colas@0
   746
            # Much harder obfuscation scheme. For link text we only encode '@'
colas@0
   747
            # See also Item2928 and Item3430 before touching this
colas@0
   748
            $url =~ s/(\W)/'&#'.ord($1).';'/ge;
colas@0
   749
            if ($text) {
colas@0
   750
                $text =~ s/\@/'&#'.ord('@').';'/ge;
colas@0
   751
            }
colas@0
   752
        }
colas@0
   753
    } else {
colas@0
   754
        $opt = ' target="_top"';
colas@0
   755
    }
colas@0
   756
    $text ||= $url;
colas@0
   757
    # SMELL: Can't use CGI::a here, because it encodes ampersands in
colas@0
   758
    # the link, and those have already been encoded once in the
colas@0
   759
    # rendering loop (they are identified as "stand-alone"). One
colas@0
   760
    # encoding works; two is too many. None would be better for everyone!
colas@0
   761
    return '<a href="'.$url.'"'.$opt.'>'.$text.'</a>';
colas@0
   762
}
colas@0
   763
colas@0
   764
# Generate a "mailTo" link
colas@0
   765
sub _mailLink {
colas@0
   766
    my( $this, $text ) = @_;
colas@0
   767
colas@0
   768
    my $url = $text;
colas@0
   769
    $url = 'mailto:'.$url unless $url =~ /^mailto:/i;
colas@0
   770
    return _externalLink( $this, $url, $text );
colas@0
   771
}
colas@0
   772
colas@0
   773
=pod
colas@0
   774
colas@0
   775
---++ ObjectMethod renderFORMFIELD ( %params, $topic, $web ) -> $html
colas@0
   776
colas@0
   777
Returns the fully rendered expansion of a %FORMFIELD{}% tag.
colas@0
   778
colas@0
   779
=cut
colas@0
   780
colas@0
   781
sub renderFORMFIELD {
colas@0
   782
    my ( $this, $params, $topic, $web ) = @_;
colas@0
   783
colas@0
   784
    my $formField = $params->{_DEFAULT};
colas@0
   785
    my $formTopic = $params->{topic};
colas@0
   786
    my $altText   = $params->{alttext};
colas@0
   787
    my $default   = $params->{default};
colas@0
   788
    my $rev       = $params->{rev};
colas@0
   789
    my $format    = $params->{'format'};
colas@0
   790
colas@0
   791
    unless ( $format ) {
colas@0
   792
        # if null format explicitly set, return empty
colas@0
   793
        # SMELL: it's not clear what this does; the implication
colas@0
   794
        # is that it does something that violates TWiki tag syntax,
colas@0
   795
        # so I've had to comment it out....
colas@0
   796
        # return '' if ( $args =~ m/format\s*=/o);
colas@0
   797
        # Otherwise default to value
colas@0
   798
        $format = '$value';
colas@0
   799
    }
colas@0
   800
colas@0
   801
    my $formWeb;
colas@0
   802
    if ( $formTopic ) {
colas@0
   803
        if ($topic =~ /^([^.]+)\.([^.]+)/o) {
colas@0
   804
            ( $formWeb, $topic ) = ( $1, $2 );
colas@0
   805
        } else {
colas@0
   806
            # SMELL: Undocumented feature, 'web' parameter
colas@0
   807
            $formWeb = $params->{web};
colas@0
   808
        }
colas@0
   809
        $formWeb = $web unless $formWeb;
colas@0
   810
    } else {
colas@0
   811
        $formWeb = $web;
colas@0
   812
        $formTopic = $topic;
colas@0
   813
    }
colas@0
   814
colas@0
   815
    my $meta = $this->{ffCache}{$formWeb.'.'.$formTopic};
colas@0
   816
    my $store = $this->{session}->{store};
colas@0
   817
    unless ( $meta ) {
colas@0
   818
        try {
colas@0
   819
            my $dummyText;
colas@0
   820
            ( $meta, $dummyText ) =
colas@0
   821
              $store->readTopic(
colas@0
   822
                  $this->{session}->{user}, $formWeb, $formTopic, $rev );
colas@0
   823
            $this->{ffCache}{$formWeb.'.'.$formTopic} = $meta;
colas@0
   824
        } catch TWiki::AccessControlException with {
colas@0
   825
            # Ignore access exceptions; just don't read the data.
colas@0
   826
            my $e = shift;
colas@0
   827
            $this->{session}->writeWarning(
colas@0
   828
                "Attempt to read form data failed: ".$e->stringify());
colas@0
   829
        };
colas@0
   830
    }
colas@0
   831
colas@0
   832
    my $text = '';
colas@0
   833
    my $found = 0;
colas@0
   834
    my $title = '';
colas@0
   835
    if ( $meta ) {
colas@0
   836
        my @fields = $meta->find( 'FIELD' );
colas@0
   837
        foreach my $field ( @fields ) {
colas@0
   838
            my $name = $field->{name};
colas@0
   839
            $title = $field->{title} || $name;
colas@0
   840
            if( $title eq $formField || $name eq $formField ) {
colas@0
   841
                $found = 1;
colas@0
   842
                my $value = $field->{value};
colas@0
   843
colas@0
   844
                if (length $value) {
colas@0
   845
                    $text = $format;   
colas@0
   846
                    $text =~ s/\$value/$value/go;
colas@0
   847
                } elsif ( defined $default ) {
colas@0
   848
                    $text = $default;
colas@0
   849
                }
colas@0
   850
                last; #one hit suffices
colas@0
   851
            }
colas@0
   852
        }
colas@0
   853
    }
colas@0
   854
colas@0
   855
    unless ( $found ) {
colas@0
   856
        $text = $altText || '';
colas@0
   857
    }
colas@0
   858
colas@0
   859
    $text =~ s/\$title/$title/go;
colas@0
   860
colas@0
   861
    return $text;
colas@0
   862
}
colas@0
   863
colas@0
   864
=pod
colas@0
   865
colas@0
   866
---++ ObjectMethod getRenderedVersion ( $text, $theWeb, $theTopic ) -> $html
colas@0
   867
colas@0
   868
The main rendering function.
colas@0
   869
colas@0
   870
=cut
colas@0
   871
colas@0
   872
sub getRenderedVersion {
colas@0
   873
    my( $this, $text, $theWeb, $theTopic ) = @_;
colas@0
   874
colas@0
   875
    return '' unless $text;  # nothing to do
colas@0
   876
colas@0
   877
    $theTopic ||= $this->{session}->{topicName};
colas@0
   878
    $theWeb ||= $this->{session}->{webName};
colas@0
   879
    my $session = $this->{session};
colas@0
   880
    my $plugins = $session->{plugins};
colas@0
   881
    my $prefs = $session->{prefs};
colas@0
   882
    
colas@0
   883
    @{$this->{LIST}} = ();
colas@0
   884
colas@0
   885
    # Initial cleanup
colas@0
   886
    $text =~ s/\r//g;
colas@0
   887
    # whitespace before <! tag (if it is the first thing) is illegal
colas@0
   888
    $text =~ s/^\s+(<![a-z])/$1/i;
colas@0
   889
colas@0
   890
    # clutch to enforce correct rendering at end of doc
colas@0
   891
    $text =~ s/\n?$/\n<nop>\n/s;
colas@0
   892
colas@0
   893
    # Maps of placeholders to tag parameters and text
colas@0
   894
    my $removed = {};
colas@0
   895
colas@0
   896
    # verbatim before literal - see Item3431
colas@0
   897
    $text = $this->takeOutBlocks( $text, 'verbatim', $removed );
colas@0
   898
    $text = $this->takeOutBlocks( $text, 'literal', $removed );
colas@0
   899
colas@0
   900
    $text = $this->_takeOutProtected( $text, qr/<\?([^?]*)\?>/s,
colas@0
   901
                                     'comment', $removed );
colas@0
   902
    $text = $this->_takeOutProtected( $text, qr/<!DOCTYPE([^<>]*)>?/mi,
colas@0
   903
                                     'comment', $removed );
colas@0
   904
    $text = $this->_takeOutProtected( $text, qr/<head.*?<\/head>/si,
colas@0
   905
                                     'head', $removed );
colas@0
   906
    $text = $this->_takeOutProtected( $text, qr/<textarea\b.*?<\/textarea>/si,
colas@0
   907
                                     'textarea', $removed );
colas@0
   908
    $text = $this->_takeOutProtected( $text, qr/<script\b.*?<\/script>/si,
colas@0
   909
                                     'script', $removed );
colas@0
   910
colas@0
   911
    # DEPRECATED startRenderingHandler before PRE removed
colas@0
   912
    # SMELL: could parse more efficiently if this wasn't
colas@0
   913
    # here.
colas@0
   914
    $plugins->startRenderingHandler( $text, $theWeb, $theTopic );
colas@0
   915
colas@0
   916
    $text = $this->takeOutBlocks( $text, 'pre', $removed );
colas@0
   917
colas@0
   918
    # Join lines ending in '\' (don't need \r?, it was removed already)
colas@0
   919
    $text =~ s/\\\n//gs;
colas@0
   920
colas@0
   921
    $plugins->preRenderingHandler( $text, $removed );
colas@0
   922
colas@0
   923
    if( $plugins->haveHandlerFor( 'insidePREHandler' )) {
colas@0
   924
        foreach my $region ( sort keys %$removed ) {
colas@0
   925
            next unless ( $region =~ /^pre\d+$/i );
colas@0
   926
            my @lines = split( /\r?\n/, $removed->{$region}{text} );
colas@0
   927
            my $rt = '';
colas@0
   928
            while ( scalar( @lines )) {
colas@0
   929
                my $line = shift( @lines );
colas@0
   930
                $plugins->insidePREHandler( $line );
colas@0
   931
                if ( $line =~ /\n/ ) {
colas@0
   932
                    unshift( @lines, split( /\r?\n/, $line ));
colas@0
   933
                    next;
colas@0
   934
                }
colas@0
   935
                $rt .= $line."\n";
colas@0
   936
            }
colas@0
   937
            $removed->{$region}{text} = $rt;
colas@0
   938
        }
colas@0
   939
    }
colas@0
   940
colas@0
   941
    if( $plugins->haveHandlerFor( 'outsidePREHandler' )) {
colas@0
   942
        # DEPRECATED - this is the one call preventing
colas@0
   943
        # effective optimisation of the TWiki ML processing loop,
colas@0
   944
        # as it exposes the concept of a 'line loop' to plugins,
colas@0
   945
        # but HTML is not a line-oriented language (though TML is).
colas@0
   946
        # But without it, a lot of processing could be moved
colas@0
   947
        # outside the line loop.
colas@0
   948
        my @lines = split( /\r?\n/, $text );
colas@0
   949
        my $rt = '';
colas@0
   950
        while ( scalar( @lines ) ) {
colas@0
   951
            my $line = shift( @lines );
colas@0
   952
            $plugins->outsidePREHandler( $line );
colas@0
   953
            if ( $line =~ /\n/ ) {
colas@0
   954
                unshift( @lines, split( /\r?\n/, $line ));
colas@0
   955
                next;
colas@0
   956
            }
colas@0
   957
            $rt .= $line . "\n";
colas@0
   958
        }
colas@0
   959
colas@0
   960
        $text = $rt;
colas@0
   961
    }
colas@0
   962
colas@0
   963
    # Escape rendering: Change ' !AnyWord' to ' <nop>AnyWord',
colas@0
   964
    # for final ' AnyWord' output
colas@0
   965
    $text =~ s/$STARTWW\!(?=[\w\*\=])/<nop>/gm;
colas@0
   966
colas@0
   967
    # Blockquoted email (indented with '> ')
colas@0
   968
    # Could be used to provide different colours for different numbers of '>'
colas@0
   969
    $text =~ s/^>(.*?)$/'&gt;'.CGI::cite( $1 ).CGI::br()/gem;
colas@0
   970
colas@0
   971
    # locate isolated < and > and translate to entities
colas@0
   972
    # Protect isolated <!-- and -->
colas@0
   973
    $text =~ s/<!--/{$TWiki::TranslationToken!--/g;
colas@0
   974
    $text =~ s/-->/--}$TWiki::TranslationToken/g;
colas@0
   975
    # SMELL: this next fragment does not handle the case where HTML tags
colas@0
   976
    # are embedded in the values provided to other tags. The only way to
colas@0
   977
    # do this correctly is to parse the HTML (bleagh!). So we just assume
colas@0
   978
    # they have been escaped.
colas@0
   979
    $text =~ s/<(\/?\w+(:\w+)?)>/{$TWiki::TranslationToken$1}$TWiki::TranslationToken/g;
colas@0
   980
    $text =~ s/<(\w+(:\w+)?(\s+.*?|\/)?)>/{$TWiki::TranslationToken$1}$TWiki::TranslationToken/g;
colas@0
   981
    # XML processing instruction only valid at start of text
colas@0
   982
    $text =~ s/^<(\?\w.*?\?)>/{$TWiki::TranslationToken$1}$TWiki::TranslationToken/g;
colas@0
   983
colas@0
   984
    # entitify lone < and >, praying that we haven't screwed up :-(
colas@0
   985
    # Item1985: CDATA sections are not lone < and >
colas@0
   986
    $text =~ s/<(?!\!\[CDATA\[)/&lt\;/g;
colas@0
   987
    $text =~ s/(?<!\]\])>/&gt\;/g;
colas@0
   988
    $text =~ s/{$TWiki::TranslationToken/</go;
colas@0
   989
    $text =~ s/}$TWiki::TranslationToken/>/go;
colas@0
   990
colas@0
   991
    # standard URI
colas@0
   992
    $text =~ s/(^|[-*\s(|])($TWiki::regex{linkProtocolPattern}:([^\s<>"]+[^\s*.,!?;:)<|]))/$1._externalLink( $this,$2)/geo;
colas@0
   993
colas@0
   994
    # other entities
colas@0
   995
    $text =~ s/&(\w+);/$TWiki::TranslationToken$1;/g;      # "&abc;"
colas@0
   996
    $text =~ s/&(#x?[0-9a-f]+);/$TWiki::TranslationToken$1;/gi;  # "&#123;"
colas@0
   997
    $text =~ s/&/&amp;/g;                         # escape standalone "&"
colas@0
   998
    $text =~ s/$TWiki::TranslationToken(#x?[0-9a-f]+;)/&$1/goi;
colas@0
   999
    $text =~ s/$TWiki::TranslationToken(\w+;)/&$1/go;
colas@0
  1000
colas@0
  1001
    # Headings
colas@0
  1002
    # '<h6>...</h6>' HTML rule
colas@0
  1003
    $text =~ s/$TWiki::regex{headerPatternHt}/_makeAnchorHeading( $this,$2,$1)/geo;
colas@0
  1004
    # '----+++++++' rule
colas@0
  1005
    $text =~ s/$TWiki::regex{headerPatternDa}/_makeAnchorHeading( $this,$2,(length($1)))/geo;
colas@0
  1006
colas@0
  1007
    # Horizontal rule
colas@0
  1008
    my $hr = CGI::hr();
colas@0
  1009
    $text =~ s/^---+/$hr/gm;
colas@0
  1010
colas@0
  1011
    # Now we really _do_ need a line loop, to process TML
colas@0
  1012
    # line-oriented stuff.
colas@0
  1013
    my $isList = 0;        # True when within a list
colas@0
  1014
    my $tableRow = 0;
colas@0
  1015
    my @result;
colas@0
  1016
    my $isFirst = 1;
colas@0
  1017
colas@0
  1018
    foreach my $line ( split( /\r?\n/, $text )) {
colas@0
  1019
        # Table: | cell | cell |
colas@0
  1020
        # allow trailing white space after the last |
colas@0
  1021
        if( $line =~ m/^(\s*)\|.*\|\s*$/ ) {
colas@0
  1022
            unless( $tableRow ) {
colas@0
  1023
                # mark the head of the table
colas@0
  1024
                push( @result, $TABLEMARKER );
colas@0
  1025
            }
colas@0
  1026
            $line =~ s/^(\s*)\|(.*)/$1._emitTR( $this, $2 )/e;
colas@0
  1027
            $tableRow++;
colas@0
  1028
        } elsif( $tableRow ) {
colas@0
  1029
            _addTHEADandTFOOT( \@result );
colas@0
  1030
            push( @result, '</table>' );
colas@0
  1031
            $tableRow = 0;
colas@0
  1032
        }
colas@0
  1033
colas@0
  1034
        # Lists and paragraphs
colas@0
  1035
        if ( $line =~ m/^\s*$/ ) {
colas@0
  1036
            unless( $tableRow || $isFirst ) {
colas@0
  1037
                $line = '<p />';
colas@0
  1038
            }
colas@0
  1039
            $isList = 0;
colas@0
  1040
        }
colas@0
  1041
        elsif ( $line =~ m/^\S/ ) {
colas@0
  1042
            $isList = 0;
colas@0
  1043
        }
colas@0
  1044
        elsif ( $line =~ m/^(\t|   )+\S/ ) {
colas@0
  1045
            if ( $line =~ s/^((\t|   )+)\$\s(([^:]+|:[^\s]+)+?):\s/<dt> $3 <\/dt><dd> / ) {
colas@0
  1046
                # Definition list
colas@0
  1047
                _addListItem( $this, \@result, 'dl', 'dd', $1 );
colas@0
  1048
                $isList = 1;
colas@0
  1049
            }
colas@0
  1050
            elsif ( $line =~ s/^((\t|   )+)(\S+?):\s/<dt> $3<\/dt><dd> /o ) {
colas@0
  1051
                # Definition list
colas@0
  1052
                _addListItem( $this, \@result, 'dl', 'dd', $1 );
colas@0
  1053
                $isList = 1;
colas@0
  1054
            }
colas@0
  1055
            elsif ( $line =~ s/^((\t|   )+)\* /<li> /o ) {
colas@0
  1056
                # Unnumbered list
colas@0
  1057
                _addListItem( $this, \@result, 'ul', 'li', $1 );
colas@0
  1058
                $isList = 1;
colas@0
  1059
            }
colas@0
  1060
            elsif ( $line =~ m/^((\t|   )+)([1AaIi]\.|\d+\.?) ?/ ) {
colas@0
  1061
                # Numbered list
colas@0
  1062
                my $ot = $3;
colas@0
  1063
                $ot =~ s/^(.).*/$1/;
colas@0
  1064
                if( $ot !~ /^\d$/ ) {
colas@0
  1065
                    $ot = ' type="'.$ot.'"';
colas@0
  1066
                } else {
colas@0
  1067
                    $ot = '';
colas@0
  1068
                }
colas@0
  1069
                $line =~ s/^((\t|   )+)([1AaIi]\.|\d+\.?) ?/<li$ot> /;
colas@0
  1070
                _addListItem( $this, \@result, 'ol', 'li', $1 );
colas@0
  1071
                $isList = 1;
colas@0
  1072
            }
colas@0
  1073
            elsif( $isList && $line =~ /^(\t|   )+\s*\S/ ) {
colas@0
  1074
                # indented line extending prior list item
colas@0
  1075
                push( @result, $line );
colas@0
  1076
                next;
colas@0
  1077
            }
colas@0
  1078
            else {
colas@0
  1079
                $isList = 0;
colas@0
  1080
            }
colas@0
  1081
        } elsif( $isList && $line =~ /^(\t|   )+\s*\S/ ) {
colas@0
  1082
            # indented line extending prior list item; case where indent
colas@0
  1083
            # starts with is at least 3 spaces or a tab, but may not be a
colas@0
  1084
            # multiple of 3.
colas@0
  1085
            push( @result, $line );
colas@0
  1086
            next;
colas@0
  1087
        }
colas@0
  1088
colas@0
  1089
        # Finish the list
colas@0
  1090
        unless( $isList || $isFirst ) {
colas@0
  1091
            _addListItem( $this, \@result, '', '', '' );
colas@0
  1092
        }
colas@0
  1093
colas@0
  1094
        push( @result, $line );
colas@0
  1095
        $isFirst = 0;
colas@0
  1096
    }
colas@0
  1097
colas@0
  1098
    if( $tableRow ) {
colas@0
  1099
        _addTHEADandTFOOT( \@result );
colas@0
  1100
        push( @result, '</table>' );
colas@0
  1101
    }
colas@0
  1102
    _addListItem( $this, \@result, '', '', '' );
colas@0
  1103
colas@0
  1104
    $text = join( '', @result );
colas@0
  1105
colas@0
  1106
    # '#WikiName' anchors
colas@0
  1107
    $text =~ s/^(\#)($TWiki::regex{wikiWordRegex})/CGI::a( { name=>$this->makeAnchorName( $2 )}, '')/geom;
colas@0
  1108
    $text =~ s/${STARTWW}==(\S+?|\S[^\n]*?\S)==$ENDWW/_fixedFontText($1,1)/gem;
colas@0
  1109
    $text =~ s/${STARTWW}__(\S+?|\S[^\n]*?\S)__$ENDWW/<strong><em>$1<\/em><\/strong>/gm;
colas@0
  1110
    $text =~ s/${STARTWW}\*(\S+?|\S[^\n]*?\S)\*$ENDWW/<strong>$1<\/strong>/gm;
colas@0
  1111
    $text =~ s/${STARTWW}\_(\S+?|\S[^\n]*?\S)\_$ENDWW/<em>$1<\/em>/gm;
colas@0
  1112
    $text =~ s/${STARTWW}\=(\S+?|\S[^\n]*?\S)\=$ENDWW/_fixedFontText($1,0)/gem;
colas@0
  1113
colas@0
  1114
    # Mailto
colas@0
  1115
    # Email addresses must always be 7-bit, even within I18N sites
colas@0
  1116
colas@0
  1117
    # Normal mailto:foo@example.com ('mailto:' part optional)
colas@0
  1118
    $text =~ s/$STARTWW((mailto\:)?[a-zA-Z0-9-_.+]+@[a-zA-Z0-9-_.]+\.[a-zA-Z0-9-_]+)$ENDWW/_mailLink( $this, $1 )/gem;
colas@0
  1119
colas@0
  1120
    # Handle [[][] and [[]] links
colas@0
  1121
    # Escape rendering: Change ' ![[...' to ' [<nop>[...', for final unrendered ' [[...' output
colas@0
  1122
    $text =~ s/(^|\s)\!\[\[/$1\[<nop>\[/gm;
colas@0
  1123
    # Spaced-out Wiki words with alternative link text
colas@0
  1124
    # i.e. [[$1][$3]]
colas@0
  1125
    $text =~ s/\[\[([^\]\[\n]+)\](\[([^\]\n]+)\])?\]/_handleSquareBracketedLink( $this,$theWeb,$theTopic,$1,$3)/ge;
colas@0
  1126
colas@0
  1127
    unless( TWiki::isTrue( $prefs->getPreferencesValue('NOAUTOLINK')) ) {
colas@0
  1128
        # Handle WikiWords
colas@0
  1129
        $text = $this->takeOutBlocks( $text, 'noautolink', $removed );
colas@0
  1130
        $text =~ s/$STARTWW(?:($TWiki::regex{webNameRegex})\.)?($TWiki::regex{wikiWordRegex}|$TWiki::regex{abbrevRegex})($TWiki::regex{anchorRegex})?/_handleWikiWord( $this,$theWeb,$1,$2,$3)/geom;
colas@0
  1131
        $this->putBackBlocks( \$text, $removed, 'noautolink' );
colas@0
  1132
    }
colas@0
  1133
colas@0
  1134
    $this->putBackBlocks( \$text, $removed, 'pre' );
colas@0
  1135
colas@0
  1136
    # DEPRECATED plugins hook after PRE re-inserted
colas@0
  1137
    $plugins->endRenderingHandler( $text );
colas@0
  1138
colas@0
  1139
    # replace verbatim with pre in the final output
colas@0
  1140
    $this->putBackBlocks( \$text, $removed,
colas@0
  1141
                          'verbatim', 'pre', \&verbatimCallBack );
colas@0
  1142
    $text =~ s|\n?<nop>\n$||o; # clean up clutch
colas@0
  1143
colas@0
  1144
    $this->_putBackProtected( \$text, 'script', $removed, \&_filterScript );
colas@0
  1145
    $this->putBackBlocks( \$text, $removed,
colas@0
  1146
                          'literal', '', \&_filterLiteral );
colas@0
  1147
colas@0
  1148
    $this->_putBackProtected( \$text, 'literal', $removed );
colas@0
  1149
    $this->_putBackProtected( \$text, 'comment', $removed );
colas@0
  1150
    $this->_putBackProtected( \$text, 'head', $removed );
colas@0
  1151
    $this->_putBackProtected( \$text, 'textarea', $removed );
colas@0
  1152
colas@0
  1153
    $this->{session}->{users}->{loginManager}->endRenderingHandler( $text );
colas@0
  1154
colas@0
  1155
    $plugins->postRenderingHandler( $text );
colas@0
  1156
    return $text;
colas@0
  1157
}
colas@0
  1158
colas@0
  1159
=pod
colas@0
  1160
colas@0
  1161
---++ StaticMethod verbatimCallBack
colas@0
  1162
colas@0
  1163
Callback for use with putBackBlocks that replaces &lt; and >
colas@0
  1164
by their HTML entities &amp;lt; and &amp;gt;
colas@0
  1165
colas@0
  1166
=cut
colas@0
  1167
colas@0
  1168
sub verbatimCallBack {
colas@0
  1169
    my $val = shift;
colas@0
  1170
colas@0
  1171
    # SMELL: A shame to do this, but been in TWiki.org have converted
colas@0
  1172
    # 3 spaces to tabs since day 1
colas@0
  1173
    $val =~ s/\t/   /g;
colas@0
  1174
colas@0
  1175
    return TWiki::entityEncode( $val );
colas@0
  1176
}
colas@0
  1177
colas@0
  1178
# Only put script and literal sections back if they are allowed by options
colas@0
  1179
sub _filterLiteral {
colas@0
  1180
    my $val = shift;
colas@0
  1181
    return $val if( $TWiki::cfg{AllowInlineScript} );
colas@0
  1182
    return CGI::comment('<literal> is not allowed on this site');
colas@0
  1183
}
colas@0
  1184
colas@0
  1185
sub _filterScript {
colas@0
  1186
    my $val = shift;
colas@0
  1187
    return $val if( $TWiki::cfg{AllowInlineScript} );
colas@0
  1188
    return CGI::comment('<script> is not allowed on this site');
colas@0
  1189
}
colas@0
  1190
colas@0
  1191
=pod
colas@0
  1192
colas@0
  1193
---++ ObjectMethod TML2PlainText( $text, $web, $topic, $opts ) -> $plainText
colas@0
  1194
colas@0
  1195
Clean up TWiki text for display as plain text without pushing it
colas@0
  1196
through the full rendering pipeline. Intended for generation of
colas@0
  1197
topic and change summaries. Adds nop tags to prevent TWiki 
colas@0
  1198
subsequent rendering; nops get removed at the very end.
colas@0
  1199
colas@0
  1200
Defuses TML.
colas@0
  1201
colas@0
  1202
$opts:
colas@0
  1203
   * showvar - shows !%VAR% names if not expanded
colas@0
  1204
   * expandvar - expands !%VARS%
colas@0
  1205
   * nohead - strips ---+ headings at the top of the text
colas@0
  1206
   * showmeta - does not filter meta-data
colas@0
  1207
colas@0
  1208
=cut
colas@0
  1209
colas@0
  1210
sub TML2PlainText {
colas@0
  1211
    my( $this, $text, $web, $topic, $opts ) = @_;
colas@0
  1212
    $opts ||= '';
colas@0
  1213
colas@0
  1214
    $text =~ s/\r//g;  # SMELL, what about OS10?
colas@0
  1215
colas@0
  1216
    if( $opts =~ /showmeta/ ) {
colas@0
  1217
        $text =~ s/%META:/%<nop>META:/g;
colas@0
  1218
    } else {
colas@0
  1219
        $text =~ s/%META:[A-Z].*?}%//g;
colas@0
  1220
    }
colas@0
  1221
colas@0
  1222
    if( $opts =~ /expandvar/ ) {
colas@0
  1223
        $text =~ s/(\%)(SEARCH){/$1<nop>$2/g; # prevent recursion
colas@0
  1224
        $text = $this->{session}->handleCommonTags( $text, $web, $topic );
colas@0
  1225
    } else {
colas@0
  1226
        $text =~ s/%WEB%/$web/g;
colas@0
  1227
        $text =~ s/%TOPIC%/$topic/g;
colas@0
  1228
        my $wtn = $this->{session}->{prefs}->getPreferencesValue(
colas@0
  1229
            'WIKITOOLNAME' ) || '';
colas@0
  1230
        $text =~ s/%WIKITOOLNAME%/$wtn/g;
colas@0
  1231
        if( $opts =~ /showvar/ ) {
colas@0
  1232
            $text =~ s/%(\w+({.*?}))%/$1/g; # defuse
colas@0
  1233
        } else {
colas@0
  1234
            $text =~ s/%$TWiki::regex{tagNameRegex}({.*?})?%//g;  # remove
colas@0
  1235
        }
colas@0
  1236
    }
colas@0
  1237
colas@0
  1238
    # Format e-mail to add spam padding (HTML tags removed later)
colas@0
  1239
    $text =~ s/$STARTWW((mailto\:)?[a-zA-Z0-9-_.+]+@[a-zA-Z0-9-_.]+\.[a-zA-Z0-9-_]+)$ENDWW/_mailLink( $this, $1 )/gem;
colas@0
  1240
    $text =~ s/<!--.*?-->//gs;          # remove all HTML comments
colas@0
  1241
    $text =~ s/<(?!nop)[^>]*>//g;       # remove all HTML tags except <nop>
colas@0
  1242
    $text =~ s/\&[a-z]+;/ /g;           # remove entities
colas@0
  1243
    if( $opts =~ /nohead/ ) {
colas@0
  1244
        # skip headings on top
colas@0
  1245
        while( $text =~ s/^\s*\-\-\-+\+[^\n\r]*// ) {}; # remove heading
colas@0
  1246
    }
colas@0
  1247
    # keep only link text of [[prot://uri.tld/ link text]] or [[][]]
colas@0
  1248
    $text =~ s/\[\[$TWiki::regex{linkProtocolPattern}\:([^\s<>"]+[^\s*.,!?;:)<|])\s+(.*?)\]\]/$3/g;
colas@0
  1249
    $text =~ s/\[\[([^\]]*\]\[)(.*?)\]\]/$2/g;
colas@0
  1250
    # remove "Web." prefix from "Web.TopicName" link
colas@0
  1251
    $text =~ s/$STARTWW(($TWiki::regex{webNameRegex})\.($TWiki::regex{wikiWordRegex}|$TWiki::regex{abbrevRegex}))/$3/g;
colas@0
  1252
    $text =~ s/<[^>]*>//g;              # remove all HTML tags
colas@0
  1253
    $text =~ s/[\[\]\*\|=_\&\<\>]/ /g;  # remove Wiki formatting chars
colas@0
  1254
    $text =~ s/^\-\-\-+\+*\s*\!*/ /gm;  # remove heading formatting and hbar
colas@0
  1255
    $text =~ s/[\+\-]+/ /g;             # remove special chars
colas@0
  1256
    $text =~ s/^\s+//;                  # remove leading whitespace
colas@0
  1257
    $text =~ s/\s+$//;                  # remove trailing whitespace
colas@0
  1258
    $text =~ s/!(\w+)/$1/gs;            # remove all nop exclamation marks before words
colas@0
  1259
    $text =~ s/[\r\n]+/\n/s;
colas@0
  1260
    $text =~ s/[ \t]+/ /s;
colas@0
  1261
colas@0
  1262
    return $text;
colas@0
  1263
}
colas@0
  1264
colas@0
  1265
=pod
colas@0
  1266
colas@0
  1267
---++ ObjectMethod protectPlainText($text) -> $tml
colas@0
  1268
colas@0
  1269
Protect plain text from expansions that would normally be done
colas@0
  1270
duing rendering, such as wikiwords. Topic summaries, for example,
colas@0
  1271
have to be protected this way.
colas@0
  1272
colas@0
  1273
=cut
colas@0
  1274
colas@0
  1275
sub protectPlainText {
colas@0
  1276
    my( $this, $text ) = @_;
colas@0
  1277
colas@0
  1278
    # prevent text from getting rendered in inline search and link tool
colas@0
  1279
    # tip text by escaping links (external, internal, Interwiki)
colas@0
  1280
#    $text =~ s/(?<=[\s\(])((($TWiki::regex{webNameRegex})\.)?($TWiki::regex{wikiWordRegex}|$TWiki::regex{abbrevRegex}))/<nop>$1/g;
colas@0
  1281
#    $text =~ s/(^|(<=\W))((($TWiki::regex{webNameRegex})\.)?($TWiki::regex{wikiWordRegex}|$TWiki::regex{abbrevRegex}))/<nop>$1/g;
colas@0
  1282
    $text =~ s/((($TWiki::regex{webNameRegex})\.)?($TWiki::regex{wikiWordRegex}|$TWiki::regex{abbrevRegex}))/<nop>$1/g;
colas@0
  1283
colas@0
  1284
#    $text =~ s/(?<=[\s\(])($TWiki::regex{linkProtocolPattern}\:)/<nop>$1/go;
colas@0
  1285
#    $text =~ s/(^|(<=\W))($TWiki::regex{linkProtocolPattern}\:)/<nop>$1/go;
colas@0
  1286
    $text =~ s/($TWiki::regex{linkProtocolPattern}\:)/<nop>$1/go;
colas@0
  1287
    $text =~ s/([@%])/<nop>$1<nop>/g;    # email address, variable
colas@0
  1288
colas@0
  1289
    # Encode special chars into XML &#nnn; entities for use in RSS feeds
colas@0
  1290
    # - no encoding for HTML pages, to avoid breaking international 
colas@0
  1291
    # characters. Only works for ISO-8859-1 sites, since the Unicode
colas@0
  1292
    # encoding (&#nnn;) is identical for first 256 characters. 
colas@0
  1293
    # I18N TODO: Convert to Unicode from any site character set.
colas@0
  1294
    if( $this->{session}->inContext( 'rss' ) &&
colas@0
  1295
          defined( $TWiki::cfg{Site}{CharSet} ) &&
colas@0
  1296
            $TWiki::cfg{Site}{CharSet} =~ /^iso-?8859-?1$/i ) {
colas@0
  1297
        $text =~ s/([\x7f-\xff])/"\&\#" . unpack( 'C', $1 ) .';'/ge;
colas@0
  1298
    }
colas@0
  1299
colas@0
  1300
    return $text;
colas@0
  1301
}
colas@0
  1302
colas@0
  1303
=pod
colas@0
  1304
colas@0
  1305
---++ ObjectMethod makeTopicSummary (  $theText, $theTopic, $theWeb, $theFlags ) -> $tml
colas@0
  1306
colas@0
  1307
Makes a plain text summary of the given topic by simply trimming a bit
colas@0
  1308
off the top. Truncates to $TMTRUNC chars or, if a number is specified in $theFlags,
colas@0
  1309
to that length.
colas@0
  1310
colas@0
  1311
=cut
colas@0
  1312
colas@0
  1313
sub makeTopicSummary {
colas@0
  1314
    my( $this, $theText, $theTopic, $theWeb, $theFlags ) = @_;
colas@0
  1315
    $theFlags ||= '';
colas@0
  1316
colas@0
  1317
    my $htext = $this->TML2PlainText( $theText, $theWeb, $theTopic, $theFlags);
colas@0
  1318
    $htext =~ s/\n+/ /g;
colas@0
  1319
colas@0
  1320
    # FIXME I18N: Avoid splitting within multi-byte characters (e.g. EUC-JP
colas@0
  1321
    # encoding) by encoding bytes as Perl UTF-8 characters in Perl 5.8+. 
colas@0
  1322
    # This avoids splitting within a Unicode codepoint (or a UTF-16
colas@0
  1323
    # surrogate pair, which is encoded as a single Perl UTF-8 character),
colas@0
  1324
    # but we ideally need to avoid splitting closely related Unicode codepoints.
colas@0
  1325
    # Specifically, this means Unicode combining character sequences (e.g.
colas@0
  1326
    # letters and accents) - might be better to split on word boundary if
colas@0
  1327
    # possible.
colas@0
  1328
colas@0
  1329
    # limit to n chars
colas@0
  1330
    my $nchar = $theFlags;
colas@0
  1331
    unless( $nchar =~ s/^.*?([0-9]+).*$/$1/ ) {
colas@0
  1332
        $nchar = $TMLTRUNC;
colas@0
  1333
    }
colas@0
  1334
    $nchar = $MINTRUNC if( $nchar < $MINTRUNC );
colas@0
  1335
    $htext =~ s/^(.{$nchar}.*?)($TWiki::regex{mixedAlphaNumRegex}).*$/$1$2 \.\.\./s;
colas@0
  1336
colas@0
  1337
    # We do not want the summary to contain any $variable that formatted
colas@0
  1338
    # searches can interpret to anything (Item3489).
colas@0
  1339
    # Especially new lines (Item2496)
colas@0
  1340
    # To not waste performance we simply replace $ by $<nop>
colas@0
  1341
    $htext =~ s/\$/\$<nop>/g;
colas@0
  1342
    # Escape Interwiki links and other side effects introduced by
colas@0
  1343
    # plugins later in the rendering pipeline (Item4748)
colas@0
  1344
    $htext =~ s/\:/<nop>\:/g;
colas@0
  1345
    $htext =~ s/\s+/ /g;
colas@0
  1346
colas@0
  1347
    return $this->protectPlainText( $htext );
colas@0
  1348
}
colas@0
  1349
colas@0
  1350
# _takeOutProtected( \$text, $re, $id, \%map ) -> $text
colas@0
  1351
#
colas@0
  1352
#   * =$text= - Text to process
colas@0
  1353
#   * =$re= - Regular expression that matches tag expressions to remove
colas@0
  1354
#   * =\%map= - Reference to a hash to contain the removed blocks
colas@0
  1355
#
colas@0
  1356
# Return value: $text with blocks removed. Unlike takeOuBlocks, this
colas@0
  1357
# *preserves* the tags.
colas@0
  1358
#
colas@0
  1359
# used to extract from $text comment type tags like &lt;!DOCTYPE blah>
colas@0
  1360
#
colas@0
  1361
# WARNING: if you want to take out &lt;!-- comments --> you _will_ need
colas@0
  1362
# to re-write all the takeOuts to use a different placeholder
colas@0
  1363
sub _takeOutProtected {
colas@0
  1364
	my( $this, $intext, $re, $id, $map ) = @_;
colas@0
  1365
colas@0
  1366
	$intext =~ s/($re)/_replaceBlock($1, $id, $map)/ge;
colas@0
  1367
colas@0
  1368
	return $intext;
colas@0
  1369
}
colas@0
  1370
colas@0
  1371
sub _replaceBlock {
colas@0
  1372
	my( $scoop, $id, $map ) = @_;
colas@0
  1373
	my $placeholder = $placeholderMarker;
colas@0
  1374
    $placeholderMarker++;
colas@0
  1375
	$map->{$id.$placeholder}{text} = $scoop;
colas@0
  1376
colas@0
  1377
	return '<!--'.$TWiki::TranslationToken.$id.$placeholder.
colas@0
  1378
      $TWiki::TranslationToken.'-->';
colas@0
  1379
}
colas@0
  1380
colas@0
  1381
# _putBackProtected( \$text, $id, \%map, $callback ) -> $text
colas@0
  1382
# Return value: $text with blocks added back
colas@0
  1383
#   * =\$text= - reference to text to process
colas@0
  1384
#   * =$id= - type of taken-out block e.g. 'verbatim'
colas@0
  1385
#   * =\%map= - map placeholders to blocks removed by takeOutBlocks
colas@0
  1386
#   * =$callback= - Reference to function to call on each block being inserted (optional)
colas@0
  1387
#
colas@0
  1388
#Reverses the actions of takeOutProtected.
colas@0
  1389
sub _putBackProtected {
colas@0
  1390
    my( $this, $text, $id, $map, $callback ) = @_;
colas@0
  1391
    ASSERT(ref($map) eq 'HASH') if DEBUG;
colas@0
  1392
colas@0
  1393
    foreach my $placeholder ( keys %$map ) {
colas@0
  1394
        next unless $placeholder =~ /^$id\d+$/;
colas@0
  1395
        my $val = $map->{$placeholder}{text};
colas@0
  1396
        $val = &$callback( $val ) if( defined( $callback ));
colas@0
  1397
        $$text =~ s/<!--$TWiki::TranslationToken$placeholder$TWiki::TranslationToken-->/$val/;
colas@0
  1398
        delete( $map->{$placeholder} );
colas@0
  1399
    }
colas@0
  1400
}
colas@0
  1401
colas@0
  1402
=pod
colas@0
  1403
colas@0
  1404
---++ ObjectMethod takeOutBlocks( \$text, $tag, \%map ) -> $text
colas@0
  1405
colas@0
  1406
   * =$text= - Text to process
colas@0
  1407
   * =$tag= - XHTML-style tag.
colas@0
  1408
   * =\%map= - Reference to a hash to contain the removed blocks
colas@0
  1409
colas@0
  1410
Return value: $text with blocks removed
colas@0
  1411
colas@0
  1412
Searches through $text and extracts blocks delimited by a tag, appending each
colas@0
  1413
onto the end of the @buffer and replacing with a token
colas@0
  1414
string which is not affected by TWiki rendering.  The text after these
colas@0
  1415
substitutions is returned.
colas@0
  1416
colas@0
  1417
Parameters to the open tag are recorded.
colas@0
  1418
colas@0
  1419
This is _different_ to takeOutProtected, because it requires tags
colas@0
  1420
to be on their own line. it also supports a callback for post-
colas@0
  1421
processing the data before re-insertion.
colas@0
  1422
colas@0
  1423
=cut
colas@0
  1424
colas@0
  1425
sub takeOutBlocks {
colas@0
  1426
    my( $this, $intext, $tag, $map ) = @_;
colas@0
  1427
colas@0
  1428
    return $intext unless( $intext =~ m/<$tag\b/i );
colas@0
  1429
colas@0
  1430
    my $out = '';
colas@0
  1431
    my $depth = 0;
colas@0
  1432
    my $scoop;
colas@0
  1433
    my $tagParams;
colas@0
  1434
colas@0
  1435
    foreach my $token ( split/(<\/?$tag[^>]*>)/i, $intext ) {
colas@0
  1436
    	if ($token =~ /<$tag\b([^>]*)?>/i) {
colas@0
  1437
    		$depth++;
colas@0
  1438
    		if ($depth eq 1) {
colas@0
  1439
    			$tagParams = $1;
colas@0
  1440
    			next;
colas@0
  1441
    		}
colas@0
  1442
    	} elsif ($token =~ /<\/$tag>/i) {
colas@0
  1443
            if ($depth > 0) {
colas@0
  1444
                $depth--;
colas@0
  1445
                if ($depth eq 0) {
colas@0
  1446
                    my $placeholder = $tag.$placeholderMarker;
colas@0
  1447
                    $placeholderMarker++;
colas@0
  1448
                    $map->{$placeholder}{text} = $scoop;
colas@0
  1449
                    $map->{$placeholder}{params} = $tagParams;
colas@0
  1450
                    $out .= '<!--'.$TWiki::TranslationToken.$placeholder.
colas@0
  1451
                      $TWiki::TranslationToken.'-->';
colas@0
  1452
                    $scoop = '';
colas@0
  1453
                    next;
colas@0
  1454
                }
colas@0
  1455
            }
colas@0
  1456
    	}
colas@0
  1457
    	if ($depth > 0) {
colas@0
  1458
    		$scoop .= $token;
colas@0
  1459
    	} else {
colas@0
  1460
    		$out .= $token;
colas@0
  1461
    	}
colas@0
  1462
    }
colas@0
  1463
colas@0
  1464
	# unmatched tags
colas@0
  1465
	if (defined($scoop) && ($scoop ne '')) {
colas@0
  1466
		my $placeholder = $tag.$placeholderMarker;
colas@0
  1467
		$placeholderMarker++;
colas@0
  1468
		$map->{$placeholder}{text} = $scoop;
colas@0
  1469
		$map->{$placeholder}{params} = $tagParams;
colas@0
  1470
		$out .= '<!--'.$TWiki::TranslationToken.$placeholder.
colas@0
  1471
          $TWiki::TranslationToken.'-->';
colas@0
  1472
	}
colas@0
  1473
colas@0
  1474
colas@0
  1475
    return $out;
colas@0
  1476
}
colas@0
  1477
colas@0
  1478
=pod
colas@0
  1479
colas@0
  1480
---++ ObjectMethod putBackBlocks( \$text, \%map, $tag, $newtag, $callBack ) -> $text
colas@0
  1481
colas@0
  1482
Return value: $text with blocks added back
colas@0
  1483
   * =\$text= - reference to text to process
colas@0
  1484
   * =\%map= - map placeholders to blocks removed by takeOutBlocks
colas@0
  1485
   * =$tag= - Tag name processed by takeOutBlocks
colas@0
  1486
   * =$newtag= - Tag name to use in output, in place of $tag. If undefined, uses $tag.
colas@0
  1487
   * =$callback= - Reference to function to call on each block being inserted (optional)
colas@0
  1488
colas@0
  1489
Reverses the actions of takeOutBlocks.
colas@0
  1490
colas@0
  1491
Each replaced block is processed by the callback (if there is one) before
colas@0
  1492
re-insertion.
colas@0
  1493
colas@0
  1494
Parameters to the outermost cut block are replaced into the open tag,
colas@0
  1495
even if that tag is changed. This allows things like
colas@0
  1496
&lt;verbatim class=''>
colas@0
  1497
to be mapped to
colas@0
  1498
&lt;pre class=''>
colas@0
  1499
colas@0
  1500
Cool, eh what? Jolly good show.
colas@0
  1501
colas@0
  1502
And if you set $newtag to '', we replace the taken out block with the valuse itself
colas@0
  1503
   * which i'm using to stop the rendering process, but then at the end put in the html directly
colas@0
  1504
   (for <literal> tag.
colas@0
  1505
colas@0
  1506
=cut
colas@0
  1507
colas@0
  1508
sub putBackBlocks {
colas@0
  1509
    my( $this, $text, $map, $tag, $newtag, $callback ) = @_;
colas@0
  1510
colas@0
  1511
    $newtag = $tag if (!defined($newtag));
colas@0
  1512
colas@0
  1513
    foreach my $placeholder ( keys %$map ) {
colas@0
  1514
        if( $placeholder =~ /^$tag\d+$/ ) {
colas@0
  1515
            my $params = $map->{$placeholder}{params} || '';
colas@0
  1516
            my $val = $map->{$placeholder}{text};
colas@0
  1517
            $val = &$callback( $val ) if ( defined( $callback ));
colas@0
  1518
            if ($newtag eq '') {
colas@0
  1519
            	$$text =~ s(<!--$TWiki::TranslationToken$placeholder$TWiki::TranslationToken-->)($val);
colas@0
  1520
            } else {
colas@0
  1521
            	$$text =~ s(<!--$TWiki::TranslationToken$placeholder$TWiki::TranslationToken-->)
colas@0
  1522
              	(<$newtag$params>$val</$newtag>);
colas@0
  1523
            }
colas@0
  1524
            delete( $map->{$placeholder} );
colas@0
  1525
        }
colas@0
  1526
    }
colas@0
  1527
}
colas@0
  1528
colas@0
  1529
=pod
colas@0
  1530
colas@0
  1531
---++ ObjectMethod renderRevisionInfo($web, $topic, $meta, $rev, $format) -> $string
colas@0
  1532
colas@0
  1533
Obtain and render revision info for a topic.
colas@0
  1534
   * =$web= - the web of the topic
colas@0
  1535
   * =$topic= - the topic
colas@0
  1536
   * =$meta= if specified, get rev info from here. If not specified, or meta contains rev info for a different version than the one requested, will reload the topic
colas@0
  1537
   * =$rev= - the rev number, defaults to latest rev
colas@0
  1538
   * =$format= - the render format, defaults to =$rev - $time - $wikiusername=
colas@0
  1539
=$format= can contain the following keys for expansion:
colas@0
  1540
   | =$web= | the web name |
colas@0
  1541
   | =$topic= | the topic name |
colas@0
  1542
   | =$rev= | the rev number |
colas@0
  1543
   | =$comment= | the comment |
colas@0
  1544
   | =$username= | the login of the saving user |
colas@0
  1545
   | =$wikiname= | the wikiname of the saving user |
colas@0
  1546
   | =$wikiusername= | the web.wikiname of the saving user |
colas@0
  1547
   | =$date= | the date of the rev (no time) |
colas@0
  1548
   | =$time= | the time of the rev |
colas@0
  1549
   | =$min=, =$sec=, etc. | Same date format qualifiers as GMTIME |
colas@0
  1550
colas@0
  1551
=cut
colas@0
  1552
colas@0
  1553
sub renderRevisionInfo {
colas@0
  1554
    my( $this, $web, $topic, $meta, $rrev, $format ) = @_;
colas@0
  1555
    my $store = $this->{session}->{store};
colas@0
  1556
    my $users = $this->{session}->{users};
colas@0
  1557
colas@0
  1558
    if( $rrev ) {
colas@0
  1559
        $rrev = $store->cleanUpRevID( $rrev );
colas@0
  1560
    }
colas@0
  1561
colas@0
  1562
    unless( $meta ) {
colas@0
  1563
        my $text;
colas@0
  1564
        ( $meta, $text ) = $store->readTopic( undef, $web, $topic, $rrev );
colas@0
  1565
    }
colas@0
  1566
    my( $date, $user, $rev, $comment ) = $meta->getRevisionInfo( $rrev );
colas@0
  1567
colas@0
  1568
    my $wun = '';
colas@0
  1569
    my $wn = '';
colas@0
  1570
    my $un = '';
colas@0
  1571
    if( $user ) {
colas@0
  1572
        $wun = $users->webDotWikiName($user);
colas@0
  1573
        $wn = $users->getWikiName( $user );
colas@0
  1574
        $un = $users->getLoginName($user);
colas@0
  1575
    }
colas@0
  1576
colas@0
  1577
    my $value = $format || 'r$rev - $date - $time - $wikiusername';
colas@0
  1578
    $value =~ s/\$web/$web/gi;
colas@0
  1579
    $value =~ s/\$topic/$topic/gi;
colas@0
  1580
    $value =~ s/\$rev/$rev/gi;
colas@0
  1581
    $value =~ s/\$time/TWiki::Time::formatTime( $date, '$hour:$min:$sec')/gei;
colas@0
  1582
    $value =~ s/\$date/TWiki::Time::formatTime( $date, $TWiki::cfg{DefaultDateFormat} )/gei;
colas@0
  1583
    $value =~ s/(\$(rcs|http|email|iso))/TWiki::Time::formatTime($date, $1 )/gei;
colas@0
  1584
    if( $value =~ /\$(sec|min|hou|day|wday|dow|week|mo|ye|epoch|tz)/ ) {
colas@0
  1585
        $value = TWiki::Time::formatTime( $date, $value );
colas@0
  1586
    }
colas@0
  1587
    $value =~ s/\$comment/$comment/gi;
colas@0
  1588
    $value =~ s/\$username/$un/gi;
colas@0
  1589
    $value =~ s/\$wikiname/$wn/gi;
colas@0
  1590
    $value =~ s/\$wikiusername/$wun/gi;
colas@0
  1591
colas@0
  1592
    return $value;
colas@0
  1593
}
colas@0
  1594
colas@0
  1595
=pod
colas@0
  1596
colas@0
  1597
---++ ObjectMethod summariseChanges($user, $web, $topic, $orev, $nrev, $tml) -> $text
colas@0
  1598
colas@0
  1599
   * =$user= - user (null to ignore permissions)
colas@0
  1600
   * =$web= - web
colas@0
  1601
   * =$topic= - topic
colas@0
  1602
   * =$orev= - older rev
colas@0
  1603
   * =$nrev= - later rev
colas@0
  1604
   * =$tml= - if true will generate renderable TML (i.e. HTML with NOPs. if false will generate a summary suitable for use in plain text (mail, for example)
colas@0
  1605
Generate a (max 3 line) summary of the differences between the revs.
colas@0
  1606
colas@0
  1607
If there is only one rev, a topic summary will be returned.
colas@0
  1608
colas@0
  1609
If =$tml= is not set, all HTML will be removed.
colas@0
  1610
colas@0
  1611
In non-tml, lines are truncated to 70 characters. Differences are shown using + and - to indicate added and removed text.
colas@0
  1612
colas@0
  1613
=cut
colas@0
  1614
colas@0
  1615
sub summariseChanges {
colas@0
  1616
    my( $this, $user, $web, $topic, $orev, $nrev, $tml ) = @_;
colas@0
  1617
    my $summary = '';
colas@0
  1618
    my $store = $this->{session}->{store};
colas@0
  1619
colas@0
  1620
    $orev = $nrev - 1 unless (defined($orev) || !defined($nrev));
colas@0
  1621
colas@0
  1622
    my( $nmeta, $ntext ) = $store->readTopic( $user, $web, $topic, $nrev );
colas@0
  1623
colas@0
  1624
    if( $nrev && $nrev > 1 && $orev ne $nrev ) {
colas@0
  1625
        my $metaPick = qr/^[A-Z](?!OPICINFO)/; # all except TOPICINFO
colas@0
  1626
        # there was a prior version. Diff it.
colas@0
  1627
        $ntext = $this->TML2PlainText(
colas@0
  1628
            $ntext, $web, $topic, 'nonop' )."\n".
colas@0
  1629
              $nmeta->stringify( $metaPick );
colas@0
  1630
colas@0
  1631
        my( $ometa, $otext ) = $store->readTopic( $user, $web, $topic, $orev );
colas@0
  1632
        $otext = $this->TML2PlainText(
colas@0
  1633
            $otext, $web, $topic, 'nonop' )."\n".
colas@0
  1634
              $ometa->stringify( $metaPick );
colas@0
  1635
colas@0
  1636
	require TWiki::Merge;
colas@0
  1637
        my $blocks = TWiki::Merge::simpleMerge( $otext, $ntext, qr/[\r\n]+/ );
colas@0
  1638
        # sort through, keeping one line of context either side of a change
colas@0
  1639
        my @revised;
colas@0
  1640
        my $getnext = 0;
colas@0
  1641
        my $prev = '';
colas@0
  1642
        my $ellipsis = $tml ? '&hellip;' : '...';
colas@0
  1643
        my $trunc = $tml ? $TMLTRUNC : $PLAINTRUNC;
colas@0
  1644
        while ( scalar @$blocks && scalar( @revised ) < $SUMMARYLINES ) {
colas@0
  1645
            my $block = shift( @$blocks );
colas@0
  1646
            next unless $block =~ /\S/;
colas@0
  1647
            my $trim = length($block) > $trunc;
colas@0
  1648
            $block =~ s/^(.{$trunc}).*$/$1/ if( $trim );
colas@0
  1649
            if ( $block =~ m/^[-+]/ ) {
colas@0
  1650
                if( $tml ) {
colas@0
  1651
                    $block =~ s/^-(.*)$/CGI::del( $1 )/se;
colas@0
  1652
                    $block =~ s/^\+(.*)$/CGI::ins( $1 )/se;
colas@0
  1653
                } elsif ( $this->{session}->inContext('rss')) {
colas@0
  1654
                    $block =~ s/^-/REMOVED: /;
colas@0
  1655
                    $block =~ s/^\+/INSERTED: /;
colas@0
  1656
                }
colas@0
  1657
                push( @revised, $prev ) if $prev;
colas@0
  1658
                $block .= $ellipsis if $trim;
colas@0
  1659
                push( @revised, $block );
colas@0
  1660
                $getnext = 1;
colas@0
  1661
                $prev = '';
colas@0
  1662
            } else {
colas@0
  1663
                if( $getnext ) {
colas@0
  1664
                    $block .= $ellipsis if $trim;
colas@0
  1665
                    push( @revised, $block );
colas@0
  1666
                    $getnext = 0;
colas@0
  1667
                    $prev = '';
colas@0
  1668
                } else {
colas@0
  1669
                    $prev = $block;
colas@0
  1670
                }
colas@0
  1671
            }
colas@0
  1672
        }
colas@0
  1673
        if( $tml ) {
colas@0
  1674
            $summary = join(CGI::br(), @revised );
colas@0
  1675
        } else {
colas@0
  1676
            $summary = join("\n", @revised );
colas@0
  1677
        }
colas@0
  1678
    }
colas@0
  1679
colas@0
  1680
    unless( $summary ) {
colas@0
  1681
        $summary = $this->makeTopicSummary( $ntext, $topic, $web );
colas@0
  1682
    }
colas@0
  1683
colas@0
  1684
    if( ! $tml ) {
colas@0
  1685
        $summary = $this->protectPlainText( $summary );
colas@0
  1686
    }
colas@0
  1687
    return $summary;
colas@0
  1688
}
colas@0
  1689
colas@0
  1690
=pod
colas@0
  1691
colas@0
  1692
---++ ObjectMethod forEachLine( $text, \&fn, \%options ) -> $newText
colas@0
  1693
colas@0
  1694
Iterate over each line, calling =\&fn= on each.
colas@0
  1695
\%options may contain:
colas@0
  1696
   * =pre= => true, will call fn for each line in pre blocks
colas@0
  1697
   * =verbatim= => true, will call fn for each line in verbatim blocks
colas@0
  1698
   * =literal= => true, will call fn for each line in literal blocks
colas@0
  1699
   * =noautolink= => true, will call fn for each line in =noautolink= blocks
colas@0
  1700
The spec of \&fn is =sub fn( $line, \%options ) -> $newLine=. The %options
colas@0
  1701
hash passed into this function is passed down to the sub, and the keys
colas@0
  1702
=in_literal=, =in_pre=, =in_verbatim= and =in_noautolink= are set boolean
colas@0
  1703
TRUE if the line is from one (or more) of those block types.
colas@0
  1704
colas@0
  1705
The return result replaces $line in $newText.
colas@0
  1706
colas@0
  1707
=cut
colas@0
  1708
colas@0
  1709
sub forEachLine {
colas@0
  1710
    my( $this, $text, $fn, $options ) = @_;
colas@0
  1711
colas@0
  1712
    $options->{in_pre} = 0;
colas@0
  1713
    $options->{in_pre} = 0;
colas@0
  1714
    $options->{in_verbatim} = 0;
colas@0
  1715
    $options->{in_literal} = 0;
colas@0
  1716
    $options->{in_noautolink} = 0;
colas@0
  1717
    my $newText = '';
colas@0
  1718
    foreach my $line ( split( /([\r\n]+)/, $text ) ) {
colas@0
  1719
        if( $line =~ /[\r\n]/ ) {
colas@0
  1720
            $newText .= $line;
colas@0
  1721
            next;
colas@0
  1722
        }
colas@0
  1723
        $options->{in_verbatim}++ if( $line =~ m|^\s*<verbatim\b[^>]*>\s*$|i );
colas@0
  1724
        $options->{in_verbatim}-- if( $line =~ m|^\s*</verbatim>\s*$|i );
colas@0
  1725
        $options->{in_literal}++ if( $line =~ m|^\s*<literal\b[^>]*>\s*$|i );
colas@0
  1726
        $options->{in_literal}-- if( $line =~ m|^\s*</literal>\s*$|i );
colas@0
  1727
        unless (( $options->{in_verbatim} > 0 ) || (( $options->{in_literal} > 0 ))){
colas@0
  1728
            $options->{in_pre}++ if( $line =~ m|<pre\b|i );
colas@0
  1729
            $options->{in_pre}-- if( $line =~ m|</pre>|i );
colas@0
  1730
            $options->{in_noautolink}++ if( $line =~ m|^\s*<noautolink\b[^>]*>\s*$|i );
colas@0
  1731
            $options->{in_noautolink}-- if( $line =~ m|^\s*</noautolink>\s*|i );
colas@0
  1732
        }
colas@0
  1733
        unless( $options->{in_pre} > 0 && !$options->{pre} ||
colas@0
  1734
                $options->{in_verbatim} > 0 && !$options->{verbatim} ||
colas@0
  1735
                $options->{in_literal} > 0 && !$options->{literal} ||
colas@0
  1736
                $options->{in_noautolink} > 0 && !$options->{noautolink} ) {
colas@0
  1737
            $line = &$fn( $line, $options );
colas@0
  1738
        }
colas@0
  1739
        $newText .= $line;
colas@0
  1740
    }
colas@0
  1741
    return $newText;
colas@0
  1742
}
colas@0
  1743
colas@0
  1744
=pod
colas@0
  1745
colas@0
  1746
---++ StaticMethod getReferenceRE($web, $topic, %options) -> $re
colas@0
  1747
colas@0
  1748
   * $web, $topic - specify the topic being referred to, or web if $topic is
colas@0
  1749
     undef.
colas@0
  1750
   * %options - the following options are available
colas@0
  1751
      * =interweb= - if true, then fully web-qualified references are required.
colas@0
  1752
      * =grep= - if true, generate a GNU-grep compatible RE instead of the
colas@0
  1753
        default Perl RE.
colas@0
  1754
      * =url= - if set, generates an expression that will match a TWiki
colas@0
  1755
        URL that points to the web/topic, instead of the default which
colas@0
  1756
        matches topic links in plain text.
colas@0
  1757
Generate a regular expression that can be used to match references to the
colas@0
  1758
specified web/topic. Note that the resultant RE will only match fully
colas@0
  1759
qualified (i.e. with web specifier) topic names and topic names that
colas@0
  1760
are wikiwords in text. Works for spaced-out wikiwords for topic names.
colas@0
  1761
colas@0
  1762
The RE returned is designed to be used with =s///=
colas@0
  1763
colas@0
  1764
=cut
colas@0
  1765
colas@0
  1766
sub getReferenceRE {
colas@0
  1767
    my( $web, $topic, %options) = @_;
colas@0
  1768
colas@0
  1769
    my $matchWeb = $web;
colas@0
  1770
    # Convert . and / to [./] (subweb separators)
colas@0
  1771
    $matchWeb =~ s#[./]#[./]#go;
colas@0
  1772
colas@0
  1773
    # Note use of \< and \> to match the empty string at the
colas@0
  1774
    # edges of a word.
colas@0
  1775
    my( $bow, $eow, $forward, $back ) = ( '\b', '\b', '?=', '?<=' );
colas@0
  1776
    if( $options{grep} ) {
colas@0
  1777
        $bow = '\<';
colas@0
  1778
        $eow = '\>';
colas@0
  1779
        $forward = '';
colas@0
  1780
        $back = '';
colas@0
  1781
    }
colas@0
  1782
    my $squabo = "($back\\[\\[)";
colas@0
  1783
    my $squabc = "($forward\\][][])";
colas@0
  1784
colas@0
  1785
    my $re;
colas@0
  1786
colas@0
  1787
    if( $options{url} ) {
colas@0
  1788
        # URL fragment. Assume / separator (while . is legal, it's
colas@0
  1789
        # undocumented and is not common usage)
colas@0
  1790
        $re = "/$web/";
colas@0
  1791
        $re .= $topic.$eow if $topic;
colas@0
  1792
    } else {
colas@0
  1793
        if( defined( $topic )) {
colas@0
  1794
            # Work out spaced-out version (allows lc first chars on words)
colas@0
  1795
            my $sot = TWiki::spaceOutWikiWord( $topic, ' *' );
colas@0
  1796
            if( $sot ne $topic ) {
colas@0
  1797
                $sot =~ s/\b([a-zA-Z])/'['.uc($1).lc($1).']'/ge;
colas@0
  1798
            } else {
colas@0
  1799
                $sot = undef;
colas@0
  1800
            }
colas@0
  1801
colas@0
  1802
            if( $options{interweb} ) {
colas@0
  1803
                # Require web specifier
colas@0
  1804
                $re = "$bow$matchWeb\\.$topic$eow";
colas@0
  1805
                if( $sot ) {
colas@0
  1806
                    # match spaced out in squabs only
colas@0
  1807
                    $re .= "|$squabo$matchWeb\\.$sot$squabc";
colas@0
  1808
                }
colas@0
  1809
            } else {
colas@0
  1810
                # Optional web specifier - but *only* if the topic name
colas@0
  1811
                # is a wikiword
colas@0
  1812
                if( $topic =~ /$TWiki::regex{wikiWordRegex}/ ) {
colas@0
  1813
                    # Bit of jigger-pokery at the front to avoid matching
colas@0
  1814
                    # subweb specifiers
colas@0
  1815
                    $re = "(($back\[^./])|^)$bow($matchWeb\\.)?$topic$eow";
colas@0
  1816
                    if( $sot ) {
colas@0
  1817
                        # match spaced out in squabs only
colas@0
  1818
                        $re .= "|$squabo($matchWeb\\.)?$sot$squabc";
colas@0
  1819
                    }
colas@0
  1820
                } else {
colas@0
  1821
                    # Non-wikiword; require web specifier or squabs
colas@0
  1822
                    $re = "(($back\[^./])|^)$bow$matchWeb\\.$topic$eow";
colas@0
  1823
                    $re .= "|$squabo$topic$squabc";
colas@0
  1824
                }
colas@0
  1825
            }
colas@0
  1826
        } else {
colas@0
  1827
            # Searching for a web
colas@0
  1828
            if( $options{interweb} ) {
colas@0
  1829
                # web name used to refer to a topic
colas@0
  1830
                $re = $bow.'\.'.$matchWeb.'\.[A-Za-z0-9]+'.$eow;
colas@0
  1831
            } else {
colas@0
  1832
                # most general search for a reference to a topic or subweb
colas@0
  1833
                $re = $bow.$matchWeb.'\.[A-Za-z0-9]+'.$eow;
colas@0
  1834
            }
colas@0
  1835
        }
colas@0
  1836
    }
colas@0
  1837
colas@0
  1838
    return $re;
colas@0
  1839
}
colas@0
  1840
colas@0
  1841
=pod
colas@0
  1842
colas@0
  1843
---++ StaticMethod replaceTopicReferences( $text, \%options ) -> $text
colas@0
  1844
colas@0
  1845
Callback designed for use with forEachLine, to replace topic references.
colas@0
  1846
\%options contains:
colas@0
  1847
   * =oldWeb= => Web of reference to replace
colas@0
  1848
   * =oldTopic= => Topic of reference to replace
colas@0
  1849
   * =newWeb= => Web of new reference
colas@0
  1850
   * =newTopic= => Topic of new reference
colas@0
  1851
   * =inWeb= => the web which the text we are presently processing resides in
colas@0
  1852
   * =fullPaths= => optional, if set forces all links to full web.topic form
colas@0
  1853
For a usage example see TWiki::UI::Manage.pm
colas@0
  1854
colas@0
  1855
=cut
colas@0
  1856
colas@0
  1857
sub replaceTopicReferences {
colas@0
  1858
    my( $text, $args ) = @_;
colas@0
  1859
colas@0
  1860
    ASSERT(defined $args->{oldWeb}) if DEBUG;
colas@0
  1861
    ASSERT(defined $args->{oldTopic}) if DEBUG;
colas@0
  1862
colas@0
  1863
    ASSERT(defined $args->{newWeb}) if DEBUG;
colas@0
  1864
    ASSERT(defined $args->{newTopic}) if DEBUG;
colas@0
  1865
colas@0
  1866
    ASSERT(defined $args->{inWeb}) if DEBUG;
colas@0
  1867
colas@0
  1868
    # Do the traditional TWiki topic references first
colas@0
  1869
    my $oldTopic = $args->{oldTopic};
colas@0
  1870
    my $newTopic = $args->{newTopic};
colas@0
  1871
    my $repl = $newTopic;
colas@0
  1872
colas@0
  1873
    # Canonicalise web names by converting . to /
colas@0
  1874
    my $inWeb = $args->{inWeb}; $inWeb =~ s#\.#/#g;
colas@0
  1875
    my $newWeb = $args->{newWeb}; $newWeb =~ s#\.#/#g;
colas@0
  1876
    my $oldWeb = $args->{oldWeb}; $oldWeb =~ s#\.#/#g;
colas@0
  1877
    my $sameWeb = ($oldWeb eq $newWeb);
colas@0
  1878
colas@0
  1879
    if( $inWeb ne $newWeb || $args->{fullPaths} ) {
colas@0
  1880
        $repl = $newWeb.'.'.$repl;
colas@0
  1881
    }
colas@0
  1882
colas@0
  1883
    my $re = getReferenceRE( $oldWeb, $oldTopic );
colas@0
  1884
colas@0
  1885
    $text =~ s/($re)/_doReplace($1, $newWeb, $repl)/ge;
colas@0
  1886
colas@0
  1887
    # Now URL form
colas@0
  1888
    $repl = "/$newWeb/$newTopic";
colas@0
  1889
    $re = getReferenceRE( $oldWeb, $oldTopic, url => 1);
colas@0
  1890
    $text =~ s/$re/$repl/g;
colas@0
  1891
colas@0
  1892
    return $text;
colas@0
  1893
}
colas@0
  1894
colas@0
  1895
sub _doReplace {
colas@0
  1896
    my ($match, $web, $repl) = @_;
colas@0
  1897
    # Bugs:Item4661 If there is a web defined in the match, then
colas@0
  1898
    # make sure there's a web defined in the replacement.
colas@0
  1899
    if ($match =~ /\./ && $repl !~ /\./) {
colas@0
  1900
        $repl = "$web.$repl";
colas@0
  1901
    }
colas@0
  1902
    return $repl;
colas@0
  1903
}
colas@0
  1904
colas@0
  1905
=pod
colas@0
  1906
colas@0
  1907
---++ StaticMethod replaceWebReferences( $text, \%options ) -> $text
colas@0
  1908
colas@0
  1909
Callback designed for use with forEachLine, to replace web references.
colas@0
  1910
\%options contains:
colas@0
  1911
   * =oldWeb= => Web of reference to replace
colas@0
  1912
   * =newWeb= => Web of new reference
colas@0
  1913
For a usage example see TWiki::UI::Manage.pm
colas@0
  1914
colas@0
  1915
=cut
colas@0
  1916
colas@0
  1917
sub replaceWebReferences {
colas@0
  1918
    my( $text, $args ) = @_;
colas@0
  1919
colas@0
  1920
    ASSERT(defined $args->{oldWeb}) if DEBUG;
colas@0
  1921
    ASSERT(defined $args->{newWeb}) if DEBUG;
colas@0
  1922
colas@0
  1923
    my $newWeb = $args->{newWeb}; $newWeb =~ s#\.#/#g;
colas@0
  1924
    my $oldWeb = $args->{oldWeb}; $oldWeb =~ s#\.#/#g;
colas@0
  1925
colas@0
  1926
    return $text if $oldWeb eq $newWeb;
colas@0
  1927
colas@0
  1928
    my $re = getReferenceRE( $oldWeb, undef);
colas@0
  1929
colas@0
  1930
    $text =~ s/$re/$newWeb/g;
colas@0
  1931
colas@0
  1932
    $re = getReferenceRE( $oldWeb, undef, url => 1);
colas@0
  1933
colas@0
  1934
    $text =~ s#$re#/$newWeb/#g;
colas@0
  1935
colas@0
  1936
    return $text;
colas@0
  1937
}
colas@0
  1938
colas@0
  1939
=pod
colas@0
  1940
colas@0
  1941
---++ ObjectMethod replaceWebInternalReferences( \$text, \%meta, $oldWeb, $oldTopic )
colas@0
  1942
colas@0
  1943
Change within-web wikiwords in $$text and $meta to full web.topic syntax.
colas@0
  1944
colas@0
  1945
\%options must include topics => list of topics that must have references
colas@0
  1946
to them changed to include the web specifier.
colas@0
  1947
colas@0
  1948
=cut
colas@0
  1949
colas@0
  1950
sub replaceWebInternalReferences {
colas@0
  1951
    my( $this, $text, $meta, $oldWeb, $oldTopic, $newWeb, $newTopic ) = @_;
colas@0
  1952
colas@0
  1953
    my @topics = $this->{session}->{store}->getTopicNames( $oldWeb );
colas@0
  1954
    my $options =
colas@0
  1955
      {
colas@0
  1956
       # exclude this topic from the list
colas@0
  1957
          topics => [ grep { !/^$oldTopic$/ } @topics ],
colas@0
  1958
       inWeb => $oldWeb,
colas@0
  1959
          inTopic => $oldTopic,
colas@0
  1960
       oldWeb => $oldWeb,
colas@0
  1961
          newWeb => $oldWeb,
colas@0
  1962
      };
colas@0
  1963
colas@0
  1964
    $$text = $this->forEachLine( $$text, \&_replaceInternalRefs, $options );
colas@0
  1965
colas@0
  1966
    $meta->forEachSelectedValue( qw/^(FIELD|TOPICPARENT)$/, undef,
colas@0
  1967
                                 \&_replaceInternalRefs, $options );
colas@0
  1968
    $meta->forEachSelectedValue( qw/^TOPICMOVED$/, qw/^by$/,
colas@0
  1969
                                 \&_replaceInternalRefs, $options );
colas@0
  1970
    $meta->forEachSelectedValue( qw/^FILEATTACHMENT$/, qw/^user$/,
colas@0
  1971
                                 \&_replaceInternalRefs, $options );
colas@0
  1972
colas@0
  1973
    ## Ok, let's do it again, but look for links to topics in the new web and remove their full paths
colas@0
  1974
    @topics = $this->{session}->{store}->getTopicNames( $newWeb );
colas@0
  1975
    $options =
colas@0
  1976
      {
colas@0
  1977
          # exclude this topic from the list
colas@0
  1978
          topics => [ @topics ],
colas@0
  1979
          fullPaths => 0,
colas@0
  1980
          inWeb => $newWeb,
colas@0
  1981
          inTopic => $oldTopic,
colas@0
  1982
          oldWeb => $newWeb,
colas@0
  1983
          newWeb => $newWeb,
colas@0
  1984
      };
colas@0
  1985
colas@0
  1986
    $$text = $this->forEachLine( $$text, \&_replaceInternalRefs, $options );
colas@0
  1987
colas@0
  1988
    $meta->forEachSelectedValue( qw/^(FIELD|TOPICPARENT)$/, undef,
colas@0
  1989
                                 \&_replaceInternalRefs, $options );
colas@0
  1990
    $meta->forEachSelectedValue( qw/^TOPICMOVED$/, qw/^by$/,
colas@0
  1991
                                 \&_replaceInternalRefs, $options );
colas@0
  1992
    $meta->forEachSelectedValue( qw/^FILEATTACHMENT$/, qw/^user$/,
colas@0
  1993
                                 \&_replaceInternalRefs, $options );
colas@0
  1994
colas@0
  1995
}
colas@0
  1996
colas@0
  1997
# callback used by replaceWebInternalReferences
colas@0
  1998
sub _replaceInternalRefs {
colas@0
  1999
    my( $text, $args ) = @_;
colas@0
  2000
    foreach my $topic ( @{$args->{topics}} ) {
colas@0
  2001
        $args->{fullPaths} =  ( $topic ne $args->{inTopic} ) if (!defined($args->{fullPaths}));
colas@0
  2002
        $args->{oldTopic} = $topic;
colas@0
  2003
        $args->{newTopic} = $topic;
colas@0
  2004
        $text = replaceTopicReferences( $text, $args );
colas@0
  2005
    }
colas@0
  2006
    return $text;
colas@0
  2007
}
colas@0
  2008
colas@0
  2009
=pod
colas@0
  2010
colas@0
  2011
---++ StaticMethod breakName( $text, $args) -> $text
colas@0
  2012
colas@0
  2013
   * =$text= - text to "break"
colas@0
  2014
   * =$args= - string of format (\d+)([,\s*]\.\.\.)?)
colas@0
  2015
Hyphenates $text every $1 characters, or if $2 is "..." then shortens to
colas@0
  2016
$1 characters and appends "..." (making the final string $1+3 characters
colas@0
  2017
long)
colas@0
  2018
colas@0
  2019
_Moved from Search.pm because it was obviously unhappy there,
colas@0
  2020
as it is a rendering function_
colas@0
  2021
colas@0
  2022
=cut
colas@0
  2023
colas@0
  2024
sub breakName {
colas@0
  2025
    my( $text, $args ) = @_;
colas@0
  2026
colas@0
  2027
    my @params = split( /[\,\s]+/, $args, 2 );
colas@0
  2028
    if( @params ) {
colas@0
  2029
        my $len = $params[0] || 1;
colas@0
  2030
        $len = 1 if( $len < 1 );
colas@0
  2031
        my $sep = '- ';
colas@0
  2032
        $sep = $params[1] if( @params > 1 );
colas@0
  2033
        if( $sep =~ /^\.\.\./i ) {
colas@0
  2034
            # make name shorter like 'ThisIsALongTop...'
colas@0
  2035
            $text =~ s/(.{$len})(.+)/$1.../s;
colas@0
  2036
colas@0
  2037
        } else {
colas@0
  2038
            # split and hyphenate the topic like 'ThisIsALo- ngTopic'
colas@0
  2039
            $text =~ s/(.{$len})/$1$sep/gs;
colas@0
  2040
            $text =~ s/$sep$//;
colas@0
  2041
        }
colas@0
  2042
    }
colas@0
  2043
    return $text;
colas@0
  2044
}
colas@0
  2045
colas@0
  2046
=pod
colas@0
  2047
colas@0
  2048
---++ StaticMethod protectFormFieldValue($value, $attrs) -> $html
colas@0
  2049
colas@0
  2050
Given the value of a form field, and a set of attributes that control how
colas@0
  2051
to display that value, protect the value from further processing.
colas@0
  2052
colas@0
  2053
The protected value is determined from the value of the field after:
colas@0
  2054
   * newlines are replaced with &lt;br> or the value of $attrs->{newline}
colas@0
  2055
   * processing through breakName if $attrs->{break} is defined
colas@0
  2056
   * escaping of $vars if $attrs->{protectdollar} is defined
colas@0
  2057
   * | is replaced with &amp;#124; or the value of $attrs->{bar} if defined
colas@0
  2058
colas@0
  2059
=cut
colas@0
  2060
colas@0
  2061
sub protectFormFieldValue {
colas@0
  2062
    my( $value, $attrs ) = @_;
colas@0
  2063
colas@0
  2064
    $value = '' unless defined( $value );
colas@0
  2065
colas@0
  2066
    if( $attrs && $attrs->{break} ) {
colas@0
  2067
        $value =~ s/^\s*(.*?)\s*$/$1/g;
colas@0
  2068
        $value = breakName( $value, $attrs->{break} );
colas@0
  2069
    }
colas@0
  2070
colas@0
  2071
    # Item3489, Item2837. Prevent $vars in formfields from
colas@0
  2072
    # being expanded in formatted searches.
colas@0
  2073
    if( $attrs && $attrs->{protectdollar}) {
colas@0
  2074
        $value =~ s/\$(n|nop|quot|percnt|dollar)/\$<nop>$1/g;
colas@0
  2075
    }
colas@0
  2076
colas@0
  2077
    # change newlines
colas@0
  2078
    my $newline = '<br />';
colas@0
  2079
    if( $attrs && defined $attrs->{newline} ) {
colas@0
  2080
        $newline = $attrs->{newline};
colas@0
  2081
        $newline =~ s/\$n/\n/gs;
colas@0
  2082
    }
colas@0
  2083
    $value =~ s/\r?\n/$newline/gs;
colas@0
  2084
colas@0
  2085
    # change vbars
colas@0
  2086
    my $bar = '&#124;';
colas@0
  2087
    if( $attrs && $attrs->{bar} ) {
colas@0
  2088
        $bar = $attrs->{bar};
colas@0
  2089
    }
colas@0
  2090
    $value =~ s/\|/$bar/g;
colas@0
  2091
colas@0
  2092
    return $value;
colas@0
  2093
}
colas@0
  2094
colas@0
  2095
1;
colas@0
  2096
__DATA__
colas@0
  2097
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0
  2098
#
colas@0
  2099
# Copyright (C) 2001-2007 Peter Thoeny, peter@thoeny.org
colas@0
  2100
# and TWiki Contributors. All Rights Reserved. TWiki Contributors
colas@0
  2101
# are listed in the AUTHORS file in the root of this distribution.
colas@0
  2102
# NOTE: Please extend that file, not this notice.
colas@0
  2103
#
colas@0
  2104
# This program is free software; you can redistribute it and/or
colas@0
  2105
# modify it under the terms of the GNU General Public License
colas@0
  2106
# as published by the Free Software Foundation; either version 2
colas@0
  2107
# of the License, or (at your option) any later version. For
colas@0
  2108
# more details read LICENSE in the root of this distribution.
colas@0
  2109
#
colas@0
  2110
# This program is distributed in the hope that it will be useful,
colas@0
  2111
# but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0
  2112
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0
  2113
#
colas@0
  2114
# As per the GPL, removal of this notice is prohibited.