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