2 # This file is part of Koha.
4 # Koha is free software; you can redistribute it and/or modify it under the
5 # terms of the GNU General Public License as published by the Free Software
6 # Foundation; either version 2 of the License, or (at your option) any later
9 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
10 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
11 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License along with
14 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
15 # Suite 330, Boston, MA 02111-1307 USA
25 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
26 use vars qw($ext_dict $select_all @fields);
32 &get_tag &get_tags &get_tag_rows
36 &delete_tag_rows_by_ids
46 $ext_dict = C4::Context->preference('TagsExternalDictionary');
49 import Data::Dumper qw(:DEFAULT);
50 print STDERR __PACKAGE__ . " external dictionary = " . ($ext_dict||'none') . "\n";
53 require Lingua::Ispell;
54 import Lingua::Ispell qw(spellcheck add_word_lc save_dictionary);
59 $ext_dict and $Lingua::Ispell::path = $ext_dict;
60 $debug and print STDERR "\$Lingua::Ispell::path = $Lingua::Ispell::path\n";
61 @fields = qw(tag_id borrowernumber biblionumber term language date_created);
62 $select_all = "SELECT " . join(',',@fields) . "\n FROM tags_all\n";
65 sub get_filters (;$) {
66 my $query = "SELECT * FROM tags_filters ";
69 $sth = C4::Context->dbh->prepare($query . " WHERE filter_id = ? ");
72 $sth = C4::Context->dbh->prepare($query);
75 return $sth->fetchall_arrayref({});
78 # (SELECT count(*) FROM tags_all ) as tags_all,
79 # (SELECT count(*) FROM tags_index ) as tags_index,
81 sub approval_counts () {
83 (SELECT count(*) FROM tags_approval WHERE approved= 1) as approved_count,
84 (SELECT count(*) FROM tags_approval WHERE approved=-1) as rejected_count,
85 (SELECT count(*) FROM tags_approval WHERE approved= 0) as unapproved_count
87 my $sth = C4::Context->dbh->prepare($query);
89 my $result = $sth->fetchrow_hashref();
90 $result->{approved_total} = $result->{approved_count} + $result->{rejected_count} + $result->{unapproved_count};
91 $debug and warn "counts returned: " . Dumper $result;
95 sub remove_tag ($;$) {
96 my $tag_id = shift or return undef;
97 my $user_id = (@_) ? shift : undef;
98 my $rows = (defined $user_id) ?
99 get_tag_rows({tag_id=>$tag_id, borrowernumber=>$user_id}) :
100 get_tag_rows({tag_id=>$tag_id}) ;
102 (scalar(@$rows) == 1) or return undef; # should never happen (duplicate ids)
103 my $row = shift(@$rows);
104 ($tag_id == $row->{tag_id}) or return 0;
105 my $tags = get_tags({term=>$row->{term}, biblionumber=>$row->{biblionumber}});
106 my $index = shift(@$tags);
107 $debug and print STDERR
108 sprintf "remove_tag: tag_id=>%s, biblionumber=>%s, weight=>%s, weight_total=>%s\n",
109 $row->{tag_id}, $row->{biblionumber}, $index->{weight}, $index->{weight_total};
110 if ($index->{weight} <= 1) {
111 delete_tag_index($row->{term},$row->{biblionumber});
113 decrement_weight($row->{term},$row->{biblionumber});
115 if ($index->{weight_total} <= 1) {
116 delete_tag_approval($row->{term});
118 decrement_weight_total($row->{term});
120 delete_tag_row_by_id($tag_id);
123 sub delete_tag_index ($$) {
124 (@_) or return undef;
125 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_index WHERE term = ? AND biblionumber = ? LIMIT 1");
127 return $sth->rows || 0;
129 sub delete_tag_approval ($) {
130 (@_) or return undef;
131 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_approval WHERE term = ? LIMIT 1");
132 $sth->execute(shift);
133 return $sth->rows || 0;
135 sub delete_tag_row_by_id ($) {
136 (@_) or return undef;
137 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_all WHERE tag_id = ? LIMIT 1");
138 $sth->execute(shift);
139 return $sth->rows || 0;
141 sub delete_tag_rows_by_ids (@) {
142 (@_) or return undef;
145 $i += delete_tag_row_by_id($_);
147 ($i == scalar(@_)) or
148 warn sprintf "delete_tag_rows_by_ids tried %s tag_ids, only succeeded on $i", scalar(@_);
152 sub get_tag_rows ($) {
153 my $hash = shift || {};
154 my @ok_fields = @fields;
155 push @ok_fields, 'limit'; # push the limit! :)
159 foreach my $key (keys %$hash) {
160 $debug and print STDERR "get_tag_rows arg. '$key' = ", $hash->{$key}, "\n";
161 unless (length $key) {
162 carp "Empty argument key to get_tag_rows: ignoring!";
165 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
166 carp "get_tag_rows received unreconized argument key '$key'.";
169 if ($key eq 'limit') {
170 my $val = $hash->{$key};
171 unless ($val =~ /^(\d+,)?\d+$/) {
172 carp "Non-nuerical limit value '$val' ignored!";
175 $limit = " LIMIT $val\n";
177 $wheres .= ($wheres) ? " AND $key = ?\n" : " WHERE $key = ?\n";
178 push @exe_args, $hash->{$key};
181 my $query = $select_all . ($wheres||'') . $limit;
182 $debug and print STDERR "get_tag_rows query:\n $query\n",
183 "get_tag_rows query args: ", join(',', @exe_args), "\n";
184 my $sth = C4::Context->dbh->prepare($query);
186 $sth->execute(@exe_args);
190 return $sth->fetchall_arrayref({});
193 sub get_tags (;$) { # i.e., from tags_index
194 my $hash = shift || {};
195 my @ok_fields = qw(term biblionumber weight limit sort approved);
200 foreach my $key (keys %$hash) {
201 $debug and print STDERR "get_tags arg. '$key' = ", $hash->{$key}, "\n";
202 unless (length $key) {
203 carp "Empty argument key to get_tags: ignoring!";
206 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
207 carp "get_tags received unreconized argument key '$key'.";
210 if ($key eq 'limit') {
211 my $val = $hash->{$key};
212 unless ($val =~ /^(\d+,)?\d+$/) {
213 carp "Non-nuerical limit value '$val' ignored!";
216 $limit = " LIMIT $val\n";
217 } elsif ($key eq 'sort') {
218 foreach my $by (split /\,/, $hash->{$key}) {
220 $by =~ /^([-+])?(term)/ or
221 $by =~ /^([-+])?(biblionumber)/ or
222 $by =~ /^([-+])?(weight)/
224 carp "get_tags received illegal sort order '$by'";
230 $order = " ORDER BY ";
232 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
236 my $whereval = $hash->{$key};
237 my $longkey = ($key eq 'term' ) ? 'tags_index.term' :
238 ($key eq 'approved') ? 'tags_approval.approved' : $key;
239 my $op = ($whereval =~ s/^(>=|<=)// or
240 $whereval =~ s/^(>|=|<)// ) ? $1 : '=';
241 $wheres .= ($wheres) ? " AND $longkey $op ?\n" : " WHERE $longkey $op ?\n";
242 push @exe_args, $whereval;
246 SELECT tags_index.term as term,biblionumber,weight,weight_total
248 LEFT JOIN tags_approval
249 ON tags_index.term = tags_approval.term
250 " . ($wheres||'') . $order . $limit;
251 $debug and print STDERR "get_tags query:\n $query\n",
252 "get_tags query args: ", join(',', @exe_args), "\n";
253 my $sth = C4::Context->dbh->prepare($query);
255 $sth->execute(@exe_args);
259 return $sth->fetchall_arrayref({});
262 sub get_approval_rows (;$) { # i.e., from tags_approval
263 my $hash = shift || {};
264 my @ok_fields = qw(term approved date_approved approved_by weight_total limit sort);
269 foreach my $key (keys %$hash) {
270 $debug and print STDERR "get_approval_rows arg. '$key' = ", $hash->{$key}, "\n";
271 unless (length $key) {
272 carp "Empty argument key to get_approval_rows: ignoring!";
275 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
276 carp "get_approval_rows received unreconized argument key '$key'.";
279 if ($key eq 'limit') {
280 my $val = $hash->{$key};
281 unless ($val =~ /^(\d+,)?\d+$/) {
282 carp "Non-nuerical limit value '$val' ignored!";
285 $limit = " LIMIT $val\n";
286 } elsif ($key eq 'sort') {
287 foreach my $by (split /\,/, $hash->{$key}) {
289 $by =~ /^([-+])?(term)/ or
290 $by =~ /^([-+])?(biblionumber)/ or
291 $by =~ /^([-+])?(weight_total)/ or
292 $by =~ /^([-+])?(approved(_by)?)/ or
293 $by =~ /^([-+])?(date_approved)/
295 carp "get_approval_rows received illegal sort order '$by'";
301 $order = " ORDER BY " unless $order;
303 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
307 my $whereval = $hash->{$key};
308 my $op = ($whereval =~ s/^(>=|<=)// or
309 $whereval =~ s/^(>|=|<)// ) ? $1 : '=';
310 $wheres .= ($wheres) ? " AND $key $op ?\n" : " WHERE $key $op ?\n";
311 push @exe_args, $whereval;
315 SELECT tags_approval.term AS term,
316 tags_approval.approved AS approved,
317 tags_approval.date_approved AS date_approved,
318 tags_approval.approved_by AS approved_by,
319 tags_approval.weight_total AS weight_total,
320 CONCAT(borrowers.surname, ', ', borrowers.firstname) AS approved_by_name
323 ON tags_approval.approved_by = borrowers.borrowernumber ";
324 $query .= ($wheres||'') . $order . $limit;
325 $debug and print STDERR "get_approval_rows query:\n $query\n",
326 "get_approval_rows query args: ", join(',', @exe_args), "\n";
327 my $sth = C4::Context->dbh->prepare($query);
329 $sth->execute(@exe_args);
333 return $sth->fetchall_arrayref({});
336 sub is_approved ($) {
337 my $term = shift or return undef;
338 my $sth = C4::Context->dbh->prepare("SELECT approved FROM tags_approval WHERE term = ?");
339 $sth->execute($term);
340 unless ($sth->rows) {
341 $ext_dict and return (spellcheck($term) ? 0 : 1); # spellcheck returns empty on OK word
347 sub get_tag_index ($;$) {
348 my $term = shift or return undef;
351 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?");
352 $sth->execute($term,shift);
354 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ?");
355 $sth->execute($term);
357 return $sth->fetchrow_hashref;
361 my $operator = shift;
362 defined $operator or return undef; # have to test defined to allow =0 (kohaadmin)
365 spellcheck($_) or next;
370 my $aref = get_approval_rows({term=>$_});
371 if ($aref and scalar @$aref) {
372 mod_tag_approval($operator,$_,1);
374 add_tag_approval($_,$operator);
379 # note: there is no "unwhitelist" operation because there is no remove for Ispell.
380 # The blacklist regexps should operate "in front of" the whitelist, so if you approve
381 # a term mistakenly, you can still reverse it. But there is no going back to "neutral".
383 my $operator = shift;
384 defined $operator or return undef; # have to test defined to allow =0 (kohaadmin)
386 my $aref = get_approval_rows({term=>$_});
387 if ($aref and scalar @$aref) {
388 mod_tag_approval($operator,$_,-1);
390 add_tag_approval($_,$operator,-1);
396 my $operator = shift;
397 defined $operator or return undef; # have to test defined to allow =0 (kohaadmin)
398 my $query = "INSERT INTO tags_blacklist (regexp,y,z) VALUES (?,?,?)";
399 # my $sth = C4::Context->dbh->prepare($query);
403 my $operator = shift;
404 defined $operator or return undef; # have to test defined to allow =0 (kohaadmin)
405 my $query = "REMOVE FROM tags_blacklist WHERE blacklist_id = ?";
406 # my $sth = C4::Context->dbh->prepare($query);
407 # $sth->execute($term);
411 sub add_tag_approval ($;$$) { # or disapproval
412 my $term = shift or return undef;
413 my $query = "SELECT * FROM tags_approval WHERE term = ?";
414 my $sth = C4::Context->dbh->prepare($query);
415 $sth->execute($term);
416 ($sth->rows) and return increment_weight_total($term);
417 my $operator = (@_ ? shift : 0);
419 my $approval = (@_ ? shift : 1); # default is to approve
420 $query = "INSERT INTO tags_approval (term,approved_by,approved,date_approved) VALUES (?,?,?,NOW())";
421 $debug and print STDERR "add_tag_approval query:\n$query\nadd_tag_approval args: ($term,$operator,$approval)\n";
422 $sth = C4::Context->dbh->prepare($query);
423 $sth->execute($term,$operator,$approval);
425 $query = "INSERT INTO tags_approval (term,date_approved) VALUES (?,NOW())";
426 $debug and print STDERR "add_tag_approval query:\n$query\nadd_tag_approval args: ($term)\n";
427 $sth = C4::Context->dbh->prepare($query);
428 $sth->execute($term);
433 sub mod_tag_approval ($$$) {
434 my $operator = shift;
435 defined $operator or return undef; # have to test defined to allow =0 (kohaadmin)
436 my $term = shift or return undef;
437 my $approval = (@_ ? shift : 1); # default is to approve
438 my $query = "UPDATE tags_approval SET approved_by=?, approved=?, date_approved=NOW() WHERE term = ?";
439 $debug and print STDERR "mod_tag_approval query:\n$query\nmod_tag_approval args: ($operator,$approval,$term)\n";
440 my $sth = C4::Context->dbh->prepare($query);
441 $sth->execute($operator,$approval,$term);
444 sub add_tag_index ($$;$) {
445 my $term = shift or return undef;
446 my $biblionumber = shift or return undef;
447 my $query = "SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?";
448 my $sth = C4::Context->dbh->prepare($query);
449 $sth->execute($term,$biblionumber);
450 ($sth->rows) and return increment_weight($term,$biblionumber);
451 $query = "INSERT INTO tags_index (term,biblionumber) VALUES (?,?)";
452 $debug and print "add_tag_index query:\n$query\nadd_tag_index args: ($term,$biblionumber)\n";
453 $sth = C4::Context->dbh->prepare($query);
454 $sth->execute($term,$biblionumber);
458 sub get_tag ($) { # by tag_id
459 (@_) or return undef;
460 my $sth = C4::Context->dbh->prepare("$select_all WHERE tag_id = ?");
461 $sth->execute(shift);
462 return $sth->fetchrow_hashref;
465 sub rectify_weights (;$) {
466 my $dbh = C4::Context->dbh;
469 SELECT term,biblionumber,count(*) as count
472 (@_) and $query .= " WHERE term =? ";
473 $query .= " GROUP BY term,biblionumber ";
474 $sth = $dbh->prepare($query);
476 $sth->execute(shift);
480 my $results = $sth->fetchall_arrayref({}) or return undef;
482 foreach (@$results) {
483 _set_weight($_->{count},$_->{term},$_->{biblionumber});
484 $tally{$_->{term}} += $_->{count};
486 foreach (keys %tally) {
487 _set_weight_total($tally{$_},$_);
489 return ($results,\%tally);
492 sub increment_weights ($$) {
493 increment_weight(@_);
494 increment_weight_total(shift);
496 sub decrement_weights ($$) {
497 decrement_weight(@_);
498 decrement_weight_total(shift);
500 sub increment_weight_total ($) {
501 _set_weight_total('weight_total+1',shift);
503 sub increment_weight ($$) {
504 _set_weight('weight+1',shift,shift);
506 sub decrement_weight_total ($) {
507 _set_weight_total('weight_total-1',shift);
509 sub decrement_weight ($$) {
510 _set_weight('weight-1',shift,shift);
512 sub _set_weight_total ($$) {
513 my $sth = C4::Context->dbh->prepare("
515 SET weight_total=" . (shift) . "
517 "); # note: CANNOT use "?" for weight_total (see the args above).
518 $sth->execute(shift); # just the term
520 sub _set_weight ($$$) {
521 my $dbh = C4::Context->dbh;
522 my $sth = $dbh->prepare("
524 SET weight=" . (shift) . "
531 sub add_tag ($$;$$) { # biblionumber,term,[borrowernumber,approvernumber]
532 my $biblionumber = shift or return undef;
533 my $term = shift or return undef;
534 my $borrowernumber = (@_) ? shift : 0; # the user, default to kohaadmin
537 ($term) or return undef; # must be more than whitespace
538 my $rows = get_tag_rows({biblionumber=>$biblionumber, borrowernumber=>$borrowernumber, term=>$term, limit=>1});
539 my $query = "INSERT INTO tags_all
540 (borrowernumber,biblionumber,term,date_created)
541 VALUES (?,?,?,NOW())";
542 $debug and print STDERR "add_tag query:\n $query\n",
543 "add_tag query args: ($borrowernumber,$biblionumber,$term)\n";
545 $debug and carp "Duplicate tag detected. Tag not added.";
548 # add to tags_all regardless of approaval
549 my $sth = C4::Context->dbh->prepare($query);
550 $sth->execute($borrowernumber,$biblionumber,$term);
553 if (@_) { # if an arg remains, it is the borrowernumber of the approver: tag is pre-approved. Note, whitelist unaffected.
554 my $approver = shift;
555 add_tag_approval($term,$approver);
556 add_tag_index($term,$biblionumber,$approver);
557 } elsif (is_approved($term)) {
558 add_tag_approval($term,1);
559 add_tag_index($term,$biblionumber,1);
561 add_tag_approval($term);
562 add_tag_index($term,$biblionumber);
569 =head1 C4::Tags.pm - Support for user tagging of biblios.
571 More verose debugging messages are sent in the presence of non-zero $ENV{"DEBUG"}.
573 =head2 add_tag(biblionumber,term[,borrowernumber])
575 =head3 TO DO: Add real perldoc
577 =head2 External Dictionary (Ispell) [Recommended]
579 An external dictionary can be used as a means of "pre-populating" and tracking
580 allowed terms based on the widely available Ispell dictionary. This can be the system
581 dictionary or a personal version, but in order to support whitelisting, it must be
582 editable to the process running Koha.
584 To enable, enter the absolute path to the ispell dictionary in the system
585 preference "TagsExternalDictionary".
587 Using external Ispell is recommended for both ease of use and performance. Note that any
588 language version of Ispell can be installed. It is also possible to modify the dictionary
589 at the command line to affect the desired content.
591 =head2 Table Structure
593 The tables used by tags are:
599 Your first thought may be that this looks a little complicated. It is, but only because
600 it has to be. I'll try to explain.
602 tags_all - This table would be all we really need if we didn't care about moderation or
603 performance or tags disappearing when borrowers are removed. Too bad, we do. Otherwise
604 though, it contains all the relevant info about a given tag:
605 tag_id - unique id number for it
606 borrowernumber - user that entered it
607 biblionumber - book record it is attached to
608 term - tag "term" itself
609 language - perhaps used later to influence weighting
610 date_created - date and time it was created
612 tags_approval - Since we need to provide moderation, this table is used to track it. If no
613 external dictionary is used, this table is the sole reference for approval and rejection.
614 With an external dictionary, it tracks pending terms and past whitelist/blacklist actions.
615 This could be called an "approved terms" table. See above regarding the External Dictionary.
616 term - tag "term" itself
617 approved - Negative, 0 or positive if tag is rejected, pending or approved.
618 date_approved - date of last action
619 approved_by - staffer performing the last action
620 weight_total - total occurance of term in any biblio by any users
622 tags_index - This table is for performance, because by far the most common operation will
623 be fetching tags for a list of search results. We will have a set of biblios, and we will
624 want ONLY their approved tags and overall weighting. While we could implement a query that
625 would traverse tags_all filtered against tags_approval, the performance implications of
626 trying to calculate that and the "weight" (number of times a tag appears) on the fly are drastic.
627 term - approved term as it appears in tags_approval
628 biblionumber - book record it is attached to
629 weight - number of times tag applied by any user
631 tags_blacklist - A set of regular expression filters. Unsurprisingly, these should be perl-
632 compatible (PCRE) for your version of perl. Since this is a blacklist, a term will be
633 blocked if it matches any of the given patterns. WARNING: do not add blacklist regexps
634 if you do not understand their operation and interaction. It is quite easy to define too
635 simple or too complex a regexp and effectively block all terms. The blacklist operation is
636 fairly resource intensive, since every line of tags_blacklist will need to be read and compared.
637 It is recommended that tags_blacklist be used minimally, and only by an administrator with an
638 understanding of regular expression syntax and performance.
640 So the best way to think about the different tables is that they are each tailored to a certain
641 use. Note that tags_approval and tags_index do not rely on the user's borrower mapping, so
642 the tag population can continue to grow even if a user (along with their corresponding
643 rows in tags_all) is removed.
647 If you want to auto-populate some tags for debugging, do something like this:
649 mysql> select biblionumber from biblio where title LIKE "%Health%";
680 26 rows in set (0.00 sec)
682 Then, take those numbers and type/pipe them into this perl command line:
683 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",});'
685 Note, the borrowernumber in this example is 51. Use your own or any arbitrary valid borrowernumber.