C4/Tags.pm

   1 package C4::Tags;
   2
   3 # Copyright Liblime 2008
   4 # Parts Copyright ACPL 2011
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 use strict;
  22 use warnings;
  23 use Carp;
  24 use Exporter;
  25
  26 use C4::Context;
  27 use C4::Debug;
  28 #use Data::Dumper;
  29 use constant TAG_FIELDS => qw(tag_id borrowernumber biblionumber term language date_created);
  30 use constant TAG_SELECT => "SELECT " . join(',', TAG_FIELDS) . "\n FROM   tags_all\n";
  31
  32 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  33 our $ext_dict;
  34
  35 BEGIN {
  36         @ISA = qw(Exporter);
  37     @EXPORT_OK = qw(
  38       &get_tag &get_tags &get_tag_rows
  39       &add_tags &add_tag
  40       &delete_tag_row_by_id
  41       &remove_tag
  42       &delete_tag_rows_by_ids
  43       &get_approval_rows
  44       &blacklist
  45       &whitelist
  46       &is_approved
  47       &approval_counts
  48       &get_count_by_tag_status
  49       &get_filters
  50       stratify_tags
  51     );
  52         # %EXPORT_TAGS = ();
  53         $ext_dict = C4::Context->preference('TagsExternalDictionary');
  54         if ($debug) {
  55                 require Data::Dumper;
  56                 import Data::Dumper qw(:DEFAULT);
  57                 print STDERR __PACKAGE__ . " external dictionary = " . ($ext_dict||'none') . "\n";
  58         }
  59         if ($ext_dict) {
  60                 require Lingua::Ispell;
  61                 import Lingua::Ispell qw(spellcheck add_word_lc save_dictionary);
  62         }
  63 }
  64
  65 =head1 C4::Tags.pm - Support for user tagging of biblios.
  66
  67 More verose debugging messages are sent in the presence of non-zero $ENV{"DEBUG"}.
  68
  69 =cut
  70
  71 INIT {
  72     $ext_dict and $Lingua::Ispell::path = $ext_dict;
  73     $debug and print STDERR "\$Lingua::Ispell::path = $Lingua::Ispell::path\n";
  74 }
  75
  76 sub get_filters {
  77         my $query = "SELECT * FROM tags_filters ";
  78         my ($sth);
  79         if (@_) {
  80                 $sth = C4::Context->dbh->prepare($query . " WHERE filter_id = ? ");
  81                 $sth->execute(shift);
  82         } else {
  83                 $sth = C4::Context->dbh->prepare($query);
  84                 $sth->execute;
  85         }
  86         return $sth->fetchall_arrayref({});
  87 }
  88
  89 #       (SELECT count(*) FROM tags_all     ) as tags_all,
  90 #       (SELECT count(*) FROM tags_index   ) as tags_index,
  91
  92 sub approval_counts {
  93         my $query = "SELECT
  94                 (SELECT count(*) FROM tags_approval WHERE approved= 1) as approved_count,
  95                 (SELECT count(*) FROM tags_approval WHERE approved=-1) as rejected_count,
  96                 (SELECT count(*) FROM tags_approval WHERE approved= 0) as unapproved_count
  97         ";
  98         my $sth = C4::Context->dbh->prepare($query);
  99         $sth->execute;
 100         my $result = $sth->fetchrow_hashref();
 101         $result->{approved_total} = $result->{approved_count} + $result->{rejected_count} + $result->{unapproved_count};
 102         $debug and warn "counts returned: " . Dumper $result;
 103         return $result;
 104 }
 105
 106 =head2 get_count_by_tag_status
 107
 108   get_count_by_tag_status($status);
 109
 110 Takes a status and gets a count of tags with that status
 111
 112 =cut
 113
 114 sub get_count_by_tag_status  {
 115     my ($status) = @_;
 116     my $dbh            = C4::Context->dbh;
 117     my $query          =
 118       "SELECT count(*) FROM tags_approval WHERE approved=?";
 119     my $sth = $dbh->prepare($query);
 120     $sth->execute( $status );
 121   return $sth->fetchrow;
 122 }
 123
 124 sub remove_tag {
 125         my $tag_id  = shift or return;
 126         my $user_id = (@_) ? shift : undef;
 127         my $rows = (defined $user_id) ?
 128                         get_tag_rows({tag_id=>$tag_id, borrowernumber=>$user_id}) :
 129                         get_tag_rows({tag_id=>$tag_id}) ;
 130         $rows or return 0;
 131         (scalar(@$rows) == 1) or return;        # should never happen (duplicate ids)
 132         my $row = shift(@$rows);
 133         ($tag_id == $row->{tag_id}) or return 0;
 134         my $tags = get_tags({term=>$row->{term}, biblionumber=>$row->{biblionumber}});
 135         my $index = shift(@$tags);
 136         $debug and print STDERR
 137                 sprintf "remove_tag: tag_id=>%s, biblionumber=>%s, weight=>%s, weight_total=>%s\n",
 138                         $row->{tag_id}, $row->{biblionumber}, $index->{weight}, $index->{weight_total};
 139         if ($index->{weight} <= 1) {
 140                 delete_tag_index($row->{term},$row->{biblionumber});
 141         } else {
 142                 decrement_weight($row->{term},$row->{biblionumber});
 143         }
 144         if ($index->{weight_total} <= 1) {
 145                 delete_tag_approval($row->{term});
 146         } else {
 147                 decrement_weight_total($row->{term});
 148         }
 149         delete_tag_row_by_id($tag_id);
 150 }
 151
 152 sub delete_tag_index {
 153         (@_) or return;
 154         my $sth = C4::Context->dbh->prepare("DELETE FROM tags_index WHERE term = ? AND biblionumber = ? LIMIT 1");
 155         $sth->execute(@_);
 156         return $sth->rows || 0;
 157 }
 158 sub delete_tag_approval {
 159         (@_) or return;
 160         my $sth = C4::Context->dbh->prepare("DELETE FROM tags_approval WHERE term = ? LIMIT 1");
 161         $sth->execute(shift);
 162         return $sth->rows || 0;
 163 }
 164 sub delete_tag_row_by_id {
 165         (@_) or return;
 166         my $sth = C4::Context->dbh->prepare("DELETE FROM tags_all WHERE tag_id = ? LIMIT 1");
 167         $sth->execute(shift);
 168         return $sth->rows || 0;
 169 }
 170 sub delete_tag_rows_by_ids {
 171         (@_) or return;
 172         my $i=0;
 173         foreach(@_) {
 174                 $i += delete_tag_row_by_id($_);
 175         }
 176         ($i == scalar(@_)) or
 177                 warn sprintf "delete_tag_rows_by_ids tried %s tag_ids, only succeeded on $i", scalar(@_);
 178         return $i;
 179 }
 180
 181 sub get_tag_rows {
 182         my $hash = shift || {};
 183     my @ok_fields = TAG_FIELDS;
 184         push @ok_fields, 'limit';       # push the limit! :)
 185         my $wheres;
 186         my $limit  = "";
 187         my @exe_args = ();
 188         foreach my $key (keys %$hash) {
 189                 $debug and print STDERR "get_tag_rows arg. '$key' = ", $hash->{$key}, "\n";
 190                 unless (length $key) {
 191                         carp "Empty argument key to get_tag_rows: ignoring!";
 192                         next;
 193                 }
 194                 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
 195                         carp "get_tag_rows received unreconized argument key '$key'.";
 196                         next;
 197                 }
 198                 if ($key eq 'limit') {
 199                         my $val = $hash->{$key};
 200                         unless ($val =~ /^(\d+,)?\d+$/) {
 201                                 carp "Non-nuerical limit value '$val' ignored!";
 202                                 next;
 203                         }
 204                         $limit = " LIMIT $val\n";
 205                 } else {
 206                         $wheres .= ($wheres) ? " AND    $key = ?\n" : " WHERE  $key = ?\n";
 207                         push @exe_args, $hash->{$key};
 208                 }
 209         }
 210     my $query = TAG_SELECT . ($wheres||'') . $limit;
 211         $debug and print STDERR "get_tag_rows query:\n $query\n",
 212                                                         "get_tag_rows query args: ", join(',', @exe_args), "\n";
 213         my $sth = C4::Context->dbh->prepare($query);
 214         if (@exe_args) {
 215                 $sth->execute(@exe_args);
 216         } else {
 217                 $sth->execute;
 218         }
 219         return $sth->fetchall_arrayref({});
 220 }
 221
 222 sub get_tags {          # i.e., from tags_index
 223         my $hash = shift || {};
 224         my @ok_fields = qw(term biblionumber weight limit sort approved);
 225         my $wheres;
 226         my $limit  = "";
 227         my $order  = "";
 228         my @exe_args = ();
 229         foreach my $key (keys %$hash) {
 230                 $debug and print STDERR "get_tags arg. '$key' = ", $hash->{$key}, "\n";
 231                 unless (length $key) {
 232                         carp "Empty argument key to get_tags: ignoring!";
 233                         next;
 234                 }
 235                 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
 236                         carp "get_tags received unreconized argument key '$key'.";
 237                         next;
 238                 }
 239                 if ($key eq 'limit') {
 240                         my $val = $hash->{$key};
 241                         unless ($val =~ /^(\d+,)?\d+$/) {
 242                                 carp "Non-nuerical limit value '$val' ignored!";
 243                                 next;
 244                         }
 245                         $limit = " LIMIT $val\n";
 246                 } elsif ($key eq 'sort') {
 247                         foreach my $by (split /\,/, $hash->{$key}) {
 248                                 unless (
 249                                         $by =~ /^([-+])?(term)/ or
 250                                         $by =~ /^([-+])?(biblionumber)/ or
 251                                         $by =~ /^([-+])?(weight)/
 252                                 ) {
 253                                         carp "get_tags received illegal sort order '$by'";
 254                                         next;
 255                                 }
 256                                 if ($order) {
 257                                         $order .= ", ";
 258                                 } else {
 259                                         $order = " ORDER BY ";
 260                                 }
 261                                 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
 262                         }
 263
 264                 } else {
 265                         my $whereval = $hash->{$key};
 266                         my $longkey = ($key eq 'term'    ) ? 'tags_index.term'        :
 267                                                   ($key eq 'approved') ? 'tags_approval.approved' : $key;
 268                         my $op = ($whereval =~ s/^(>=|<=)// or
 269                                           $whereval =~ s/^(>|=|<)//   ) ? $1 : '=';
 270                         $wheres .= ($wheres) ? " AND    $longkey $op ?\n" : " WHERE  $longkey $op ?\n";
 271                         push @exe_args, $whereval;
 272                 }
 273         }
 274         my $query = "
 275         SELECT    tags_index.term as term,biblionumber,weight,weight_total
 276         FROM      tags_index
 277         LEFT JOIN tags_approval
 278         ON        tags_index.term = tags_approval.term
 279         " . ($wheres||'') . $order . $limit;
 280         $debug and print STDERR "get_tags query:\n $query\n",
 281                                                         "get_tags query args: ", join(',', @exe_args), "\n";
 282         my $sth = C4::Context->dbh->prepare($query);
 283         if (@exe_args) {
 284                 $sth->execute(@exe_args);
 285         } else {
 286                 $sth->execute;
 287         }
 288         return $sth->fetchall_arrayref({});
 289 }
 290
 291 sub get_approval_rows {         # i.e., from tags_approval
 292         my $hash = shift || {};
 293         my @ok_fields = qw(term approved date_approved approved_by weight_total limit sort borrowernumber);
 294         my $wheres;
 295         my $limit  = "";
 296         my $order  = "";
 297         my @exe_args = ();
 298         foreach my $key (keys %$hash) {
 299                 $debug and print STDERR "get_approval_rows arg. '$key' = ", $hash->{$key}, "\n";
 300                 unless (length $key) {
 301                         carp "Empty argument key to get_approval_rows: ignoring!";
 302                         next;
 303                 }
 304                 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
 305                         carp "get_approval_rows received unreconized argument key '$key'.";
 306                         next;
 307                 }
 308                 if ($key eq 'limit') {
 309                         my $val = $hash->{$key};
 310                         unless ($val =~ /^(\d+,)?\d+$/) {
 311                                 carp "Non-numerical limit value '$val' ignored!";
 312                                 next;
 313                         }
 314                         $limit = " LIMIT $val\n";
 315                 } elsif ($key eq 'sort') {
 316                         foreach my $by (split /\,/, $hash->{$key}) {
 317                                 unless (
 318                                         $by =~ /^([-+])?(term)/            or
 319                                         $by =~ /^([-+])?(biblionumber)/    or
 320                     $by =~ /^([-+])?(borrowernumber)/  or
 321                                         $by =~ /^([-+])?(weight_total)/    or
 322                                         $by =~ /^([-+])?(approved(_by)?)/  or
 323                                         $by =~ /^([-+])?(date_approved)/
 324                                 ) {
 325                                         carp "get_approval_rows received illegal sort order '$by'";
 326                                         next;
 327                                 }
 328                                 if ($order) {
 329                                         $order .= ", ";
 330                                 } else {
 331                                         $order = " ORDER BY " unless $order;
 332                                 }
 333                                 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
 334                         }
 335
 336                 } else {
 337                         my $whereval = $hash->{$key};
 338                         my $op = ($whereval =~ s/^(>=|<=)// or
 339                                           $whereval =~ s/^(>|=|<)//   ) ? $1 : '=';
 340                         $wheres .= ($wheres) ? " AND    $key $op ?\n" : " WHERE  $key $op ?\n";
 341                         push @exe_args, $whereval;
 342                 }
 343         }
 344         my $query = "
 345         SELECT  tags_approval.term          AS term,
 346                         tags_approval.approved      AS approved,
 347                         tags_approval.date_approved AS date_approved,
 348                         tags_approval.approved_by   AS approved_by,
 349                         tags_approval.weight_total  AS weight_total,
 350                         CONCAT(borrowers.surname, ', ', borrowers.firstname) AS approved_by_name
 351         FROM    tags_approval
 352         LEFT JOIN borrowers
 353         ON      tags_approval.approved_by = borrowers.borrowernumber ";
 354         $query .= ($wheres||'') . $order . $limit;
 355         $debug and print STDERR "get_approval_rows query:\n $query\n",
 356                                                         "get_approval_rows query args: ", join(',', @exe_args), "\n";
 357         my $sth = C4::Context->dbh->prepare($query);
 358         if (@exe_args) {
 359                 $sth->execute(@exe_args);
 360         } else {
 361                 $sth->execute;
 362         }
 363         return $sth->fetchall_arrayref({});
 364 }
 365
 366 sub is_approved {
 367         my $term = shift or return;
 368         my $sth = C4::Context->dbh->prepare("SELECT approved FROM tags_approval WHERE term = ?");
 369         $sth->execute($term);
 370         unless ($sth->rows) {
 371                 $ext_dict and return (spellcheck($term) ? 0 : 1);       # spellcheck returns empty on OK word
 372                 return 0;
 373         }
 374         return $sth->fetchrow;
 375 }
 376
 377 sub get_tag_index {
 378         my $term = shift or return;
 379         my $sth;
 380         if (@_) {
 381                 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?");
 382                 $sth->execute($term,shift);
 383         } else {
 384                 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ?");
 385                 $sth->execute($term);
 386         }
 387         return $sth->fetchrow_hashref;
 388 }
 389
 390 sub whitelist {
 391         my $operator = shift;
 392         defined $operator or return; # have to test defined to allow =0 (kohaadmin)
 393         if ($ext_dict) {
 394                 foreach (@_) {
 395                         spellcheck($_) or next;
 396                         add_word_lc($_);
 397                 }
 398         }
 399         foreach (@_) {
 400                 my $aref = get_approval_rows({term=>$_});
 401                 if ($aref and scalar @$aref) {
 402                         mod_tag_approval($operator,$_,1);
 403                 } else {
 404                         add_tag_approval($_,$operator);
 405                 }
 406         }
 407         return scalar @_;
 408 }
 409 # note: there is no "unwhitelist" operation because there is no remove for Ispell.
 410 # The blacklist regexps should operate "in front of" the whitelist, so if you approve
 411 # a term mistakenly, you can still reverse it. But there is no going back to "neutral".
 412 sub blacklist {
 413         my $operator = shift;
 414         defined $operator or return; # have to test defined to allow =0 (kohaadmin)
 415         foreach (@_) {
 416                 my $aref = get_approval_rows({term=>$_});
 417                 if ($aref and scalar @$aref) {
 418                         mod_tag_approval($operator,$_,-1);
 419                 } else {
 420                         add_tag_approval($_,$operator,-1);
 421                 }
 422         }
 423         return scalar @_;
 424 }
 425 sub add_filter {
 426         my $operator = shift;
 427         defined $operator or return; # have to test defined to allow =0 (kohaadmin)
 428         my $query = "INSERT INTO tags_blacklist (regexp,y,z) VALUES (?,?,?)";
 429         # my $sth = C4::Context->dbh->prepare($query);
 430         return scalar @_;
 431 }
 432 sub remove_filter {
 433         my $operator = shift;
 434         defined $operator or return; # have to test defined to allow =0 (kohaadmin)
 435         my $query = "REMOVE FROM tags_blacklist WHERE blacklist_id = ?";
 436         # my $sth = C4::Context->dbh->prepare($query);
 437         # $sth->execute($term);
 438         return scalar @_;
 439 }
 440
 441 sub add_tag_approval {  # or disapproval
 442         $debug and warn "add_tag_approval(" . join(", ",map {defined($_) ? $_ : 'UNDEF'} @_) . ")";
 443         my $term = shift or return;
 444         my $query = "SELECT * FROM tags_approval WHERE term = ?";
 445         my $sth = C4::Context->dbh->prepare($query);
 446         $sth->execute($term);
 447         ($sth->rows) and return increment_weight_total($term);
 448         my $operator = shift || 0;
 449         my $approval = (@_ ? shift : 0);        # default is unapproved
 450         my @exe_args = ($term);         # all 3 queries will use this argument
 451         if ($operator) {
 452                 $query = "INSERT INTO tags_approval (term,approved_by,approved,date_approved) VALUES (?,?,?,NOW())";
 453                 push @exe_args, $operator, $approval;
 454         } elsif ($approval) {
 455                 $query = "INSERT INTO tags_approval (term,approved,date_approved) VALUES (?,?,NOW())";
 456                 push @exe_args, $approval;
 457         } else {
 458                 $query = "INSERT INTO tags_approval (term,date_approved) VALUES (?,NOW())";
 459         }
 460         $debug and print STDERR "add_tag_approval query: $query\nadd_tag_approval args: (" . join(", ", @exe_args) . ")\n";
 461         $sth = C4::Context->dbh->prepare($query);
 462         $sth->execute(@exe_args);
 463         return $sth->rows;
 464 }
 465
 466 sub mod_tag_approval {
 467         my $operator = shift;
 468         defined $operator or return; # have to test defined to allow =0 (kohaadmin)
 469         my $term     = shift or return;
 470         my $approval = (scalar @_ ? shift : 1); # default is to approve
 471         my $query = "UPDATE tags_approval SET approved_by=?, approved=?, date_approved=NOW() WHERE term = ?";
 472         $debug and print STDERR "mod_tag_approval query: $query\nmod_tag_approval args: ($operator,$approval,$term)\n";
 473         my $sth = C4::Context->dbh->prepare($query);
 474         $sth->execute($operator,$approval,$term);
 475 }
 476
 477 sub add_tag_index {
 478         my $term         = shift or return;
 479         my $biblionumber = shift or return;
 480         my $query = "SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?";
 481         my $sth = C4::Context->dbh->prepare($query);
 482         $sth->execute($term,$biblionumber);
 483         ($sth->rows) and return increment_weight($term,$biblionumber);
 484         $query = "INSERT INTO tags_index (term,biblionumber) VALUES (?,?)";
 485         $debug and print STDERR "add_tag_index query: $query\nadd_tag_index args: ($term,$biblionumber)\n";
 486         $sth = C4::Context->dbh->prepare($query);
 487         $sth->execute($term,$biblionumber);
 488         return $sth->rows;
 489 }
 490
 491 sub get_tag {           # by tag_id
 492         (@_) or return;
 493     my $sth = C4::Context->dbh->prepare(TAG_SELECT . "WHERE tag_id = ?");
 494         $sth->execute(shift);
 495         return $sth->fetchrow_hashref;
 496 }
 497
 498 sub increment_weights {
 499         increment_weight(@_);
 500         increment_weight_total(shift);
 501 }
 502 sub decrement_weights {
 503         decrement_weight(@_);
 504         decrement_weight_total(shift);
 505 }
 506 sub increment_weight_total {
 507         _set_weight_total('weight_total+1',shift);
 508 }
 509 sub increment_weight {
 510         _set_weight('weight+1',shift,shift);
 511 }
 512 sub decrement_weight_total {
 513         _set_weight_total('weight_total-1',shift);
 514 }
 515 sub decrement_weight {
 516         _set_weight('weight-1',shift,shift);
 517 }
 518 sub _set_weight_total {
 519         my $sth = C4::Context->dbh->prepare("
 520         UPDATE tags_approval
 521         SET    weight_total=" . (shift) . "
 522         WHERE  term=?
 523         ");                                             # note: CANNOT use "?" for weight_total (see the args above).
 524         $sth->execute(shift);   # just the term
 525 }
 526 sub _set_weight {
 527         my $dbh = C4::Context->dbh;
 528         my $sth = $dbh->prepare("
 529         UPDATE tags_index
 530         SET    weight=" . (shift) . "
 531         WHERE  term=?
 532         AND    biblionumber=?
 533         ");
 534         $sth->execute(@_);
 535 }
 536
 537 sub add_tag {   # biblionumber,term,[borrowernumber,approvernumber]
 538         my $biblionumber = shift or return;
 539         my $term         = shift or return;
 540         my $borrowernumber = (@_) ? shift : 0;          # the user, default to kohaadmin
 541         $term =~ s/^\s+//;
 542         $term =~ s/\s+$//;
 543         ($term) or return;      # must be more than whitespace
 544         my $rows = get_tag_rows({biblionumber=>$biblionumber, borrowernumber=>$borrowernumber, term=>$term, limit=>1});
 545         my $query = "INSERT INTO tags_all
 546         (borrowernumber,biblionumber,term,date_created)
 547         VALUES (?,?,?,NOW())";
 548         $debug and print STDERR "add_tag query: $query\n",
 549                                                         "add_tag query args: ($borrowernumber,$biblionumber,$term)\n";
 550         if (scalar @$rows) {
 551                 $debug and carp "Duplicate tag detected.  Tag not added.";
 552                 return;
 553         }
 554         # add to tags_all regardless of approaval
 555         my $sth = C4::Context->dbh->prepare($query);
 556         $sth->execute($borrowernumber,$biblionumber,$term);
 557
 558         # then
 559         if (scalar @_) {        # if arg remains, it is the borrowernumber of the approver: tag is pre-approved.
 560                 my $approver = shift;
 561                 $debug and print STDERR "term '$term' pre-approved by borrower #$approver\n";
 562                 add_tag_approval($term,$approver,1);
 563                 add_tag_index($term,$biblionumber,$approver);
 564         } elsif (is_approved($term) >= 1) {
 565                 $debug and print STDERR "term '$term' approved by whitelist\n";
 566                 add_tag_approval($term,0,1);
 567                 add_tag_index($term,$biblionumber,1);
 568         } else {
 569                 $debug and print STDERR "term '$term' NOT approved (yet)\n";
 570                 add_tag_approval($term);
 571                 add_tag_index($term,$biblionumber);
 572         }
 573 }
 574
 575 # This takes a set of tags, as returned by C<get_approval_rows> and divides
 576 # them up into a number of "strata" based on their weight. This is useful
 577 # to display them in a number of different sizes.
 578 #
 579 # Usage:
 580 #   ($min, $max) = stratify_tags($strata, $tags);
 581 # $stratum: the number of divisions you want
 582 # $tags: the tags, as provided by get_approval_rows
 583 # $min: the minimum stratum value
 584 # $max: the maximum stratum value. This may be the same as $min if there
 585 # is only one weight. Beware of divide by zeros.
 586 # This will add a field to the tag called "stratum" containing the calculated
 587 # value.
 588 sub stratify_tags {
 589     my ( $strata, $tags ) = @_;
 590     return (0,0) if !@$tags;
 591     my ( $min, $max );
 592     foreach (@$tags) {
 593         my $w = $_->{weight_total};
 594         $min = $w if ( !defined($min) || $min > $w );
 595         $max = $w if ( !defined($max) || $max < $w );
 596     }
 597
 598     # normalise min to zero
 599     $max = $max - $min;
 600     my $orig_min = $min;
 601     $min = 0;
 602
 603     # if min and max are the same, just make it 1
 604     my $span = ( $strata - 1 ) / ( $max || 1 );
 605     foreach (@$tags) {
 606         my $w = $_->{weight_total};
 607         $_->{stratum} = int( ( $w - $orig_min ) * $span );
 608     }
 609     return ( $min, $max );
 610 }
 611
 612 1;
 613 __END__
 614
 615 =head2 add_tag(biblionumber,term[,borrowernumber])
 616
 617 =head3 TO DO: Add real perldoc
 618
 619 =cut
 620
 621 =head2 External Dictionary (Ispell) [Recommended]
 622
 623 An external dictionary can be used as a means of "pre-populating" and tracking
 624 allowed terms based on the widely available Ispell dictionary.  This can be the system
 625 dictionary or a personal version, but in order to support whitelisting, it must be
 626 editable to the process running Koha.
 627
 628 To enable, enter the absolute path to the ispell dictionary in the system
 629 preference "TagsExternalDictionary".
 630
 631 Using external Ispell is recommended for both ease of use and performance.  Note that any
 632 language version of Ispell can be installed.  It is also possible to modify the dictionary
 633 at the command line to affect the desired content.
 634
 635 WARNING: The default Ispell dictionary includes (properly spelled) obscenities!  Users
 636 should build their own wordlist and recompile Ispell based on it.  See man ispell for
 637 instructions.
 638
 639 =head2 Table Structure
 640
 641 The tables used by tags are:
 642         tags_all
 643         tags_index
 644         tags_approval
 645         tags_blacklist
 646
 647 Your first thought may be that this looks a little complicated.  It is, but only because
 648 it has to be.  I'll try to explain.
 649
 650 tags_all - This table would be all we really need if we didn't care about moderation or
 651 performance or tags disappearing when borrowers are removed.  Too bad, we do.  Otherwise
 652 though, it contains all the relevant info about a given tag:
 653         tag_id         - unique id number for it
 654         borrowernumber - user that entered it
 655         biblionumber   - book record it is attached to
 656         term           - tag "term" itself
 657         language       - perhaps used later to influence weighting
 658         date_created   - date and time it was created
 659
 660 tags_approval - Since we need to provide moderation, this table is used to track it.  If no
 661 external dictionary is used, this table is the sole reference for approval and rejection.
 662 With an external dictionary, it tracks pending terms and past whitelist/blacklist actions.
 663 This could be called an "approved terms" table.  See above regarding the External Dictionary.
 664         term           - tag "term" itself
 665         approved       - Negative, 0 or positive if tag is rejected, pending or approved.
 666         date_approved  - date of last action
 667         approved_by    - staffer performing the last action
 668     weight_total   - total occurrence of term in any biblio by any users
 669
 670 tags_index - This table is for performance, because by far the most common operation will
 671 be fetching tags for a list of search results.  We will have a set of biblios, and we will
 672 want ONLY their approved tags and overall weighting.  While we could implement a query that
 673 would traverse tags_all filtered against tags_approval, the performance implications of
 674 trying to calculate that and the "weight" (number of times a tag appears) on the fly are drastic.
 675         term           - approved term as it appears in tags_approval
 676         biblionumber   - book record it is attached to
 677         weight         - number of times tag applied by any user
 678
 679 tags_blacklist - A set of regular expression filters.  Unsurprisingly, these should be perl-
 680 compatible (PCRE) for your version of perl.  Since this is a blacklist, a term will be
 681 blocked if it matches any of the given patterns.  WARNING: do not add blacklist regexps
 682 if you do not understand their operation and interaction.  It is quite easy to define too
 683 simple or too complex a regexp and effectively block all terms.  The blacklist operation is
 684 fairly resource intensive, since every line of tags_blacklist will need to be read and compared.
 685 It is recommended that tags_blacklist be used minimally, and only by an administrator with an
 686 understanding of regular expression syntax and performance.
 687
 688 So the best way to think about the different tables is that they are each tailored to a certain
 689 use.  Note that tags_approval and tags_index do not rely on the user's borrower mapping, so
 690 the tag population can continue to grow even if a user (along with their corresponding
 691 rows in tags_all) is removed.
 692
 693 =head2 Tricks
 694
 695 If you want to auto-populate some tags for debugging, do something like this:
 696
 697 mysql> select biblionumber from biblio where title LIKE "%Health%";
 698 +--------------+
 699 | biblionumber |
 700 +--------------+
 701 |           18 |
 702 |           22 |
 703 |           24 |
 704 |           30 |
 705 |           44 |
 706 |           45 |
 707 |           46 |
 708 |           49 |
 709 |          111 |
 710 |          113 |
 711 |          128 |
 712 |          146 |
 713 |          155 |
 714 |          518 |
 715 |          522 |
 716 |          524 |
 717 |          530 |
 718 |          544 |
 719 |          545 |
 720 |          546 |
 721 |          549 |
 722 |          611 |
 723 |          613 |
 724 |          628 |
 725 |          646 |
 726 |          655 |
 727 +--------------+
 728 26 rows in set (0.00 sec)
 729
 730 Then, take those numbers and type/pipe them into this perl command line:
 731 perl -ne 'use C4::Tags qw(get_tags add_tag); use Data::Dumper;chomp; add_tag($_,"health",51,1); print Dumper get_tags({limit=>5,term=>"health",});'
 732
 733 Note, the borrowernumber in this example is 51.  Use your own or any arbitrary valid borrowernumber.
 734
 735 =cut
 736