3 # Copyright Liblime 2008
4 # Parts Copyright ACPL 2011
6 # This file is part of Koha.
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.
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.
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>.
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";
32 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
35 $VERSION = 3.07.00.049;
38 &get_tag &get_tags &get_tag_rows
42 &delete_tag_rows_by_ids
48 &get_count_by_tag_status
53 my $ext_dict = C4::Context->preference('TagsExternalDictionary');
56 import Data::Dumper qw(:DEFAULT);
57 print STDERR __PACKAGE__ . " external dictionary = " . ($ext_dict||'none') . "\n";
60 require Lingua::Ispell;
61 import Lingua::Ispell qw(spellcheck add_word_lc);
62 $Lingua::Ispell::path = $ext_dict;
63 $debug and print STDERR "\$Lingua::Ispell::path = $Lingua::Ispell::path\n";
67 =head1 C4::Tags.pm - Support for user tagging of biblios.
69 More verose debugging messages are sent in the presence of non-zero $ENV{"DEBUG"}.
74 my $query = "SELECT * FROM tags_filters ";
77 $sth = C4::Context->dbh->prepare($query . " WHERE filter_id = ? ");
80 $sth = C4::Context->dbh->prepare($query);
83 return $sth->fetchall_arrayref({});
86 # (SELECT count(*) FROM tags_all ) as tags_all,
87 # (SELECT count(*) FROM tags_index ) as tags_index,
91 (SELECT count(*) FROM tags_approval WHERE approved= 1) as approved_count,
92 (SELECT count(*) FROM tags_approval WHERE approved=-1) as rejected_count,
93 (SELECT count(*) FROM tags_approval WHERE approved= 0) as unapproved_count
95 my $sth = C4::Context->dbh->prepare($query);
97 my $result = $sth->fetchrow_hashref();
98 $result->{approved_total} = $result->{approved_count} + $result->{rejected_count} + $result->{unapproved_count};
99 $debug and warn "counts returned: " . Dumper $result;
103 =head2 get_count_by_tag_status
105 get_count_by_tag_status($status);
107 Takes a status and gets a count of tags with that status
111 sub get_count_by_tag_status {
113 my $dbh = C4::Context->dbh;
115 "SELECT count(*) FROM tags_approval WHERE approved=?";
116 my $sth = $dbh->prepare($query);
117 $sth->execute( $status );
118 return $sth->fetchrow;
122 my $tag_id = shift or return;
123 my $user_id = (@_) ? shift : undef;
124 my $rows = (defined $user_id) ?
125 get_tag_rows({tag_id=>$tag_id, borrowernumber=>$user_id}) :
126 get_tag_rows({tag_id=>$tag_id}) ;
128 (scalar(@$rows) == 1) or return; # should never happen (duplicate ids)
129 my $row = shift(@$rows);
130 ($tag_id == $row->{tag_id}) or return 0;
131 my $tags = get_tags({term=>$row->{term}, biblionumber=>$row->{biblionumber}});
132 my $index = shift(@$tags);
133 $debug and print STDERR
134 sprintf "remove_tag: tag_id=>%s, biblionumber=>%s, weight=>%s, weight_total=>%s\n",
135 $row->{tag_id}, $row->{biblionumber}, $index->{weight}, $index->{weight_total};
136 if ($index->{weight} <= 1) {
137 delete_tag_index($row->{term},$row->{biblionumber});
139 decrement_weight($row->{term},$row->{biblionumber});
141 if ($index->{weight_total} <= 1) {
142 delete_tag_approval($row->{term});
144 decrement_weight_total($row->{term});
146 delete_tag_row_by_id($tag_id);
149 sub delete_tag_index {
151 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_index WHERE term = ? AND biblionumber = ? LIMIT 1");
153 return $sth->rows || 0;
155 sub delete_tag_approval {
157 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_approval WHERE term = ? LIMIT 1");
158 $sth->execute(shift);
159 return $sth->rows || 0;
161 sub delete_tag_row_by_id {
163 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_all WHERE tag_id = ? LIMIT 1");
164 $sth->execute(shift);
165 return $sth->rows || 0;
167 sub delete_tag_rows_by_ids {
171 $i += delete_tag_row_by_id($_);
173 ($i == scalar(@_)) or
174 warn sprintf "delete_tag_rows_by_ids tried %s tag_ids, only succeeded on $i", scalar(@_);
179 my $hash = shift || {};
180 my @ok_fields = TAG_FIELDS;
181 push @ok_fields, 'limit'; # push the limit! :)
185 foreach my $key (keys %$hash) {
186 $debug and print STDERR "get_tag_rows arg. '$key' = ", $hash->{$key}, "\n";
187 unless (length $key) {
188 carp "Empty argument key to get_tag_rows: ignoring!";
191 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
192 carp "get_tag_rows received unreconized argument key '$key'.";
195 if ($key eq 'limit') {
196 my $val = $hash->{$key};
197 unless ($val =~ /^(\d+,)?\d+$/) {
198 carp "Non-nuerical limit value '$val' ignored!";
201 $limit = " LIMIT $val\n";
203 $wheres .= ($wheres) ? " AND $key = ?\n" : " WHERE $key = ?\n";
204 push @exe_args, $hash->{$key};
207 my $query = TAG_SELECT . ($wheres||'') . $limit;
208 $debug and print STDERR "get_tag_rows query:\n $query\n",
209 "get_tag_rows query args: ", join(',', @exe_args), "\n";
210 my $sth = C4::Context->dbh->prepare($query);
212 $sth->execute(@exe_args);
216 return $sth->fetchall_arrayref({});
219 sub get_tags { # i.e., from tags_index
220 my $hash = shift || {};
221 my @ok_fields = qw(term biblionumber weight limit sort approved);
226 foreach my $key (keys %$hash) {
227 $debug and print STDERR "get_tags arg. '$key' = ", $hash->{$key}, "\n";
228 unless (length $key) {
229 carp "Empty argument key to get_tags: ignoring!";
232 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
233 carp "get_tags received unreconized argument key '$key'.";
236 if ($key eq 'limit') {
237 my $val = $hash->{$key};
238 unless ($val =~ /^(\d+,)?\d+$/) {
239 carp "Non-nuerical limit value '$val' ignored!";
242 $limit = " LIMIT $val\n";
243 } elsif ($key eq 'sort') {
244 foreach my $by (split /\,/, $hash->{$key}) {
246 $by =~ /^([-+])?(term)/ or
247 $by =~ /^([-+])?(biblionumber)/ or
248 $by =~ /^([-+])?(weight)/
250 carp "get_tags received illegal sort order '$by'";
256 $order = " ORDER BY ";
258 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
262 my $whereval = $hash->{$key};
263 my $longkey = ($key eq 'term' ) ? 'tags_index.term' :
264 ($key eq 'approved') ? 'tags_approval.approved' : $key;
265 my $op = ($whereval =~ s/^(>=|<=)// or
266 $whereval =~ s/^(>|=|<)// ) ? $1 : '=';
267 $wheres .= ($wheres) ? " AND $longkey $op ?\n" : " WHERE $longkey $op ?\n";
268 push @exe_args, $whereval;
272 SELECT tags_index.term as term,biblionumber,weight,weight_total
274 LEFT JOIN tags_approval
275 ON tags_index.term = tags_approval.term
276 " . ($wheres||'') . $order . $limit;
277 $debug and print STDERR "get_tags query:\n $query\n",
278 "get_tags query args: ", join(',', @exe_args), "\n";
279 my $sth = C4::Context->dbh->prepare($query);
281 $sth->execute(@exe_args);
285 return $sth->fetchall_arrayref({});
288 sub get_approval_rows { # i.e., from tags_approval
289 my $hash = shift || {};
290 my @ok_fields = qw(term approved date_approved approved_by weight_total limit sort borrowernumber);
295 foreach my $key (keys %$hash) {
296 $debug and print STDERR "get_approval_rows arg. '$key' = ", $hash->{$key}, "\n";
297 unless (length $key) {
298 carp "Empty argument key to get_approval_rows: ignoring!";
301 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
302 carp "get_approval_rows received unreconized argument key '$key'.";
305 if ($key eq 'limit') {
306 my $val = $hash->{$key};
307 unless ($val =~ /^(\d+,)?\d+$/) {
308 carp "Non-numerical limit value '$val' ignored!";
311 $limit = " LIMIT $val\n";
312 } elsif ($key eq 'sort') {
313 foreach my $by (split /\,/, $hash->{$key}) {
315 $by =~ /^([-+])?(term)/ or
316 $by =~ /^([-+])?(biblionumber)/ or
317 $by =~ /^([-+])?(borrowernumber)/ or
318 $by =~ /^([-+])?(weight_total)/ or
319 $by =~ /^([-+])?(approved(_by)?)/ or
320 $by =~ /^([-+])?(date_approved)/
322 carp "get_approval_rows received illegal sort order '$by'";
328 $order = " ORDER BY " unless $order;
330 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
334 my $whereval = $hash->{$key};
335 my $op = ($whereval =~ s/^(>=|<=)// or
336 $whereval =~ s/^(>|=|<)// ) ? $1 : '=';
337 $wheres .= ($wheres) ? " AND $key $op ?\n" : " WHERE $key $op ?\n";
338 push @exe_args, $whereval;
342 SELECT tags_approval.term AS term,
343 tags_approval.approved AS approved,
344 tags_approval.date_approved AS date_approved,
345 tags_approval.approved_by AS approved_by,
346 tags_approval.weight_total AS weight_total,
347 CONCAT(borrowers.surname, ', ', borrowers.firstname) AS approved_by_name
350 ON tags_approval.approved_by = borrowers.borrowernumber ";
351 $query .= ($wheres||'') . $order . $limit;
352 $debug and print STDERR "get_approval_rows query:\n $query\n",
353 "get_approval_rows query args: ", join(',', @exe_args), "\n";
354 my $sth = C4::Context->dbh->prepare($query);
356 $sth->execute(@exe_args);
360 return $sth->fetchall_arrayref({});
364 my $term = shift or return;
365 my $sth = C4::Context->dbh->prepare("SELECT approved FROM tags_approval WHERE term = ?");
366 $sth->execute($term);
367 my $ext_dict = C4::Context->preference('TagsExternalDictionary');
368 unless ($sth->rows) {
369 $ext_dict and return (spellcheck($term) ? 0 : 1); # spellcheck returns empty on OK word
372 return $sth->fetchrow;
376 my $term = shift or return;
379 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?");
380 $sth->execute($term,shift);
382 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ?");
383 $sth->execute($term);
385 return $sth->fetchrow_hashref;
389 my $operator = shift;
390 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
391 my $ext_dict = C4::Context->preference('TagsExternalDictionary');
394 spellcheck($_) or next;
399 my $aref = get_approval_rows({term=>$_});
400 if ($aref and scalar @$aref) {
401 mod_tag_approval($operator,$_,1);
403 add_tag_approval($_,$operator);
408 # note: there is no "unwhitelist" operation because there is no remove for Ispell.
409 # The blacklist regexps should operate "in front of" the whitelist, so if you approve
410 # a term mistakenly, you can still reverse it. But there is no going back to "neutral".
412 my $operator = shift;
413 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
415 my $aref = get_approval_rows({term=>$_});
416 if ($aref and scalar @$aref) {
417 mod_tag_approval($operator,$_,-1);
419 add_tag_approval($_,$operator,-1);
425 my $operator = shift;
426 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
427 my $query = "INSERT INTO tags_blacklist (regexp,y,z) VALUES (?,?,?)";
428 # my $sth = C4::Context->dbh->prepare($query);
432 my $operator = shift;
433 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
434 my $query = "REMOVE FROM tags_blacklist WHERE blacklist_id = ?";
435 # my $sth = C4::Context->dbh->prepare($query);
436 # $sth->execute($term);
440 sub add_tag_approval { # or disapproval
441 $debug and warn "add_tag_approval(" . join(", ",map {defined($_) ? $_ : 'UNDEF'} @_) . ")";
442 my $term = shift or return;
443 my $query = "SELECT * FROM tags_approval WHERE term = ?";
444 my $sth = C4::Context->dbh->prepare($query);
445 $sth->execute($term);
446 ($sth->rows) and return increment_weight_total($term);
447 my $operator = shift || 0;
448 my $approval = (@_ ? shift : 0); # default is unapproved
449 my @exe_args = ($term); # all 3 queries will use this argument
451 $query = "INSERT INTO tags_approval (term,approved_by,approved,date_approved) VALUES (?,?,?,NOW())";
452 push @exe_args, $operator, $approval;
453 } elsif ($approval) {
454 $query = "INSERT INTO tags_approval (term,approved,date_approved) VALUES (?,?,NOW())";
455 push @exe_args, $approval;
457 $query = "INSERT INTO tags_approval (term,date_approved) VALUES (?,NOW())";
459 $debug and print STDERR "add_tag_approval query: $query\nadd_tag_approval args: (" . join(", ", @exe_args) . ")\n";
460 $sth = C4::Context->dbh->prepare($query);
461 $sth->execute(@exe_args);
465 sub mod_tag_approval {
466 my $operator = shift;
467 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
468 my $term = shift or return;
469 my $approval = (scalar @_ ? shift : 1); # default is to approve
470 my $query = "UPDATE tags_approval SET approved_by=?, approved=?, date_approved=NOW() WHERE term = ?";
471 $debug and print STDERR "mod_tag_approval query: $query\nmod_tag_approval args: ($operator,$approval,$term)\n";
472 my $sth = C4::Context->dbh->prepare($query);
473 $sth->execute($operator,$approval,$term);
477 my $term = shift or return;
478 my $biblionumber = shift or return;
479 my $query = "SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?";
480 my $sth = C4::Context->dbh->prepare($query);
481 $sth->execute($term,$biblionumber);
482 ($sth->rows) and return increment_weight($term,$biblionumber);
483 $query = "INSERT INTO tags_index (term,biblionumber) VALUES (?,?)";
484 $debug and print STDERR "add_tag_index query: $query\nadd_tag_index args: ($term,$biblionumber)\n";
485 $sth = C4::Context->dbh->prepare($query);
486 $sth->execute($term,$biblionumber);
490 sub get_tag { # by tag_id
492 my $sth = C4::Context->dbh->prepare(TAG_SELECT . "WHERE tag_id = ?");
493 $sth->execute(shift);
494 return $sth->fetchrow_hashref;
497 sub increment_weights {
498 increment_weight(@_);
499 increment_weight_total(shift);
501 sub decrement_weights {
502 decrement_weight(@_);
503 decrement_weight_total(shift);
505 sub increment_weight_total {
506 _set_weight_total('weight_total+1',shift);
508 sub increment_weight {
509 _set_weight('weight+1',shift,shift);
511 sub decrement_weight_total {
512 _set_weight_total('weight_total-1',shift);
514 sub decrement_weight {
515 _set_weight('weight-1',shift,shift);
517 sub _set_weight_total {
518 my $sth = C4::Context->dbh->prepare("
520 SET weight_total=" . (shift) . "
522 "); # note: CANNOT use "?" for weight_total (see the args above).
523 $sth->execute(shift); # just the term
526 my $dbh = C4::Context->dbh;
527 my $sth = $dbh->prepare("
529 SET weight=" . (shift) . "
536 sub add_tag { # biblionumber,term,[borrowernumber,approvernumber]
537 my $biblionumber = shift or return;
538 my $term = shift or return;
539 my $borrowernumber = (@_) ? shift : 0; # the user, default to kohaadmin
542 ($term) or return; # must be more than whitespace
543 my $rows = get_tag_rows({biblionumber=>$biblionumber, borrowernumber=>$borrowernumber, term=>$term, limit=>1});
544 my $query = "INSERT INTO tags_all
545 (borrowernumber,biblionumber,term,date_created)
546 VALUES (?,?,?,NOW())";
547 $debug and print STDERR "add_tag query: $query\n",
548 "add_tag query args: ($borrowernumber,$biblionumber,$term)\n";
550 $debug and carp "Duplicate tag detected. Tag not added.";
553 # add to tags_all regardless of approaval
554 my $sth = C4::Context->dbh->prepare($query);
555 $sth->execute($borrowernumber,$biblionumber,$term);
558 if (scalar @_) { # if arg remains, it is the borrowernumber of the approver: tag is pre-approved.
559 my $approver = shift;
560 $debug and print STDERR "term '$term' pre-approved by borrower #$approver\n";
561 add_tag_approval($term,$approver,1);
562 add_tag_index($term,$biblionumber,$approver);
563 } elsif (is_approved($term) >= 1) {
564 $debug and print STDERR "term '$term' approved by whitelist\n";
565 add_tag_approval($term,0,1);
566 add_tag_index($term,$biblionumber,1);
568 $debug and print STDERR "term '$term' NOT approved (yet)\n";
569 add_tag_approval($term);
570 add_tag_index($term,$biblionumber);
574 # This takes a set of tags, as returned by C<get_approval_rows> and divides
575 # them up into a number of "strata" based on their weight. This is useful
576 # to display them in a number of different sizes.
579 # ($min, $max) = stratify_tags($strata, $tags);
580 # $stratum: the number of divisions you want
581 # $tags: the tags, as provided by get_approval_rows
582 # $min: the minimum stratum value
583 # $max: the maximum stratum value. This may be the same as $min if there
584 # is only one weight. Beware of divide by zeros.
585 # This will add a field to the tag called "stratum" containing the calculated
588 my ( $strata, $tags ) = @_;
589 return (0,0) if !@$tags;
592 my $w = $_->{weight_total};
593 $min = $w if ( !defined($min) || $min > $w );
594 $max = $w if ( !defined($max) || $max < $w );
597 # normalise min to zero
602 # if min and max are the same, just make it 1
603 my $span = ( $strata - 1 ) / ( $max || 1 );
605 my $w = $_->{weight_total};
606 $_->{stratum} = int( ( $w - $orig_min ) * $span );
608 return ( $min, $max );
614 =head2 add_tag(biblionumber,term[,borrowernumber])
616 =head3 TO DO: Add real perldoc
620 =head2 External Dictionary (Ispell) [Recommended]
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.
627 To enable, enter the absolute path to the ispell dictionary in the system
628 preference "TagsExternalDictionary".
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.
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
638 =head2 Table Structure
640 The tables used by tags are:
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.
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
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 occurrence of term in any biblio by any users
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
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.
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.
694 If you want to auto-populate some tags for debugging, do something like this:
696 mysql> select biblionumber from biblio where title LIKE "%Health%";
727 26 rows in set (0.00 sec)
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",});'
732 Note, the borrowernumber in this example is 51. Use your own or any arbitrary valid borrowernumber.