1# Plugin for TWiki Collaboration Platform, http://TWiki.org/
2#
3# Copyright (C) 2006 Peter Thoeny, peter@thoeny.org
4# Copyright (c) 2006 Fred Morris, m3047-twiki@inwa.net
5# Copyright (c) 2007 Crawford Currie, http://c-dot.co.uk
6# Copyright (c) 2007 Sven Dowideit, SvenDowideit@DistributedINFORMATION.com
7# Copyright (c) 2007 Arthur Clemens, arthur@visiblearea.com
8#
9# This program is free software; you can redistribute it and/or
10# modify it under the terms of the GNU General Public License
11# as published by the Free Software Foundation; either version 2
12# of the License, or (at your option) any later version.
13#
14# This program is distributed in the hope that it will be useful,
15# but WITHOUT ANY WARRANTY; without even the implied warranty of
16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17# GNU General Public License for more details, published at
18# http://www.gnu.org/copyleft/gpl.html
19#
20# =========================
21#
22# This Plugin implements tags in TWiki.
23
24# =========================
25package TWiki::Plugins::TagMePlugin;
26
27use strict;
28
29# =========================
30use vars qw(
31  $web $topic $user $installWeb $VERSION $RELEASE $pluginName $debug
32  $initialized $workAreaDir $attachUrl $logAction $tagLinkFormat
33  $tagQueryFormat $alphaNum $doneHeader $normalizeTagInput $lineRegex
34  $topicsRegex $action $style $label $header $footer $button
35);
36
37$VERSION    = '1.049';
38$RELEASE    = 'TWiki 4';
39$pluginName = 'TagMePlugin';    # Name of this Plugin
40
41$initialized = 0;
42$lineRegex   = "^0*([0-9]+), ([^,]+), (.*)";
43my $tagChangeRequestTopic = 'TagMeChangeRequests';
44my $tagChangeRequestLink =
45  "[[$tagChangeRequestTopic][Tag change requests]]";
46
47BEGIN {
48
49    # I18N initialization
50    if ( $TWiki::cfg{UseLocale} ) {
51        require locale;
52        import locale();
53    }
54}
55
56# =========================
57sub initPlugin {
58    ( $topic, $web, $user, $installWeb ) = @_;
59
60    # check for Plugins.pm versions
61    if ( $TWiki::Plugins::VERSION < 1.024 ) {
62        TWiki::Func::writeWarning(
63            "Version mismatch between $pluginName and Plugins.pm");
64        return 0;
65    }
66
67    # Get plugin debug flag
68    $debug = TWiki::Func::getPreferencesFlag('TAGMEPLUGIN_DEBUG');
69    $normalizeTagInput = TWiki::Func::getPreferencesFlag('TAGMEPLUGIN_NORMALIZE_TAG_INPUT');
70
71    _writeDebug("initPlugin( $web.$topic ) is OK");
72    $initialized = 0;
73    $doneHeader  = 0;
74
75    return 1;
76}
77
78# =========================
79sub _initialize {
80    return if ($initialized);
81
82    # Initialization
83    $workAreaDir = TWiki::Func::getWorkArea($pluginName);
84    $attachUrl = TWiki::Func::getPubUrlPath() . "/$installWeb/$pluginName";
85    $logAction = TWiki::Func::getPreferencesFlag("\U$pluginName\E_LOGACTION");
86    $tagLinkFormat =
87        '<a href="%SCRIPTURL{view}%/'
88      . $installWeb
89      . '/TagMeSearch?tag=$tag;by=$by">$tag</a>';
90    $tagQueryFormat =
91'<table class="tagmeResultsTable tagmeResultsTableHeader" cellpadding="0" cellspacing="0" border="0"><tr>$n'
92      . '<td class="tagmeTopicTd"> <b>[[$web.$topic][<nop>$topic]]</b> '
93      . '<span class="tagmeTopicTdWeb">in <nop>$web web</span></td>$n'
94      . '<td class="tagmeDateTd">'
95      . '[[%SCRIPTURL{rdiff}%/$web/$topic][$date]] - r$rev </td>$n'
96      . '<td class="tagmeAuthorTd"> $wikiusername </td>$n'
97      . '</tr></table>$n'
98      . '<p class="tagmeResultsDetails">'
99      . '<span class="tagmeResultsSummary">$summary</span>%BR% $n'
100      . '<span class="tagmeResultsTags">Tags: $taglist</span>' . '</p>';
101    $alphaNum = TWiki::Func::getRegularExpression('mixedAlphaNum');
102
103    _addHeader();
104
105    $initialized = 1;
106}
107
108# =========================
109sub afterSaveHandler {
110### my ( $text, $topic, $web, $error, $meta ) = @_;
111
112    _writeDebug("afterSaveHandler( $_[2].$_[1] )");
113
114    my $newTopic = $_[1];
115    my $newWeb   = $_[2];
116    if ( "$newWeb.$newTopic" ne "$web.$topic"
117        && $topic ne $TWiki::cfg{HomeTopicName} )
118    {
119
120        # excluding WebHome due to TWiki 4 bug on statistics viewed as WebHome
121        # and saved as WebStatistics
122        _writeDebug(" - topic renamed from $web.$topic to $newWeb.$newTopic");
123        _initialize();
124        renameTagInfo( "$web.$topic", "$newWeb.$newTopic" );
125    }
126}
127
128# =========================
129sub commonTagsHandler {
130### my ( $text, $topic, $web ) = @_;   # do not uncomment, use $_[0], $_[1]... instead
131
132    _writeDebug("commonTagsHandler( $_[2].$_[1] )");
133    $_[0] =~ s/%TAGME{(.*?)}%/_handleTagMe($1)/ge;
134}
135
136# =========================
137sub _addHeader {
138    return if $doneHeader;
139
140    my $header =
141"\n<style type=\"text/css\" media=\"all\">\n\@import url(\"$attachUrl/tagme.css\");\n</style>\n";
142    TWiki::Func::addToHEAD( 'TAGMEPLUGIN', $header );
143    $doneHeader = 1;
144}
145
146# =========================
147sub _handleTagMe {
148    my ($attr) = @_;
149    $action = TWiki::Func::extractNameValuePair( $attr, 'tpaction' );
150    $style = TWiki::Func::extractNameValuePair( $attr, 'style' );
151    $label = TWiki::Func::extractNameValuePair( $attr, 'label' );
152    $button = TWiki::Func::extractNameValuePair( $attr, 'button' );
153    $header = TWiki::Func::extractNameValuePair( $attr, 'header' );
154    $header =~ s/\$n/\n/go;
155    $footer = TWiki::Func::extractNameValuePair( $attr, 'footer' );
156    $footer =~ s/\$n/\n/go;
157    my $text = '';
158    _initialize();
159
160    if ( $action eq 'show' ) {
161	$text = _showDefault();
162    }
163    elsif ( $action eq 'showalltags' ) {
164        $text = _showAllTags($attr);
165    }
166    elsif ( $action eq 'query' ) {
167        $text = _queryTag($attr);
168    }
169    elsif ( $action eq 'newtag' ) {
170        $text = _newTag($attr);
171    }
172    elsif ( $action eq 'newtagsandadd' ) {
173        $text = _newTagsAndAdd($attr);
174    }
175    elsif ( $action eq 'autonewadd' ) {
176        $text = _newTag($attr, 'silent', 1);
177        $text = _addTag($attr) unless $text =~ /twikiAlert/;
178    }
179    elsif ( $action eq 'add' ) {
180        $text = _addTag($attr);
181    }
182    elsif ( $action eq 'remove' ) {
183        $text = _removeTag($attr);
184    }
185    elsif ( $action eq 'removeall' ) {
186        $text = _removeAllTag($attr);
187    }
188    elsif ( $action eq 'renametag' ) {
189        $text = _renameTag($attr);
190    }
191    elsif ( $action eq 'renametaginit' ) {
192        $text = _modifyTagInit( 'rename', $attr );
193    }
194    elsif ( $action eq 'deletetag' ) {
195        $text = _deleteTag($attr);
196    }
197    elsif ( $action eq 'deletethetag' ) {
198        $text = _deleteTheTag($attr);
199    }
200    elsif ( $action eq 'deletetaginit' ) {
201        $text = _modifyTagInit( 'delete', $attr );
202    }
203    elsif ( $action eq 'nop' ) {
204
205        # no operation
206    }
207    elsif ($action) {
208        $text = 'Unrecognized action';
209    }
210    else {
211	$text = _showDefault();
212    }
213    return $text;
214}
215
216# =========================
217sub _showDefault {
218    my (@tagInfo) = @_;
219
220    return '' unless ( TWiki::Func::topicExists( $web, $topic ) );
221
222    # overriden by the relevant "show" functions for each style
223    if ($style eq 'blog') {
224	return _showStyleBlog(@tagInfo);
225    }
226
227    my $query = TWiki::Func::getCgiQuery();
228    my $tagMode = $query->param('tagmode') || '';
229
230    my $webTopic = "$web.$topic";
231    @tagInfo = _readTagInfo($webTopic) unless ( scalar(@tagInfo) );
232    my $text  = '';
233    my $tag   = '';
234    my $num   = '';
235    my $users = '';
236    my $line  = '';
237    my %seen  = ();
238    foreach (@tagInfo) {
239
240        # Format:  3 digit number of users, tag, comma delimited list of users
241        # Example: 004, usability, UserA, UserB, UserC, UserD
242        # SMELL: This format is a quick hack for easy sorting, parsing, and
243        # for fast rendering
244        if (/$lineRegex/) {
245            $num   = $1;
246            $tag   = $2;
247            $users = $3;
248            $line =
249              _printTagLink( $tag, '' )
250              . "<span class=\"tagMeVoteCount\">$num</span>";
251            if ( $users =~ /\b$user\b/ ) {
252                $line .= _imgTag( 'tag_remove', 'Remove my vote on this tag',
253                    'remove', $tag, $tagMode );
254            }
255            else {
256                $line .= _imgTag( 'tag_add', 'Add my vote for this tag',
257                    'add', $tag, $tagMode );
258            }
259            $seen{$tag} = _wrapHtmlTagControl($line);
260        }
261    }
262    if ($normalizeTagInput) {
263
264        # plain sort can be used and should be just a little faster
265        $text .= join( ' ', map { $seen{$_} } sort keys(%seen) );
266    }
267    else {
268
269        # uppercase characters are possible, so sort with lowercase comparison
270        $text .=
271          join( ' ', map { $seen{$_} } sort { lc $a cmp lc $b } keys(%seen) );
272    }
273    my @allTags = _readAllTags();
274    my @notSeen = ();
275    foreach (@allTags) {
276        push( @notSeen, $_ ) unless ( $seen{$_} );
277    }
278    if ( scalar @notSeen ) {
279        if ( $tagMode eq 'nojavascript' ) {
280            $text .= _createNoJavascriptSelectBox(@notSeen);
281        }
282        else {
283            $text .= _createJavascriptSelectBox(@notSeen);
284        }
285    }
286    $text .= ' '.
287      _wrapHtmlTagControl("<a href=\"%SCRIPTURL{viewauth}%/$installWeb/TagMeCreateNewTag".
288        "?from=$web.$topic\">create new tag</a>");
289
290    return _wrapHtmlTagMeShowForm($text);
291}
292
293# =========================
294# displays a comprehensive tag management frame, with a common UI
295sub _showStyleBlog {
296    my (@tagInfo) = @_;
297    my $text  = '';
298
299    # View mode
300    if (!$action) {
301	if ($button) {
302	    $text .= $button;
303	} elsif ($label) {
304	    $text = "<a href='%SCRIPTURL{viewauth}%/%WEB%/%TOPIC%?tpaction=show' title='Open tag edit menu'>" . $label . "</a>" if $label;
305	}
306	return $text;
307    }
308    return _htmlErrorFeedbackChangeMessage('edit', '') unless (_canChange());
309
310    my $query = TWiki::Func::getCgiQuery();
311    my $tagMode = $query->param('tagmode') || '';
312
313    my $webTopic = "$web.$topic";
314    @tagInfo = _readTagInfo($webTopic) unless ( scalar(@tagInfo) );
315    my @allTags = _readAllTags();
316    my $tag   = '';
317    my $num   = '';
318    my $users = '';
319    my $line  = '';
320    my %seen = ();
321    my %seen_my  = ();
322    my %seen_others  = ();
323    my %tagCount = ();
324    # header
325    $text .= $header."<fieldset class='tagmeEdit'><legend class='tagmeEdit'>Edit Tags - <a href='".
326	$topic . "' name='tagmeEdit'>Done</a></legend>";
327
328    # My tags on this topic + Tags from others on this topic
329    foreach (@tagInfo) {
330        # Format:  3 digit number of users, tag, comma delimited list of users
331        # Example: 004, usability, UserA, UserB, UserC, UserD
332        # SMELL: This format is a quick hack for easy sorting, parsing, and
333        # for fast rendering
334        if (/$lineRegex/) {
335            $num   = $1;
336            $tag   = $2;
337            $users = $3;
338            $seen{$tag} = lc $1;
339            if ( $users =~ /\b$user\b/ ) { # we tagged this topic
340	        $line = "<a class='tagmeTag' href='" . $topic .
341  	        "?tpaction=remove;tag=" . &_urlEncode($tag) . "'>". $tag .
342		"</a> ";
343		$seen_my{$tag} = _wrapHtmlTagControl($line);
344            } else {                       # others tagged it
345	        $line = "<a class='tagmeTag' href='" . $topic .
346  	        "?tpaction=add;tag=" . &_urlEncode($tag) . "'>". $tag .
347		"</a> ";
348		$line .= _imgTag( 'tag_remove', 'Force untagging',
349				  'removeall', $tag, $tagMode );
350		$seen_others{$tag} = _wrapHtmlTagControl($line);
351            }
352        }
353    }
354
355    if ($normalizeTagInput) {
356        # plain sort can be used and should be just a little faster
357        $text .= "<p class='tagmeBlog'><b>My Tags on this topic: </b>" .
358	    join( ' ', map { $seen_my{$_} } sort keys(%seen_my) ) .
359	        "<br /><i>click to untag</i></p>";
360        $text .= "<p class='tagmeBlog'><b>Tags on this topic by others: </b>".
361	    join( ' ', map { $seen_others{$_} } sort keys(%seen_others) ) .
362	        "<br /><i>click tag to also tag with, click delete icon to force untag by all</i></p>" if %seen_others;
363    } else {
364        # uppercase characters are possible, so sort with lowercase comparison
365        $text .= "<p class='tagmeBlog'><b>My Tags on this topic: </b>" .
366            join( ' ', map { $seen_my{$_} } sort { lc $a cmp lc $b } keys(%seen_my) ) .
367	        "<br /><i>click to untag</i></p>";
368        $text .= "<p class='tagmeBlog'><b>Tags on this topic by others: </b>" .
369            join( ' ', map { $seen_others{$_} } sort { lc $a cmp lc $b } keys(%seen_others) ) .
370	        "<br /><i>click tag to also tag with, click delete icon to force untag by all</i></p>" if %seen_others;
371    }
372
373    # Related tags (and we compute counts)
374    my %related   = ();
375    my $tagWebTopic = '';
376    foreach $tagWebTopic ( _getTagInfoList() ) {
377	my @tagInfo = _readTagInfo($tagWebTopic);
378	my @seenTopic = ();
379	my $topicIsRelated = 0;
380	foreach my $line (@tagInfo) {
381	    if ( $line =~ /$lineRegex/ ) {
382		$num   = $1;
383                $tag   = $2;
384		push (@seenTopic, $tag);
385		$topicIsRelated = 1 if $seen{$tag};
386		if ($tagCount{$tag}) {
387		    $tagCount{$tag} += $num;
388		} else {
389		    $tagCount{$tag} = 1;
390		}
391	    }
392	}
393	if ($topicIsRelated) {
394	    foreach my $tag (@seenTopic) {
395		$related{$tag} = 1 unless ($seen{$tag});
396	    }
397	}
398    }
399    if ( %related ) {
400        $text .= "<p class='tagmeBlog'><b>Related tags:</b> ";
401	foreach my $tag (keys %related) {
402	    $text .= "<a class='tagmeTag' href='" . $topic .
403  	        "?tpaction=add;tag=" . &_urlEncode($tag) . "'>". $tag .
404		    "</a> ";
405	}
406	$text .= "<br /><i>click to tag with</i></p>"
407    }
408
409    # Bundles, space or commas-seprated of titles: and tags
410    my $bundles = TWiki::Func::getPluginPreferencesValue('BUNDLES');
411    if ( defined($bundles) && $bundles =~ /\S/ ) {
412	my $tagsep = ( $bundles =~ /[^,]*/ ) ? qr/[\,\s]+/ :  qr/\s*\,+\s*/;
413	my $listsep = '';
414	$text .= "<p class='tagmeBlog'><b>Bundles:</b><ul><li> ";
415	foreach my $tag ( split( $tagsep, $bundles )) {
416	    if ( $tag =~ /:$/ ) {
417		$text .= $listsep . "<b>$tag</b> ";
418	    } else {
419		if ( $seen{lc $tag} ) {
420		    $text .= "<span class='tagmeTagNoclick'>" . $tag .
421			"</span> ";
422		} else {
423		    $text .= "<a class='tagmeTag' href='" . $topic .
424			"?tpaction=autonewadd;tag=" . &_urlEncode($tag) .
425			    "'>". $tag . "</a> ";
426		}
427	    }
428	    $listsep ="</li><li>";
429	}
430	$text .= "</li></ul></p>";
431    }
432
433    # Unused, available, tags in the system
434    my @notSeen = ();
435    foreach (@allTags) {
436        push( @notSeen, $_ ) unless ( $seen_my{$_} || $seen_others{$_} );
437    }
438
439    if ( @notSeen ) {
440        $text .= "<p class='tagmeBlog'><b>Available known tags:</b> ";
441	foreach my $tag (@notSeen) {
442	    $text .= "<a class='tagmeTag' href='" . $topic .
443  	        "?tpaction=add;tag=" . &_urlEncode($tag) . "'>". $tag .
444		"</a>";
445	    if ($tagCount{$tag}) {
446		$text .= "<span class=\"tagMeVoteCount\">($tagCount{$tag})</span>";
447	    } else {
448		$text .= _imgTag( 'tag_remove', 'Delete tag',
449				  'deletethetag', $tag, $tagMode );
450	    }
451	    $text .= " ";
452	}
453	$text .= "<br /><i>click to tag with, click delete icon to delete unused tags</i></p>"
454    }
455
456    # create and add tag
457    $text .= "<p class='tagmeBlog'><b>Tag with a new tag:</b>
458        <form name='createtag' style='display:inline'>
459	<input type='text' class='twikiInputField' name='tag' size='64' />
460	<input type='hidden' name='tpaction' value='newtagsandadd' />
461	<input type='submit' class='twikiSubmit' value='Create and Tag' />
462	</form>
463        <br /><i>You can enter multiple tags separated by spaces</i></p>";
464
465    # more
466    $text .= "<p class='tagmeBlog'><b>Tags management:</b>
467        [[TWiki.TagMeCreateNewTag][create tags]] -
468        [[TWiki.TagMeRenameTag][rename tags]] -
469	[[TWiki.TagMeDeleteTag][delete tags]] -
470	[[TWiki.TagMeViewAllTags][view all tags]] -
471	[[TWiki.TagMeViewMyTags][view my tags]] -
472	[[TWiki.TagMeSearch][search with tags]]
473        </p>";
474    # footer
475    $text .= "</fieldset>".$footer;
476    return $text;
477}
478
479# =========================
480# Used as fallback for noscript
481sub _createNoJavascriptSelectBox {
482    my (@notSeen) = @_;
483
484    my $selectControl = '';
485    $selectControl .= '<select class="twikiSelect" name="tag"> <option></option> ';
486    foreach (@notSeen) {
487        $selectControl .= "<option>$_</option> ";
488    }
489    $selectControl .= '</select>';
490    $selectControl .= _addNewButton();
491    $selectControl = _wrapHtmlTagControl($selectControl);
492
493    return $selectControl;
494}
495
496# =========================
497# The select box plus contents is written using Javascript to prevent the tags
498# getting indexed by search engines
499sub _createJavascriptSelectBox {
500    my (@notSeen) = @_;
501
502    my $random          = int( rand(1000) );
503    my $selectControlId = "tagMeSelect$random";
504    my $selectControl   = "<span id=\"$selectControlId\"></span>";
505    my $script          = <<'EOF';
506<script type="text/javascript" language="javascript">
507//<![CDATA[
508function createSelectBox(inText, inElemId) {
509	var selectBox = document.createElement('SELECT');
510	selectBox.name = "tag";
511	selectBox.className = "twikiSelect";
512	document.getElementById(inElemId).appendChild(selectBox);
513	var items = inText.split("#");
514	var i, ilen = items.length;
515	for (i=0; i<ilen; ++i) {
516		selectBox.options[i] = new Option(items[i], items[i]);
517	}
518}
519EOF
520    $script .= 'var text="#' . join( "#", @notSeen ) . '";';
521    $script .=
522"\nif (text.length > 0) {createSelectBox(text, \"$selectControlId\"); document.getElementById(\"tagmeAddNewButton\").style.display=\"inline\";}\n//]]>\n</script>";
523
524    my $noscript .=
525'<noscript><a href="%SCRIPTURL{viewauth}%/%BASEWEB%/%BASETOPIC%?tagmode=nojavascript">tag this topic</a></noscript>';
526
527    $selectControl .=
528        '<span id="tagmeAddNewButton" style="display:none;">'
529      . _addNewButton()
530      . '</span>';
531    $selectControl .= $script;
532
533    $selectControl = _wrapHtmlTagControl($selectControl);
534    $selectControl .= $noscript;
535
536    return $selectControl;
537}
538
539# =========================
540sub _addNewButton {
541
542    my $input = '<input type="hidden" name="tpaction" value="add" />';
543    $input .=
544        '<input type="image"' . ' src="'
545      . $attachUrl
546      . '/tag_addnew.gif"'
547      . ' class="tag_addnew"'
548      . ' name="add"'
549      . ' alt="Select tag and add to topic"'
550      . ' value="Select tag and add to topic"'
551      . ' title="Select tag and add to topic"' . ' />';
552    return $input;
553}
554
555# =========================
556sub _showAllTags {
557    my ($attr) = @_;
558
559    my @allTags = _readAllTags();
560    return '' if scalar @allTags == 0;
561
562    my $qWeb      = TWiki::Func::extractNameValuePair( $attr, 'web' );
563    my $qTopic    = TWiki::Func::extractNameValuePair( $attr, 'topic' );
564    my $exclude   = TWiki::Func::extractNameValuePair( $attr, 'exclude' );
565    my $by        = TWiki::Func::extractNameValuePair( $attr, 'by' );
566    my $format    = TWiki::Func::extractNameValuePair( $attr, 'format' );
567    my $header    = TWiki::Func::extractNameValuePair( $attr, 'header' );
568    my $separator = TWiki::Func::extractNameValuePair( $attr, 'separator' );
569    my $footer    = TWiki::Func::extractNameValuePair( $attr, 'footer' );
570    my $minSize   = TWiki::Func::extractNameValuePair( $attr, 'minsize' );
571    my $maxSize   = TWiki::Func::extractNameValuePair( $attr, 'maxsize' );
572    my $minCount  = TWiki::Func::extractNameValuePair( $attr, 'mincount' );
573
574    $minCount = 1 if !defined($minCount) || $qWeb || $qTopic || $exclude || $by;
575
576    # a comma separated list of 'selected' options (for html forms)
577    my $selection = TWiki::Func::extractNameValuePair( $attr, 'selection' )
578      || '';
579    my %selected = map { $_ => 1 } split( /,\s*/, $selection );
580
581    $topicsRegex = '';
582    if ($qTopic) {
583        $topicsRegex = $qTopic;
584        $topicsRegex =~ s/, */\|/go;
585        $topicsRegex =~ s/\*/\.\*/go;
586        $topicsRegex = '^.*\.(' . $topicsRegex . ')$';
587    }
588    my $excludeRegex = '';
589    if ($exclude) {
590        $excludeRegex = $exclude;
591        $excludeRegex =~ s/, */\|/go;
592        $excludeRegex =~ s/\*/\.\*/go;
593        $excludeRegex = '^(' . $excludeRegex . ')$';
594    }
595    my $hasSeparator = $separator ne '';
596    my $hasFormat    = $format    ne '';
597
598    $separator = ', ' unless ( $hasSeparator || $hasFormat );
599    $separator =~ s/\$n/\n/go;
600
601    $format = '$tag' unless $hasFormat;
602    $format .= "\n" unless $separator;
603    $format =~ s/\$n/\n/go;
604
605    $by = $user if ( $by eq 'me' );
606    $by = ''    if ( $by eq 'all' );
607    $maxSize = 180 unless ($maxSize);    # Max % size of font
608    $minSize = 90  unless ($minSize);
609    my $text = '';
610    my $line = '';
611    unless ( $format =~ /\$(size|count|order)/ || $by || $qWeb || $qTopic || $exclude ) {
612
613        # fast processing
614        $text = join(
615            $separator,
616            map {
617                my $tag = $_;
618                $line = $format;
619                $line =~ s/\$tag/$tag/go;
620                my $marker = '';
621                $marker = ' selected="selected" ' if ( $selected{$tag} );
622                $line =~ s/\$marker/$marker/g;
623                $line;
624              } @allTags
625        );
626    }
627    else {
628
629        # slow processing
630        # SMELL: Quick hack, should be done with nice data structure
631        my %tagCount = ();
632        my %allTags  = map {$_=>1} @allTags;
633        my %myTags   = ();
634        my $webTopic = '';
635
636        foreach (keys %allTags) {
637          $tagCount{$_} = 0;
638        }
639
640        foreach $webTopic ( _getTagInfoList() ) {
641            next if ( $qWeb        && $webTopic !~ /^$qWeb\./ );
642            next if ( $topicsRegex && $webTopic !~ /$topicsRegex/ );
643            my @tagInfo = _readTagInfo($webTopic);
644            my $tag     = '';
645            my $num     = '';
646            my $users   = '';
647            foreach $line (@tagInfo) {
648                if ( $line =~ /$lineRegex/ ) {
649                    $num   = $1;
650                    $tag   = $2;
651                    $users = $3;
652                    unless ( $excludeRegex && $tag =~ /$excludeRegex/ ) {
653                        $tagCount{$tag} += $num
654                          unless ( $by && $users !~ /$by/ );
655                        $myTags{$tag} = 1 if ( $users =~ /$by/ );
656                    }
657                }
658            }
659        }
660
661        if ($minCount) {
662
663            # remove items below the threshold
664            foreach my $item ( keys %allTags ) {
665                delete $allTags{$item} if ( $tagCount{$item} < $minCount );
666            }
667        }
668
669        my @tags = ();
670        if ($by) {
671            if ($normalizeTagInput) {
672                @tags = sort keys(%myTags);
673            }
674            else {
675                @tags = sort { lc $a cmp lc $b } keys(%myTags);
676            }
677        }
678        else {
679            if ($normalizeTagInput) {
680                @tags = sort keys(%allTags);
681            }
682            else {
683                @tags = sort { lc $a cmp lc $b } keys(%allTags);
684            }
685        }
686        if ( $by && !scalar @tags ) {
687            return
688              "__Note:__ You haven't yet added any tags. To add a tag, go to "
689              . "a topic of interest, and add a tag from the list, or put your "
690              . "vote on an existing tag.";
691        }
692
693#        my @ordered = sort { $tagCount{$a} <=> $tagCount{$b} } @tags;
694        my @ordered = sort { $tagCount{$a} <=> $tagCount{$b} } keys(%tagCount);
695        my %order = map { ( $_, $tagCount{$_} ) }
696          @ordered;
697        my $smallestItem = $ordered[0];
698        my $largestItem = $ordered[$#ordered];
699        my $smallest = $order{$smallestItem};
700        my $largest = $order{$largestItem};
701        my $div = ($largest - $smallest) || 1; # prevent division by zero
702        my $sizingFactor = ($maxSize - $minSize) / $div;
703        my $size   = 0;
704        my $tmpSep = '_#_';
705        $text = join(
706            $separator,
707            map {
708                $size = int( $minSize + ( $order{$_} * $sizingFactor ) );
709                $size = $minSize if ( $size < $minSize );
710                $line = $format;
711                $line =~ s/(tag\=)\$tag/$1$tmpSep\$tag$tmpSep/go;
712                $line =~ s/$tmpSep\$tag$tmpSep/&_urlEncode($_)/geo;
713                $line =~ s/\$tag/$_/go;
714                $line =~ s/\$size/$size/go;
715                $line =~ s/\$count/$tagCount{$_}/go;
716                $line =~ s/\$order/$order{$_}/go;
717                $line;
718              } @tags
719        );
720    }
721    return $text ? $header.$text.$footer : $text;
722}
723
724# =========================
725sub _queryTag {
726    my ($attr) = @_;
727
728    my $qWeb   = TWiki::Func::extractNameValuePair( $attr, 'web' );
729    my $qTopic = TWiki::Func::extractNameValuePair( $attr, 'topic' );
730    my $qTag = _urlDecode( TWiki::Func::extractNameValuePair( $attr, 'tag' ) );
731    my $refine = TWiki::Func::extractNameValuePair( $attr, 'refine' )
732      || TWiki::Func::getPluginPreferencesFlag('ALWAYS_REFINE');
733    my $qBy       = TWiki::Func::extractNameValuePair( $attr, 'by' );
734    my $noRelated = TWiki::Func::extractNameValuePair( $attr, 'norelated' );
735    my $noTotal   = TWiki::Func::extractNameValuePair( $attr, 'nototal' );
736    my $sort = TWiki::Func::extractNameValuePair( $attr, 'sort' ) || 'tagcount';
737    my $format = TWiki::Func::extractNameValuePair( $attr, 'format' )
738      || $tagQueryFormat;
739    my $separator = TWiki::Func::extractNameValuePair( $attr, 'separator' )
740      || "\n";
741    my $minSize      = TWiki::Func::extractNameValuePair( $attr, 'minsize' );
742    my $maxSize      = TWiki::Func::extractNameValuePair( $attr, 'maxsize' );
743    my $resultLimit  = TWiki::Func::extractNameValuePair( $attr, 'limit' );
744    my $formatHeader = TWiki::Func::extractNameValuePair( $attr, 'header' )
745      || '---+++ $web';
746    my $formatFooter = TWiki::Func::extractNameValuePair( $attr, 'footer' )
747      || 'Showing $limit out of $count results $showmore';
748
749    return '__Note:__ Please select a tag' unless ($qTag);
750
751    my $topicsRegex = '';
752    if ($qTopic) {
753        $topicsRegex = $qTopic;
754        $topicsRegex =~ s/, */\|/go;
755        $topicsRegex =~ s/\*/\.\*/go;
756        $topicsRegex = '^.*\.(' . $topicsRegex . ')$';
757    }
758    $qBy = '' unless ($qBy);
759    $qBy = '' if ( $qBy eq 'all' );
760    my $by = $qBy;
761    $by = $user if ( $by eq 'me' );
762    $format    =~ s/([^\\])\"/$1\\\"/go;
763    $separator =~ s/\$n\b/\n/go;
764    $separator =~ s/\$n\(\)/\n/go;
765    $maxSize = 180 unless ($maxSize);    # Max % size of font
766    $minSize = 90  unless ($minSize);
767
768    my @qTagsA = split( /,\s*/, $qTag );
769    my $qTagsRE = join( '|', @qTagsA );
770
771    # SMELL: Quick hack, should be done with nice data structure
772    my $text      = '';
773    my %tagVotes  = ();
774    my %topicTags = ();
775    my %related   = ();
776    my %sawTag;
777    my $tag   = '';
778    my $num   = '';
779    my $users = '';
780    my @tags;
781    my $webTopic = '';
782
783    foreach $webTopic ( _getTagInfoList() ) {
784        next if ( $qWeb        && $webTopic !~ /^$qWeb\./ );
785        next if ( $topicsRegex && $webTopic !~ /$topicsRegex/ );
786        my @tagInfo = _readTagInfo($webTopic);
787        @tags   = ();
788        %sawTag = ();
789        foreach my $line (@tagInfo) {
790            if ( $line =~ /$lineRegex/ ) {
791                $num   = $1;
792                $tag   = $2;
793                $users = $3;
794                push( @tags, $tag );
795                if ( $tag =~ /^($qTagsRE)$/ ) {
796                    $sawTag{$tag}        = 1;
797                    $tagVotes{$webTopic} = $num
798                      unless ( $by && $users !~ /$by/ );
799                }
800            }
801        }
802        if ( scalar keys %sawTag < scalar @qTagsA ) {
803
804            # Not all tags seen, skip this topic
805            delete $tagVotes{$webTopic};
806        }
807        elsif ( $tagVotes{$webTopic} ) {
808            $topicTags{$webTopic} = [ sort { lc $a cmp lc $b } @tags ];
809            foreach $tag (@tags) {
810                unless( $tag =~ /^($qTagsRE)$/ ) {
811                    $num = $related{$tag} || 0;
812                    $related{$tag} = $num + 1;
813                }
814            }
815        }
816    }
817
818    return "__Note:__ No topics found tagged with \"$qTag\""
819      unless ( scalar keys(%tagVotes) );
820
821    # related tags
822    unless ($noRelated) {
823
824        # TODO: should be conditional sort
825        my @relatedTags = map { _printTagLink( $_, $qBy, undef, $refine ) }
826          grep { !/^\Q$qTagsRE\E$/ }
827          sort { lc $a cmp lc $b } keys(%related);
828        if (@relatedTags) {
829            $text .= '<span class="tagmeRelated">%MAKETEXT{"Related tags"}%';
830            $text .= ' (%MAKETEXT{"Click to refine the search"}%)' if $refine;
831            $text .= ': </span> ' . join( ', ', @relatedTags ) . "\n\n";
832        }
833    }
834
835    # SMELL: Commented out by CC. This code does nothing useful.
836    #if ($normalizeTagInput) {
837    #    @tags = sort keys(%allTags);
838    #}
839    #else {
840    #    @tags = sort { lc $a cmp lc $b } keys(%allTags);
841    #}
842    my @topics = ();
843    if ( $sort eq 'tagcount' ) {
844
845        # Sort topics by tag count
846        @topics = sort { $tagVotes{$b} <=> $tagVotes{$a} } keys(%tagVotes);
847    }
848    elsif ( $sort eq 'topic' ) {
849
850        # Sort topics by topic name
851        @topics = sort {
852            substr( $a, rindex( $a, '.' ) ) cmp substr( $b, rindex( $b, '.' ) )
853          }
854          keys(%tagVotes);
855    }
856    else {
857
858        # Sort topics by web, then topic
859        @topics = sort keys(%tagVotes);
860    }
861    if ( $format =~ /\$size/ ) {
862
863        # handle formatting with $size (slower)
864        my %order = ();
865        my $max   = 1;
866        my $size  = 0;
867        %order = map { ( $_, $max++ ) }
868          sort { $tagVotes{$a} <=> $tagVotes{$b} }
869          keys(%tagVotes);
870        foreach $webTopic (@topics) {
871            $size = int( $maxSize * ( $order{$webTopic} + 1 ) / $max );
872            $size = $minSize if ( $size < $minSize );
873            $text .=
874              _printWebTopic( $webTopic, $topicTags{$webTopic}, $qBy, $format,
875                $tagVotes{$webTopic}, $size );
876            $text .= $separator;
877        }
878    }
879    else {
880
881        # normal formatting without $size (faster)
882        if ( $qWeb =~ /\|/ ) {
883
884            #multiple webs selected
885            my %webText;
886            my %resultCount;
887            foreach $webTopic (@topics) {
888                my ( $thisWeb, $thisTopic ) =
889                  TWiki::Func::normalizeWebTopicName( '', $webTopic );
890
891                #initialise this new web with the header
892                unless ( defined( $webText{$thisWeb} ) ) {
893                    $webText{$thisWeb}     = '';
894                    $resultCount{$thisWeb} = 0;
895                    if ( defined($formatHeader) ) {
896                        my $header = $formatHeader;
897                        $header =~ s/\$web/$thisWeb/g;
898                        $webText{$thisWeb} .= "\n$header\n";
899                    }
900                }
901                $resultCount{$thisWeb}++;
902
903                #limit by $resultLimit
904                next
905                  if ( ( defined($resultLimit) )
906                    && ( $resultLimit ne '' )
907                    && ( $resultLimit < $resultCount{$thisWeb} ) );
908
909                $webText{$thisWeb} .=
910                  _printWebTopic( $webTopic, $topicTags{$webTopic}, $qBy,
911                    $format, $tagVotes{$webTopic} );
912                $webText{$thisWeb} .= $separator;
913            }
914            my @webOrder = split( /[)(|]/, $qWeb );
915            foreach my $thisWeb (@webOrder) {
916                if ( defined( $webText{$thisWeb} ) ) {
917                    if ( defined($formatFooter) ) {
918                        my $footer = $formatFooter;
919                        $footer =~ s/\$web/$thisWeb/g;
920                        my $c =
921                          ( $resultLimit < $resultCount{$thisWeb} )
922                          ? $resultLimit
923                          : $resultCount{$thisWeb};
924                        $footer =~ s/\$limit/$c/g;
925                        my $morelink = '';
926
927                        #TODO: make link
928                        $morelink =
929"\n %BR%<div class='tagShowMore'> *Show All results*: "
930                          . _printTagLink( $qTag, $qBy, $thisWeb )
931                          . "</div>\n"
932                          if ( $c < $resultCount{$thisWeb} );
933                        $footer =~ s/\$showmore/$morelink/g;
934                        $footer =~ s/\$count/$resultCount{$thisWeb}/g;
935                        $webText{$thisWeb} .= "\n$footer\n";
936                    }
937                    $text .= $webText{$thisWeb} . "\n";
938                }
939            }
940        }
941        else {
942            foreach $webTopic (@topics) {
943                $text .=
944                  _printWebTopic( $webTopic, $topicTags{$webTopic}, $qBy,
945                    $format, $tagVotes{$webTopic} );
946                $text .= $separator;
947            }
948        }
949    }
950    $text =~ s/\Q$separator\E$//s;
951    $text .= "\n%MAKETEXT{\"Number of topics\"}%: " . scalar( keys(%tagVotes) )
952      unless ($noTotal);
953    _handleMakeText($text);
954    return $text;
955}
956
957# =========================
958sub _printWebTopic {
959    my ( $webTopic, $tagsRef, $qBy, $format, $voteCount, $size ) = @_;
960    $webTopic =~ /^(.*)\.(.)(.*)$/;
961    my $qWeb = $1;
962    my $qT1  = $2
963      ; # Workaround for core bug Bugs:Item2625, fixed in SVN 11484, hotfix-4.0.4-4
964    my $qTopic = quotemeta("$2$3");
965    my $text   = '%SEARCH{ '
966      . "\"^$qTopic\$\" scope=\"topic\" web=\"$qWeb\" topic=\"$qT1\*\" "
967      . 'regex="on" limit="1" nosearch="on" nototal="on" '
968      . "format=\"$format\"" . ' }%';
969    $text = TWiki::Func::expandCommonVariables( $text, $qTopic, $qWeb );
970
971    # TODO: should be conditional sort
972    $text =~
973s/\$taglist/join( ', ', map{ _printTagLink( $_, $qBy ) } sort { lc $a cmp lc $b} @{$tagsRef} )/geo;
974    $text =~ s/\$size/$size/go if ($size);
975    $text =~ s/\$votecount/$voteCount/go;
976    return $text;
977}
978
979# =========================
980sub _printTagLink {
981    my ( $qTag, $by, $web, $refine ) = @_;
982    $web = '' unless ( defined($web) );
983
984    my $links = '';
985
986    foreach my $tag ( split( /,\s*/, $qTag ) ) {
987        my $text = $tagLinkFormat;
988        if ($refine) {
989            $text = '[['
990              . TWiki::Func::getCgiQuery()->url( -path_info => 1 ) . '?'
991              . TWiki::Func::getCgiQuery()->query_string();
992            $text .= ";tag=" . _urlEncode($tag) . '][' . $tag . ']]';
993        }
994
995        # urlencode characters
996        # in 2 passes
997        my $tmpSep = '_#_';
998        $text =~ s/(tag=)\$tag/$1$tmpSep\$tag$tmpSep/go;
999        $text =~ s/$tmpSep\$tag$tmpSep/&_urlEncode($tag)/geo;
1000        $text =~ s/\$tag/$tag/go;
1001        $text =~ s/\$by/$by/go;
1002        $text =~ s/\$web/$web/go;
1003        $links .= $text;
1004    }
1005    return $links;
1006}
1007
1008# =========================
1009# Add new tag to system
1010sub _newTag {
1011    my ($attr) = @_;
1012
1013    my $tag = TWiki::Func::extractNameValuePair( $attr, 'tag' );
1014    my $note = TWiki::Func::extractNameValuePair( $attr, 'note' ) || '';
1015    my $silent = TWiki::Func::extractNameValuePair( $attr, 'silent' );
1016
1017    return _wrapHtmlErrorFeedbackMessage( "<nop>$user cannot add new tags",
1018        $note )
1019      if ( $user =~ /^(TWikiGuest|guest)$/ );
1020
1021    $tag = _makeSafeTag($tag);
1022
1023    return _wrapHtmlErrorFeedbackMessage( "Please enter a tag", $note )
1024      unless ($tag);
1025    my @allTags = _readAllTags();
1026    if ( grep( /^\Q$tag\E$/, @allTags ) ) {
1027	return _wrapHtmlErrorFeedbackMessage("Tag \"$tag\" already exists", $note ) unless (defined $silent) ;
1028    }
1029    else {
1030        push( @allTags, $tag );
1031        writeAllTags(@allTags);
1032        _writeLog("New tag '$tag'");
1033        my $query = TWiki::Func::getCgiQuery();
1034        my $from  = $query->param('from');
1035        if ($from) {
1036            $note =
1037'<a href="%SCRIPTURL{viewauth}%/%URLPARAM{"from"}%?tpaction=add;tag=%URLPARAM{newtag}%">Add tag "%URLPARAM{newtag}%" to %URLPARAM{"from"}%</a>%BR%'
1038              . $note;
1039        }
1040        return _wrapHtmlFeedbackMessage( "Tag \"$tag\" is successfully added",
1041            $note );
1042    }
1043    return "";
1044}
1045
1046# =========================
1047# Normalize tag, strip illegal characters, limit length
1048sub _makeSafeTag {
1049    my ($tag) = @_;
1050    if ($normalizeTagInput) {
1051        $tag =~ s/[- \/]/_/go;
1052        $tag = lc($tag);
1053        $tag =~ s/[^${alphaNum}_]//go;
1054        $tag =~ s/_+/_/go;              # replace double underscores with single
1055    }
1056    else {
1057        $tag =~ s/[\x01-\x1f^\#\,\'\"\|\*]//go;    # strip #,'"|*
1058    }
1059    $tag =~ s/^(.{30}).*/$1/;                      # limit to 30 characters
1060    $tag =~ s/^\s*//;                              # trim spaces at start
1061    $tag =~ s/\s*$//;                              # trim spaces at end
1062    return $tag;
1063}
1064
1065# =========================
1066# Add tag to topic
1067# The tag must already exist
1068sub _addTag {
1069    my ( $attr ) = @_;
1070
1071    my $addTag = TWiki::Func::extractNameValuePair( $attr, 'tag' );
1072    my $noStatus = TWiki::Func::extractNameValuePair( $attr, 'nostatus' );
1073
1074    my $webTopic = "$web.$topic";
1075    my @tagInfo  = _readTagInfo($webTopic);
1076    my $text     = '';
1077    my $tag      = '';
1078    my $num      = '';
1079    my $users    = '';
1080    my @result   = ();
1081    if ( TWiki::Func::topicExists( $web, $topic ) ) {
1082        foreach my $line (@tagInfo) {
1083            if ( $line =~ /$lineRegex/ ) {
1084                $num   = $1;
1085                $tag   = $2;
1086                $users = $3;
1087                if ( $tag eq $addTag ) {
1088                    if ( $users =~ /\b$user\b/ ) {
1089                        $text .=
1090                          _wrapHtmlFeedbackErrorInline(
1091                            "you already added this tag");
1092                    }
1093                    else {
1094
1095                        # add user to existing tag
1096                        $line = _tagDataLine( $num + 1, $tag, $users, $user );
1097                        $text .=
1098                          _wrapHtmlFeedbackInline("added tag vote on \"$tag\"");
1099                        _writeLog("Added tag vote on '$tag'");
1100                    }
1101                }
1102            }
1103            push( @result, $line );
1104        }
1105        unless ($text) {
1106
1107            # tag does not exist yet
1108            if ($addTag) {
1109                push( @result, "001, $addTag, $user" );
1110                $text .= _wrapHtmlFeedbackInline(" added tag \"$addTag\"");
1111                _writeLog("Added tag '$addTag'");
1112            }
1113            else {
1114                $text .= _wrapHtmlFeedbackInline(" (please select a tag)");
1115            }
1116        }
1117        @tagInfo = reverse sort(@result);
1118        _writeTagInfo( $webTopic, @tagInfo );
1119    }
1120    else {
1121        $text .=
1122          _wrapHtmlFeedbackErrorInline("tag not added, topic does not exist");
1123    }
1124
1125    # Suppress status? FWM, 03-Oct-2006
1126    return _showDefault(@tagInfo) . ( ($noStatus) ? '' : $text );
1127}
1128
1129# =========================
1130# Create and tag with multiple tags
1131sub _newTagsAndAdd {
1132    my ( $attr ) = @_;
1133    my $text;
1134    my $args;
1135    my $tags = TWiki::Func::extractNameValuePair( $attr, 'tag' );
1136    $tags =~ s/^\s+//o;
1137    $tags =~ s/\s+$//o;
1138    $tags =~ s/\s\s+/ /go;
1139    foreach my $tag ( split( ' ', $tags )) {
1140	$tag = _makeSafeTag($tag);
1141	if ($tag) {
1142	    $args = 'tag="' . $tag . '"';
1143	    $text = _newTag($args);
1144	    $text = _addTag($args) unless $text =~ /twikiAlert/;
1145	}
1146    }
1147    return $text;
1148}
1149
1150# =========================
1151# Remove my tag vote from topic
1152sub _removeTag {
1153    my ( $attr ) = @_;
1154
1155    my $removeTag = TWiki::Func::extractNameValuePair( $attr, 'tag' );
1156    my $noStatus = TWiki::Func::extractNameValuePair( $attr, 'nostatus' );
1157
1158    my $webTopic = "$web.$topic";
1159    my @tagInfo  = _readTagInfo($webTopic);
1160    my $text     = '';
1161    my $tag      = '';
1162    my $num      = '';
1163    my $users    = '';
1164    my $found    = 0;
1165    my @result   = ();
1166    foreach my $line (@tagInfo) {
1167
1168        if ( $line =~ /^0*([0-9]+), ([^,]+)(, .*)/ ) {
1169            $num   = $1;
1170            $tag   = $2;
1171            $users = $3;
1172            if ( $tag eq $removeTag ) {
1173                if ( $users =~ s/, $user\b// ) {
1174                    $found = 1;
1175                    $num--;
1176                    if ($num) {
1177                        $line = _tagDataLine( $num, $tag, $users );
1178                        $text .=
1179                          _wrapHtmlFeedbackInline(
1180                            "removed my tag vote on \"$tag\"");
1181                        _writeLog("Removed tag vote on '$tag'");
1182                        push( @result, $line );
1183                    }
1184                    else {
1185                        $text .=
1186                          _wrapHtmlFeedbackInline("removed tag \"$tag\"");
1187                        _writeLog("Removed tag '$tag'");
1188                    }
1189                }
1190            }
1191            else {
1192                push( @result, $line );
1193            }
1194        }
1195        else {
1196            push( @result, $line );
1197        }
1198    }
1199    if ($found) {
1200        @tagInfo = reverse sort(@result);
1201        _writeTagInfo( $webTopic, @tagInfo );
1202    }
1203    else {
1204        $text .= _wrapHtmlFeedbackErrorInline("Tag \"$removeTag\" not found");
1205    }
1206
1207    # Suppress status? FWM, 03-Oct-2006
1208    return _showDefault(@tagInfo) . ( ($noStatus) ? '' : $text );
1209}
1210
1211# =========================
1212# Force remove tag  from topic (clear all users votes)
1213sub _removeAllTag {
1214    my ( $attr ) = @_;
1215
1216    my $removeTag = TWiki::Func::extractNameValuePair( $attr, 'tag' );
1217    my $noStatus = TWiki::Func::extractNameValuePair( $attr, 'nostatus' );
1218
1219    my $webTopic = "$web.$topic";
1220    my @tagInfo  = _readTagInfo($webTopic);
1221    my $text     = '';
1222    my $tag      = '';
1223    my $num      = '';
1224    my $users    = '';
1225    my $found    = 0;
1226    my @result   = ();
1227    foreach my $line (@tagInfo) {
1228
1229        if ( $line =~ /^0*([0-9]+), ([^,]+)(, .*)/ ) {
1230            $num   = $1;
1231            $tag   = $2;
1232            $users = $3;
1233            if ( $tag eq $removeTag ) {
1234		$text .= _wrapHtmlFeedbackInline("removed tag \"$tag\"");
1235		_writeLog("Removed tag '$tag'");
1236		$found = 1;
1237            } else {
1238                push( @result, $line );
1239            }
1240        } else {
1241            push( @result, $line );
1242        }
1243    }
1244    if ($found) {
1245        @tagInfo = reverse sort(@result);
1246        _writeTagInfo( $webTopic, @tagInfo );
1247    } else {
1248        $text .= _wrapHtmlFeedbackErrorInline("Tag \"$removeTag\" not found");
1249    }
1250
1251    # Suppress status? FWM, 03-Oct-2006
1252    return _showDefault(@tagInfo) . ( ($noStatus) ? '' : $text );
1253}
1254
1255# =========================
1256sub _tagDataLine {
1257    my ( $num, $tag, $users, $user ) = @_;
1258
1259    my $line = sprintf( '%03d', $num );
1260    $line .= ", $tag, $users";
1261    $line .= ", $user" if $user;
1262    return $line;
1263}
1264
1265# =========================
1266sub _imgTag {
1267    my ( $image, $title, $action, $tag, $tagMode ) = @_;
1268    my $text = '';
1269
1270    #my $tagMode |= '';
1271
1272    if ($tag) {
1273        $text =
1274"<a class=\"tagmeAction $image\" href=\"%SCRIPTURL{viewauth}%/%BASEWEB%/%BASETOPIC%?"
1275          . "tpaction=$action;tag="
1276          . _urlEncode($tag)
1277          . ";tagmode=$tagMode\">";
1278    }
1279    $text .=
1280        "<img src=\"$attachUrl/$image.gif\""
1281      . " alt=\"$title\" title=\"$title\""
1282      . " width=\"11\" height=\"10\""
1283      . " align=\"middle\""
1284      . " border=\"0\"" . " />";
1285    $text .= "</a>" if ($tag);
1286    return $text;
1287}
1288
1289# =========================
1290sub _getTagInfoList {
1291    my @list = ();
1292    if ( opendir( DIR, "$workAreaDir" ) ) {
1293        my @files =
1294          grep { !/^_tags_all\.txt$/ } grep { /^_tags_.*\.txt$/ } readdir(DIR);
1295        closedir DIR;
1296        @list = map { s/^_tags_(.*)\.txt$/$1/; $_ } @files;
1297    }
1298    return sort @list;
1299}
1300
1301# =========================
1302sub _readTagInfo {
1303    my ($webTopic) = @_;
1304
1305    $webTopic =~ s/[\/\\]/\./g;
1306    my $text = TWiki::Func::readFile("$workAreaDir/_tags_$webTopic.txt");
1307    my @info = grep { /^[0-9]/ } split( /\n/, $text );
1308    return @info;
1309}
1310
1311# =========================
1312sub _writeTagInfo {
1313    my ( $webTopic, @info ) = @_;
1314    $webTopic =~ s/[\/\\]/\./g;
1315    my $file = "$workAreaDir/_tags_$webTopic.txt";
1316    if ( scalar @info ) {
1317        my $text =
1318          "# This file is generated, do not edit\n"
1319          . join( "\n", reverse sort @info ) . "\n";
1320        TWiki::Func::saveFile( $file, $text );
1321    }
1322    elsif ( -e $file ) {
1323        unlink($file);
1324    }
1325}
1326
1327# =========================
1328sub renameTagInfo {
1329    my ( $oldWebTopic, $newWebTopic ) = @_;
1330
1331    $oldWebTopic =~ s/[\/\\]/\./g;
1332    $newWebTopic =~ s/[\/\\]/\./g;
1333    my $oldFile = "$workAreaDir/_tags_$oldWebTopic.txt";
1334    my $newFile = "$workAreaDir/_tags_$newWebTopic.txt";
1335    if ( -e $oldFile ) {
1336        my $text = TWiki::Func::readFile($oldFile);
1337        TWiki::Func::saveFile( $newFile, $text );
1338        unlink($oldFile);
1339    }
1340}
1341
1342# =========================
1343sub _readAllTags {
1344    my $text = TWiki::Func::readFile("$workAreaDir/_tags_all.txt");
1345
1346    #my @tags = grep{ /^[${alphaNum}_]/ } split( /\n/, $text );
1347    # we assume that this file has been written by TagMe, so tags should be
1348    # valid, and we only need to filter out the comment line
1349    my @tags = grep { !/^\#.*/ } split( /\n/, $text );
1350    return @tags;
1351}
1352
1353# =========================
1354# Sorting of tags (lowercase comparison) is done just before writing of
1355# the _tags_all file.
1356sub writeAllTags {
1357    my (@tags) = @_;
1358    my $text =
1359      "# This file is generated, do not edit\n"
1360      . join( "\n", sort { lc $a cmp lc $b } @tags ) . "\n";
1361    TWiki::Func::saveFile( "$workAreaDir/_tags_all.txt", $text );
1362}
1363
1364# =========================
1365sub _modifyTag {
1366    my ( $oldTag, $newTag, $changeMessage, $note ) = @_;
1367
1368    return _htmlErrorFeedbackChangeMessage( 'modify', $note ) if !_canChange();
1369
1370    my @allTags = _readAllTags();
1371
1372    if ($oldTag) {
1373        if ( !grep( /^\Q$oldTag\E$/, @allTags ) ) {
1374            return _wrapHtmlErrorFeedbackMessage(
1375                "Tag \"$oldTag\" does not exist", $note );
1376        }
1377    }
1378    if ($newTag) {
1379        if ( grep( /^\Q$newTag\E$/, @allTags ) ) {
1380            return _wrapHtmlErrorFeedbackMessage(
1381                "Tag \"$newTag\" already exists", $note );
1382        }
1383    }
1384
1385    my @newAllTags = grep( !/^\Q$oldTag\E$/, @allTags );
1386    push( @newAllTags, $newTag ) if ($newTag);
1387    writeAllTags(@newAllTags);
1388
1389    my $webTopic = '';
1390    foreach $webTopic ( _getTagInfoList() ) {
1391        next if ( $topicsRegex && $webTopic !~ /$topicsRegex/ );
1392        my @tagInfo = _readTagInfo($webTopic);
1393        my $tag     = '';
1394        my $num     = '';
1395        my $users   = '';
1396        my $tagChanged = 0;    # only save new file if content should be updated
1397        my @result     = ();
1398        foreach my $line (@tagInfo) {
1399
1400            if ( $line =~ /^($lineRegex)$/ ) {
1401                $line  = $1;
1402                $num   = $2;
1403                $tag   = $3;
1404                $users = $4;
1405                if ($newTag) {
1406
1407                    # rename
1408                    if ( $tag eq $oldTag ) {
1409                        $line = _tagDataLine( $num, $newTag, $users );
1410                        $tagChanged = 1;
1411                    }
1412                    push( @result, $line );
1413                }
1414                else {
1415
1416                    # delete
1417                    if ( $tag eq $oldTag ) {
1418                        $tagChanged = 1;
1419                    }
1420                    else {
1421                        push( @result, $line );
1422                    }
1423                }
1424            }
1425        }
1426        if ($tagChanged) {
1427            @result = reverse sort(@result);
1428            $webTopic =~ /(.*)/;
1429            $webTopic = $1;    # untaint
1430            _writeTagInfo( $webTopic, @result );
1431        }
1432    }
1433
1434    _writeLog($changeMessage);
1435    return _wrapHtmlFeedbackMessage( $changeMessage, $note );
1436}
1437
1438# =========================
1439sub _canChange {
1440
1441    my $allowModifyPrefNames =
1442         TWiki::Func::getPluginPreferencesValue('ALLOW_TAG_CHANGE')
1443      || TWiki::Func::getPluginPreferencesValue('ALLOW_TAG_CHANGE');
1444
1445    return 1 if !$allowModifyPrefNames;    # anyone is allowed to change
1446
1447    $allowModifyPrefNames =~ s/ //g;
1448    my @groupsAndUsers = split( ",", $allowModifyPrefNames );
1449    foreach (@groupsAndUsers) {
1450        my $name = $_;
1451        $name =~ s/(Main\.|\%MAINWEB\%\.)//go;
1452        return 1 if ( $name eq TWiki::Func::getWikiName(undef) ); # user is listed
1453        return 1 if _isGroupMember( $name );
1454    }
1455
1456    # this user is not in list
1457    return 0;
1458}
1459
1460# =========================
1461sub _renameTag {
1462    my ($attr) = @_;
1463
1464    my $oldTag = TWiki::Func::extractNameValuePair( $attr, 'oldtag' );
1465    my $newTag = TWiki::Func::extractNameValuePair( $attr, 'newtag' );
1466    my $note   = TWiki::Func::extractNameValuePair( $attr, 'note' ) || '';
1467
1468    my $query = TWiki::Func::getCgiQuery();
1469    my $postChangeRequest = $query->param('postChangeRequest') || '';
1470    if ($postChangeRequest) {
1471        return _handlePostChangeRequest( 'rename', $oldTag, $newTag, $note );
1472    }
1473    return _htmlErrorFeedbackChangeMessage( 'rename', $note ) if !_canChange();
1474
1475    $newTag = _makeSafeTag($newTag);
1476
1477    return _wrapHtmlErrorFeedbackMessage( "Please select a tag to rename",
1478        $note )
1479      unless ($oldTag);
1480
1481    return _wrapHtmlErrorFeedbackMessage( "Please enter a new tag name", $note )
1482      unless ($newTag);
1483
1484    my $changeMessage =
1485      "Tag \"$oldTag\" is successfully renamed to \"$newTag\"";
1486    return _modifyTag( $oldTag, $newTag, $changeMessage, $note );
1487}
1488
1489# =========================
1490sub _handlePostChangeRequest {
1491    my ( $mode, $oldTag, $newTag, $note ) = @_;
1492
1493    my $userName    = TWiki::Func::getWikiUserName();
1494    my $requestLine = '';
1495    my $message     = '';
1496    my $logMessage  = '';
1497    if ( $mode eq 'rename' ) {
1498        $requestLine = "| Rename | $oldTag | $newTag | $userName | %DATE% |";
1499        $message .=
1500"Your request to rename \"$oldTag\" to \"$newTag\" is added to $tagChangeRequestLink";
1501        $logMessage .=
1502"Posted tag rename request: from '$oldTag' to '$newTag' (requested by $userName)";
1503    }
1504    elsif ( $mode eq 'delete' ) {
1505        $requestLine =
1506"| %RED% Delete %ENDCOLOR% | %RED% $oldTag %ENDCOLOR%  | | $userName | %DATE% |";
1507        $message .=
1508"Your request to delete \"$oldTag\" is added to $tagChangeRequestLink";
1509        $logMessage .=
1510          "Posted tag delete request: '$oldTag' (requested by $userName)";
1511    }
1512
1513    my ( $meta, $text ) =
1514      TWiki::Func::readTopic( $installWeb, $tagChangeRequestTopic );
1515    $text .= $requestLine;
1516    TWiki::Func::saveTopic( $installWeb, $tagChangeRequestTopic, $meta, $text,
1517        { comment => 'posted tag change request' } );
1518
1519    $message .= "%BR%$note" if $note;
1520    $message .= _htmlPostChangeRequestFormField();
1521
1522    _writeLog($logMessage);
1523
1524    return _wrapHtmlFeedbackMessage( $message, $note );
1525}
1526
1527# =========================
1528# Default (starting) modify action so we can post a useful feedback message if
1529# this user is not allowed to change tags.
1530# Is he can change no feedback message will be shown.
1531sub _modifyTagInit {
1532    my ( $mode, $attr ) = @_;
1533
1534    my $note = TWiki::Func::extractNameValuePair( $attr, 'note' ) || '';
1535
1536    return _htmlErrorFeedbackChangeMessage( $mode, $note ) if !_canChange();
1537
1538    return $note;
1539}
1540
1541# =========================
1542sub _deleteTag {
1543    my ($attr) = @_;
1544    my $deleteTag = TWiki::Func::extractNameValuePair( $attr, 'oldtag' );
1545    my $note = TWiki::Func::extractNameValuePair( $attr, 'note' ) || '';
1546
1547    my $query = TWiki::Func::getCgiQuery();
1548    my $postChangeRequest = $query->param('postChangeRequest') || '';
1549    if ($postChangeRequest) {
1550        return _handlePostChangeRequest( 'delete', $deleteTag, undef, $note );
1551    }
1552    return _htmlErrorFeedbackChangeMessage( 'delete', $note ) if !_canChange();
1553
1554    return _wrapHtmlErrorFeedbackMessage( "Please select a tag to delete",
1555        $note )
1556      unless ($deleteTag);
1557
1558    my $changeMessage = "Tag \"$deleteTag\" is successfully deleted";
1559    return _modifyTag( $deleteTag, '', $changeMessage, $note );
1560}
1561
1562# =========================
1563# same as above but to be used inlinr on a topic, for some styles
1564sub _deleteTheTag {
1565    my ($attr) = @_;
1566    my $deleteTag = TWiki::Func::extractNameValuePair( $attr, 'tag' );
1567    my $note = TWiki::Func::extractNameValuePair( $attr, 'note' ) || '';
1568
1569    return _htmlErrorFeedbackChangeMessage( 'delete', $note ) if !_canChange();
1570
1571    return _wrapHtmlErrorFeedbackMessage( "Please select a tag to delete",
1572        $note )
1573      unless ($deleteTag);
1574
1575    my $changeMessage = "Tag \"$deleteTag\" is successfully deleted";
1576    $note = _modifyTag( $deleteTag, '', $changeMessage, $note );
1577    return _showDefault() . $note;
1578}
1579
1580# =========================
1581sub _wrapHtmlFeedbackMessage {
1582    my ( $text, $note ) = @_;
1583    return "<div class=\"tagMeNotification\">$text<div>$note</div></div>";
1584}
1585
1586# =========================
1587sub _wrapHtmlErrorFeedbackMessage {
1588    my ( $text, $note ) = @_;
1589    return _wrapHtmlFeedbackMessage( "<span class=\"twikiAlert\">$text</span>",
1590        $note );
1591}
1592
1593# =========================
1594sub _wrapHtmlFeedbackInline {
1595    my ($text) = @_;
1596    return " <span class=\"tagMeNotification\">$text</span>";
1597}
1598
1599# =========================
1600sub _wrapHtmlFeedbackErrorInline {
1601    my ($text) = @_;
1602    return _wrapHtmlFeedbackInline("<span class=\"twikiAlert\">$text</span>");
1603}
1604
1605# =========================
1606sub _wrapHtmlTagControl {
1607    my ($text) = @_;
1608    return "<span class=\"tagMeControl\">$text</span>";
1609}
1610
1611# =========================
1612sub _wrapHtmlTagMeShowForm {
1613    my ($text) = @_;
1614    return
1615"<form name=\"tagmeshow\" action=\"%SCRIPTURL{viewauth}%/%BASEWEB%/%BASETOPIC%\" method=\"post\">$text</form>";
1616}
1617
1618# =========================
1619sub _htmlErrorFeedbackChangeMessage {
1620    my ( $changeMode, $note ) = @_;
1621
1622    my $errorMessage = '%ICON{"warning"}%';
1623    if ( $changeMode eq 'rename' ) {
1624        $errorMessage .= ' You are not allowed to rename tags';
1625    }
1626    elsif ( $changeMode eq 'delete' ) {
1627        $errorMessage .= ' You are not allowed to delete tags';
1628    }
1629    else {
1630        $errorMessage .= ' You are not allowed to modify tags';
1631    }
1632
1633    my $extraNote =
1634"But you may use this form to post a change request to $tagChangeRequestLink";
1635    $note = '%BR%' . $note if $note;
1636    $note = $extraNote . $note;
1637    $note .= _htmlPostChangeRequestFormField();
1638    return _wrapHtmlErrorFeedbackMessage( $errorMessage, $note );
1639}
1640
1641# =========================
1642sub _htmlPostChangeRequestFormField {
1643    return '<input type="hidden" name="postChangeRequest" value="on" />';
1644}
1645
1646# =========================
1647sub _urlEncode {
1648    my $text = shift;
1649    $text =~ s/([^0-9a-zA-Z-_.:~!*'()\/%])/'%'.sprintf('%02x',ord($1))/ge;
1650    return $text;
1651}
1652
1653# =========================
1654sub _urlDecode {
1655    my $text = shift;
1656    $text =~ s/%([\da-f]{2})/chr(hex($1))/gei;
1657    return $text;
1658}
1659
1660# =========================
1661sub _handleMakeText {
1662### my( $text ) = @_; # do not uncomment, use $_[0] instead
1663
1664    # for compatibility with TWiki 3
1665    return unless ( $TWiki::Plugins::VERSION < 1.1 );
1666
1667    # very crude hack to remove MAKETEXT{"...."}
1668    # Note: parameters are _not_ supported!
1669    $_[0] =~ s/[%]MAKETEXT{ *\"(.*?)." *}%/$1/go;
1670}
1671
1672# =========================
1673sub _writeDebug {
1674    my ($text) = @_;
1675    TWiki::Func::writeDebug("- ${pluginName}: $text") if $debug;
1676}
1677
1678# =========================
1679sub _writeLog {
1680    my ($theText) = @_;
1681    if ($logAction) {
1682        $TWiki::Plugins::SESSION
1683          ? $TWiki::Plugins::SESSION->writeLog( "tagme", "$web.$topic",
1684            $theText )
1685          : TWiki::Store::writeLog( "tagme", "$web.$topic", $theText );
1686        _writeDebug("TAGME action, $web.$topic, $theText");
1687    }
1688}
1689
1690# =========================
1691sub _isGroupMember {
1692    my $group = shift;
1693
1694    return TWiki::Func::isGroupMember ( $group, undef ) if $TWiki::Plugins::VERSION >= 1.2;
1695    return $TWiki::Plugins::SESSION->{user}->isInList($group);
1696}
1697
1698# =========================
16991;
1700