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