← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:27 2013

Filename/usr/share/koha/lib/C4/Tags.pm
StatementsExecuted 1787 statements in 50.0ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
25116.73ms68.7msC4::Tags::::get_tagsC4::Tags::get_tags
600111.35ms1.35msC4::Tags::::CORE:regcompC4::Tags::CORE:regcomp (opcode)
70031853µs853µsC4::Tags::::CORE:matchC4::Tags::CORE:match (opcode)
10011172µs172µsC4::Tags::::CORE:substC4::Tags::CORE:subst (opcode)
11135µs1.96msC4::Tags::::BEGIN@35C4::Tags::BEGIN@35
11124µs31µsC4::Tags::::BEGIN@21C4::Tags::BEGIN@21
11122µs88µsC4::Tags::::BEGIN@30C4::Tags::BEGIN@30
11121µs143µsC4::Tags::::BEGIN@27C4::Tags::BEGIN@27
11118µs44µsC4::Tags::::BEGIN@22C4::Tags::BEGIN@22
11117µs73µsC4::Tags::::BEGIN@23C4::Tags::BEGIN@23
11117µs17µsC4::Tags::::INITC4::Tags::INIT
11116µs21µsC4::Tags::::BEGIN@26C4::Tags::BEGIN@26
11114µs66µsC4::Tags::::BEGIN@29C4::Tags::BEGIN@29
11114µs34µsC4::Tags::::BEGIN@24C4::Tags::BEGIN@24
11113µs96µsC4::Tags::::BEGIN@32C4::Tags::BEGIN@32
0000s0sC4::Tags::::_set_weightC4::Tags::_set_weight
0000s0sC4::Tags::::_set_weight_totalC4::Tags::_set_weight_total
0000s0sC4::Tags::::add_filterC4::Tags::add_filter
0000s0sC4::Tags::::add_tagC4::Tags::add_tag
0000s0sC4::Tags::::add_tag_approvalC4::Tags::add_tag_approval
0000s0sC4::Tags::::add_tag_indexC4::Tags::add_tag_index
0000s0sC4::Tags::::approval_countsC4::Tags::approval_counts
0000s0sC4::Tags::::blacklistC4::Tags::blacklist
0000s0sC4::Tags::::decrement_weightC4::Tags::decrement_weight
0000s0sC4::Tags::::decrement_weight_totalC4::Tags::decrement_weight_total
0000s0sC4::Tags::::decrement_weightsC4::Tags::decrement_weights
0000s0sC4::Tags::::delete_tag_approvalC4::Tags::delete_tag_approval
0000s0sC4::Tags::::delete_tag_indexC4::Tags::delete_tag_index
0000s0sC4::Tags::::delete_tag_row_by_idC4::Tags::delete_tag_row_by_id
0000s0sC4::Tags::::delete_tag_rows_by_idsC4::Tags::delete_tag_rows_by_ids
0000s0sC4::Tags::::get_approval_rowsC4::Tags::get_approval_rows
0000s0sC4::Tags::::get_count_by_tag_statusC4::Tags::get_count_by_tag_status
0000s0sC4::Tags::::get_filtersC4::Tags::get_filters
0000s0sC4::Tags::::get_tagC4::Tags::get_tag
0000s0sC4::Tags::::get_tag_indexC4::Tags::get_tag_index
0000s0sC4::Tags::::get_tag_rowsC4::Tags::get_tag_rows
0000s0sC4::Tags::::increment_weightC4::Tags::increment_weight
0000s0sC4::Tags::::increment_weight_totalC4::Tags::increment_weight_total
0000s0sC4::Tags::::increment_weightsC4::Tags::increment_weights
0000s0sC4::Tags::::is_approvedC4::Tags::is_approved
0000s0sC4::Tags::::mod_tag_approvalC4::Tags::mod_tag_approval
0000s0sC4::Tags::::remove_filterC4::Tags::remove_filter
0000s0sC4::Tags::::remove_tagC4::Tags::remove_tag
0000s0sC4::Tags::::stratify_tagsC4::Tags::stratify_tags
0000s0sC4::Tags::::whitelistC4::Tags::whitelist
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package 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
21334µs238µs
# spent 31µs (24+7) within C4::Tags::BEGIN@21 which was called: # once (24µs+7µs) by main::BEGIN@51 at line 21
use strict;
# spent 31µs making 1 call to C4::Tags::BEGIN@21 # spent 7µs making 1 call to strict::import
22388µs269µs
# spent 44µs (18+26) within C4::Tags::BEGIN@22 which was called: # once (18µs+26µs) by main::BEGIN@51 at line 22
use warnings;
# spent 44µs making 1 call to C4::Tags::BEGIN@22 # spent 26µs making 1 call to warnings::import
23335µs2129µs
# spent 73µs (17+56) within C4::Tags::BEGIN@23 which was called: # once (17µs+56µs) by main::BEGIN@51 at line 23
use Carp;
# spent 73µs making 1 call to C4::Tags::BEGIN@23 # spent 56µs making 1 call to Exporter::import
24329µs254µs
# spent 34µs (14+20) within C4::Tags::BEGIN@24 which was called: # once (14µs+20µs) by main::BEGIN@51 at line 24
use Exporter;
# spent 34µs making 1 call to C4::Tags::BEGIN@24 # spent 20µs making 1 call to Exporter::import
25
26390µs225µs
# spent 21µs (16+4) within C4::Tags::BEGIN@26 which was called: # once (16µs+4µs) by main::BEGIN@51 at line 26
use C4::Context;
# spent 21µs making 1 call to C4::Tags::BEGIN@26 # spent 4µs making 1 call to C4::Context::import
27362µs2265µs
# spent 143µs (21+122) within C4::Tags::BEGIN@27 which was called: # once (21µs+122µs) by main::BEGIN@51 at line 27
use C4::Debug;
# spent 143µs making 1 call to C4::Tags::BEGIN@27 # spent 122µs making 1 call to Exporter::import
28#use Data::Dumper;
29354µs2118µs
# spent 66µs (14+52) within C4::Tags::BEGIN@29 which was called: # once (14µs+52µs) by main::BEGIN@51 at line 29
use constant TAG_FIELDS => qw(tag_id borrowernumber biblionumber term language date_created);
# spent 66µs making 1 call to C4::Tags::BEGIN@29 # spent 52µs making 1 call to constant::import
30351µs3154µs
# spent 88µs (22+66) within C4::Tags::BEGIN@30 which was called: # once (22µs+66µs) by main::BEGIN@51 at line 30
use constant TAG_SELECT => "SELECT " . join(',', TAG_FIELDS) . "\n FROM tags_all\n";
# spent 88µs making 1 call to C4::Tags::BEGIN@30 # spent 63µs making 1 call to constant::import # spent 3µs making 1 call to constant::__ANON__[constant.pm:119]
31
323169µs2179µs
# spent 96µs (13+83) within C4::Tags::BEGIN@32 which was called: # once (13µs+83µs) by main::BEGIN@51 at line 32
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# spent 96µs making 1 call to C4::Tags::BEGIN@32 # spent 83µs making 1 call to vars::import
331300nsour $ext_dict;
34
35
# spent 1.96ms (35µs+1.92) within C4::Tags::BEGIN@35 which was called: # once (35µs+1.92ms) by main::BEGIN@51 at line 64
BEGIN {
36626µs $VERSION = 3.07.00.049;
37 @ISA = qw(Exporter);
38 @EXPORT_OK = qw(
39 &get_tag &get_tags &get_tag_rows
40 &add_tags &add_tag
41 &delete_tag_row_by_id
42 &remove_tag
43 &delete_tag_rows_by_ids
44 &get_approval_rows
45 &blacklist
46 &whitelist
47 &is_approved
48 &approval_counts
49 &get_count_by_tag_status
50 &get_filters
51 stratify_tags
52 );
53 # %EXPORT_TAGS = ();
5411.92ms $ext_dict = C4::Context->preference('TagsExternalDictionary');
# spent 1.92ms making 1 call to C4::Context::preference
55 if ($debug) {
56 require Data::Dumper;
57 import Data::Dumper qw(:DEFAULT);
58 print STDERR __PACKAGE__ . " external dictionary = " . ($ext_dict||'none') . "\n";
59 }
60 if ($ext_dict) {
61 require Lingua::Ispell;
62 import Lingua::Ispell qw(spellcheck add_word_lc save_dictionary);
63 }
6416.14ms11.96ms}
# spent 1.96ms making 1 call to C4::Tags::BEGIN@35
65
66=head1 C4::Tags.pm - Support for user tagging of biblios.
67
- -
72
# spent 17µs within C4::Tags::INIT which was called: # once (17µs+0s) by main::RUNTIME at line 0 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
INIT {
73225µs $ext_dict and $Lingua::Ispell::path = $ext_dict;
74 $debug and print STDERR "\$Lingua::Ispell::path = $Lingua::Ispell::path\n";
75}
76
77sub get_filters {
78 my $query = "SELECT * FROM tags_filters ";
79 my ($sth);
80 if (@_) {
81 $sth = C4::Context->dbh->prepare($query . " WHERE filter_id = ? ");
82 $sth->execute(shift);
83 } else {
84 $sth = C4::Context->dbh->prepare($query);
85 $sth->execute;
86 }
87 return $sth->fetchall_arrayref({});
88}
89
90# (SELECT count(*) FROM tags_all ) as tags_all,
91# (SELECT count(*) FROM tags_index ) as tags_index,
92
93sub approval_counts {
94 my $query = "SELECT
95 (SELECT count(*) FROM tags_approval WHERE approved= 1) as approved_count,
96 (SELECT count(*) FROM tags_approval WHERE approved=-1) as rejected_count,
97 (SELECT count(*) FROM tags_approval WHERE approved= 0) as unapproved_count
98 ";
99 my $sth = C4::Context->dbh->prepare($query);
100 $sth->execute;
101 my $result = $sth->fetchrow_hashref();
102 $result->{approved_total} = $result->{approved_count} + $result->{rejected_count} + $result->{unapproved_count};
103 $debug and warn "counts returned: " . Dumper $result;
104 return $result;
105}
106
107=head2 get_count_by_tag_status
108
- -
115sub get_count_by_tag_status {
116 my ($status) = @_;
117 my $dbh = C4::Context->dbh;
118 my $query =
119 "SELECT count(*) FROM tags_approval WHERE approved=?";
120 my $sth = $dbh->prepare($query);
121 $sth->execute( $status );
122 return $sth->fetchrow;
123}
124
125sub remove_tag {
126 my $tag_id = shift or return;
127 my $user_id = (@_) ? shift : undef;
128 my $rows = (defined $user_id) ?
129 get_tag_rows({tag_id=>$tag_id, borrowernumber=>$user_id}) :
130 get_tag_rows({tag_id=>$tag_id}) ;
131 $rows or return 0;
132 (scalar(@$rows) == 1) or return; # should never happen (duplicate ids)
133 my $row = shift(@$rows);
134 ($tag_id == $row->{tag_id}) or return 0;
135 my $tags = get_tags({term=>$row->{term}, biblionumber=>$row->{biblionumber}});
136 my $index = shift(@$tags);
137 $debug and print STDERR
138 sprintf "remove_tag: tag_id=>%s, biblionumber=>%s, weight=>%s, weight_total=>%s\n",
139 $row->{tag_id}, $row->{biblionumber}, $index->{weight}, $index->{weight_total};
140 if ($index->{weight} <= 1) {
141 delete_tag_index($row->{term},$row->{biblionumber});
142 } else {
143 decrement_weight($row->{term},$row->{biblionumber});
144 }
145 if ($index->{weight_total} <= 1) {
146 delete_tag_approval($row->{term});
147 } else {
148 decrement_weight_total($row->{term});
149 }
150 delete_tag_row_by_id($tag_id);
151}
152
153sub delete_tag_index {
154 (@_) or return;
155 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_index WHERE term = ? AND biblionumber = ? LIMIT 1");
156 $sth->execute(@_);
157 return $sth->rows || 0;
158}
159sub delete_tag_approval {
160 (@_) or return;
161 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_approval WHERE term = ? LIMIT 1");
162 $sth->execute(shift);
163 return $sth->rows || 0;
164}
165sub delete_tag_row_by_id {
166 (@_) or return;
167 my $sth = C4::Context->dbh->prepare("DELETE FROM tags_all WHERE tag_id = ? LIMIT 1");
168 $sth->execute(shift);
169 return $sth->rows || 0;
170}
171sub delete_tag_rows_by_ids {
172 (@_) or return;
173 my $i=0;
174 foreach(@_) {
175 $i += delete_tag_row_by_id($_);
176 }
177 ($i == scalar(@_)) or
178 warn sprintf "delete_tag_rows_by_ids tried %s tag_ids, only succeeded on $i", scalar(@_);
179 return $i;
180}
181
182sub get_tag_rows {
183 my $hash = shift || {};
184 my @ok_fields = TAG_FIELDS;
185 push @ok_fields, 'limit'; # push the limit! :)
186 my $wheres;
187 my $limit = "";
188 my @exe_args = ();
189 foreach my $key (keys %$hash) {
190 $debug and print STDERR "get_tag_rows arg. '$key' = ", $hash->{$key}, "\n";
191 unless (length $key) {
192 carp "Empty argument key to get_tag_rows: ignoring!";
193 next;
194 }
195 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
196 carp "get_tag_rows received unreconized argument key '$key'.";
197 next;
198 }
199 if ($key eq 'limit') {
200 my $val = $hash->{$key};
201 unless ($val =~ /^(\d+,)?\d+$/) {
202 carp "Non-nuerical limit value '$val' ignored!";
203 next;
204 }
205 $limit = " LIMIT $val\n";
206 } else {
207 $wheres .= ($wheres) ? " AND $key = ?\n" : " WHERE $key = ?\n";
208 push @exe_args, $hash->{$key};
209 }
210 }
211 my $query = TAG_SELECT . ($wheres||'') . $limit;
212 $debug and print STDERR "get_tag_rows query:\n $query\n",
213 "get_tag_rows query args: ", join(',', @exe_args), "\n";
214 my $sth = C4::Context->dbh->prepare($query);
215 if (@exe_args) {
216 $sth->execute(@exe_args);
217 } else {
218 $sth->execute;
219 }
220 return $sth->fetchall_arrayref({});
221}
222
223
# spent 68.7ms (6.73+62.0) within C4::Tags::get_tags which was called 25 times, avg 2.75ms/call: # 25 times (6.73ms+62.0ms) by main::RUNTIME at line 581 of /usr/share/koha/opac/cgi-bin/opac/opac-search.pl, avg 2.75ms/call
sub get_tags { # i.e., from tags_index
224175041.8ms my $hash = shift || {};
225 my @ok_fields = qw(term biblionumber weight limit sort approved);
226 my $wheres;
227 my $limit = "";
228 my $order = "";
229 my @exe_args = ();
230 foreach my $key (keys %$hash) {
231 $debug and print STDERR "get_tags arg. '$key' = ", $hash->{$key}, "\n";
232 unless (length $key) {
233 carp "Empty argument key to get_tags: ignoring!";
234 next;
235 }
23612001.92ms unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
# spent 1.35ms making 600 calls to C4::Tags::CORE:regcomp, avg 2µs/call # spent 566µs making 600 calls to C4::Tags::CORE:match, avg 943ns/call
237 carp "get_tags received unreconized argument key '$key'.";
238 next;
239 }
240 if ($key eq 'limit') {
241 my $val = $hash->{$key};
2422595µs unless ($val =~ /^(\d+,)?\d+$/) {
# spent 95µs making 25 calls to C4::Tags::CORE:match, avg 4µs/call
243 carp "Non-nuerical limit value '$val' ignored!";
244 next;
245 }
246 $limit = " LIMIT $val\n";
247 } elsif ($key eq 'sort') {
248 foreach my $by (split /\,/, $hash->{$key}) {
24975192µs unless (
# spent 192µs making 75 calls to C4::Tags::CORE:match, avg 3µs/call
250 $by =~ /^([-+])?(term)/ or
251 $by =~ /^([-+])?(biblionumber)/ or
252 $by =~ /^([-+])?(weight)/
253 ) {
254 carp "get_tags received illegal sort order '$by'";
255 next;
256 }
257 if ($order) {
258 $order .= ", ";
259 } else {
260 $order = " ORDER BY ";
261 }
262 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
263 }
264
265 } else {
266 my $whereval = $hash->{$key};
267 my $longkey = ($key eq 'term' ) ? 'tags_index.term' :
268 ($key eq 'approved') ? 'tags_approval.approved' : $key;
269100172µs my $op = ($whereval =~ s/^(>=|<=)// or
# spent 172µs making 100 calls to C4::Tags::CORE:subst, avg 2µs/call
270 $whereval =~ s/^(>|=|<)// ) ? $1 : '=';
271 $wheres .= ($wheres) ? " AND $longkey $op ?\n" : " WHERE $longkey $op ?\n";
272 push @exe_args, $whereval;
273 }
274 }
275 my $query = "
276 SELECT tags_index.term as term,biblionumber,weight,weight_total
277 FROM tags_index
278 LEFT JOIN tags_approval
279 ON tags_index.term = tags_approval.term
280 " . ($wheres||'') . $order . $limit;
281 $debug and print STDERR "get_tags query:\n $query\n",
282 "get_tags query args: ", join(',', @exe_args), "\n";
2831140µs7526.0ms my $sth = C4::Context->dbh->prepare($query);
# spent 21.6ms making 25 calls to C4::Context::dbh, avg 866µs/call # spent 2.35ms making 25 calls to DBI::db::prepare, avg 94µs/call # spent 1.97ms making 25 calls to DBD::mysql::db::prepare, avg 79µs/call
2842532.9ms if (@exe_args) {
# spent 32.9ms making 25 calls to DBI::st::execute, avg 1.32ms/call
285 $sth->execute(@exe_args);
286 } else {
287 $sth->execute;
288 }
28911.20ms504.14ms return $sth->fetchall_arrayref({});
# spent 2.35ms making 25 calls to DBI::st::fetchall_arrayref, avg 94µs/call # spent 1.79ms making 25 calls to DBD::_::st::fetchall_arrayref, avg 71µs/call
290}
291
292sub get_approval_rows { # i.e., from tags_approval
293 my $hash = shift || {};
294 my @ok_fields = qw(term approved date_approved approved_by weight_total limit sort borrowernumber);
295 my $wheres;
296 my $limit = "";
297 my $order = "";
298 my @exe_args = ();
299 foreach my $key (keys %$hash) {
300 $debug and print STDERR "get_approval_rows arg. '$key' = ", $hash->{$key}, "\n";
301 unless (length $key) {
302 carp "Empty argument key to get_approval_rows: ignoring!";
303 next;
304 }
305 unless (1 == scalar grep {/^ $key $/x} @ok_fields) {
306 carp "get_approval_rows received unreconized argument key '$key'.";
307 next;
308 }
309 if ($key eq 'limit') {
310 my $val = $hash->{$key};
311 unless ($val =~ /^(\d+,)?\d+$/) {
312 carp "Non-numerical limit value '$val' ignored!";
313 next;
314 }
315 $limit = " LIMIT $val\n";
316 } elsif ($key eq 'sort') {
317 foreach my $by (split /\,/, $hash->{$key}) {
318 unless (
319 $by =~ /^([-+])?(term)/ or
320 $by =~ /^([-+])?(biblionumber)/ or
321 $by =~ /^([-+])?(borrowernumber)/ or
322 $by =~ /^([-+])?(weight_total)/ or
323 $by =~ /^([-+])?(approved(_by)?)/ or
324 $by =~ /^([-+])?(date_approved)/
325 ) {
326 carp "get_approval_rows received illegal sort order '$by'";
327 next;
328 }
329 if ($order) {
330 $order .= ", ";
331 } else {
332 $order = " ORDER BY " unless $order;
333 }
334 $order .= $2 . " " . ((!$1) ? '' : $1 eq '-' ? 'DESC' : $1 eq '+' ? 'ASC' : '') . "\n";
335 }
336
337 } else {
338 my $whereval = $hash->{$key};
339 my $op = ($whereval =~ s/^(>=|<=)// or
340 $whereval =~ s/^(>|=|<)// ) ? $1 : '=';
341 $wheres .= ($wheres) ? " AND $key $op ?\n" : " WHERE $key $op ?\n";
342 push @exe_args, $whereval;
343 }
344 }
345 my $query = "
346 SELECT tags_approval.term AS term,
347 tags_approval.approved AS approved,
348 tags_approval.date_approved AS date_approved,
349 tags_approval.approved_by AS approved_by,
350 tags_approval.weight_total AS weight_total,
351 CONCAT(borrowers.surname, ', ', borrowers.firstname) AS approved_by_name
352 FROM tags_approval
353 LEFT JOIN borrowers
354 ON tags_approval.approved_by = borrowers.borrowernumber ";
355 $query .= ($wheres||'') . $order . $limit;
356 $debug and print STDERR "get_approval_rows query:\n $query\n",
357 "get_approval_rows query args: ", join(',', @exe_args), "\n";
358 my $sth = C4::Context->dbh->prepare($query);
359 if (@exe_args) {
360 $sth->execute(@exe_args);
361 } else {
362 $sth->execute;
363 }
364 return $sth->fetchall_arrayref({});
365}
366
367sub is_approved {
368 my $term = shift or return;
369 my $sth = C4::Context->dbh->prepare("SELECT approved FROM tags_approval WHERE term = ?");
370 $sth->execute($term);
371 unless ($sth->rows) {
372 $ext_dict and return (spellcheck($term) ? 0 : 1); # spellcheck returns empty on OK word
373 return 0;
374 }
375 return $sth->fetchrow;
376}
377
378sub get_tag_index {
379 my $term = shift or return;
380 my $sth;
381 if (@_) {
382 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?");
383 $sth->execute($term,shift);
384 } else {
385 $sth = C4::Context->dbh->prepare("SELECT * FROM tags_index WHERE term = ?");
386 $sth->execute($term);
387 }
388 return $sth->fetchrow_hashref;
389}
390
391sub whitelist {
392 my $operator = shift;
393 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
394 if ($ext_dict) {
395 foreach (@_) {
396 spellcheck($_) or next;
397 add_word_lc($_);
398 }
399 }
400 foreach (@_) {
401 my $aref = get_approval_rows({term=>$_});
402 if ($aref and scalar @$aref) {
403 mod_tag_approval($operator,$_,1);
404 } else {
405 add_tag_approval($_,$operator);
406 }
407 }
408 return scalar @_;
409}
410# note: there is no "unwhitelist" operation because there is no remove for Ispell.
411# The blacklist regexps should operate "in front of" the whitelist, so if you approve
412# a term mistakenly, you can still reverse it. But there is no going back to "neutral".
413sub blacklist {
414 my $operator = shift;
415 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
416 foreach (@_) {
417 my $aref = get_approval_rows({term=>$_});
418 if ($aref and scalar @$aref) {
419 mod_tag_approval($operator,$_,-1);
420 } else {
421 add_tag_approval($_,$operator,-1);
422 }
423 }
424 return scalar @_;
425}
426sub add_filter {
427 my $operator = shift;
428 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
429 my $query = "INSERT INTO tags_blacklist (regexp,y,z) VALUES (?,?,?)";
430 # my $sth = C4::Context->dbh->prepare($query);
431 return scalar @_;
432}
433sub remove_filter {
434 my $operator = shift;
435 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
436 my $query = "REMOVE FROM tags_blacklist WHERE blacklist_id = ?";
437 # my $sth = C4::Context->dbh->prepare($query);
438 # $sth->execute($term);
439 return scalar @_;
440}
441
442sub add_tag_approval { # or disapproval
443 $debug and warn "add_tag_approval(" . join(", ",map {defined($_) ? $_ : 'UNDEF'} @_) . ")";
444 my $term = shift or return;
445 my $query = "SELECT * FROM tags_approval WHERE term = ?";
446 my $sth = C4::Context->dbh->prepare($query);
447 $sth->execute($term);
448 ($sth->rows) and return increment_weight_total($term);
449 my $operator = shift || 0;
450 my $approval = (@_ ? shift : 0); # default is unapproved
451 my @exe_args = ($term); # all 3 queries will use this argument
452 if ($operator) {
453 $query = "INSERT INTO tags_approval (term,approved_by,approved,date_approved) VALUES (?,?,?,NOW())";
454 push @exe_args, $operator, $approval;
455 } elsif ($approval) {
456 $query = "INSERT INTO tags_approval (term,approved,date_approved) VALUES (?,?,NOW())";
457 push @exe_args, $approval;
458 } else {
459 $query = "INSERT INTO tags_approval (term,date_approved) VALUES (?,NOW())";
460 }
461 $debug and print STDERR "add_tag_approval query: $query\nadd_tag_approval args: (" . join(", ", @exe_args) . ")\n";
462 $sth = C4::Context->dbh->prepare($query);
463 $sth->execute(@exe_args);
464 return $sth->rows;
465}
466
467sub mod_tag_approval {
468 my $operator = shift;
469 defined $operator or return; # have to test defined to allow =0 (kohaadmin)
470 my $term = shift or return;
471 my $approval = (scalar @_ ? shift : 1); # default is to approve
472 my $query = "UPDATE tags_approval SET approved_by=?, approved=?, date_approved=NOW() WHERE term = ?";
473 $debug and print STDERR "mod_tag_approval query: $query\nmod_tag_approval args: ($operator,$approval,$term)\n";
474 my $sth = C4::Context->dbh->prepare($query);
475 $sth->execute($operator,$approval,$term);
476}
477
478sub add_tag_index {
479 my $term = shift or return;
480 my $biblionumber = shift or return;
481 my $query = "SELECT * FROM tags_index WHERE term = ? AND biblionumber = ?";
482 my $sth = C4::Context->dbh->prepare($query);
483 $sth->execute($term,$biblionumber);
484 ($sth->rows) and return increment_weight($term,$biblionumber);
485 $query = "INSERT INTO tags_index (term,biblionumber) VALUES (?,?)";
486 $debug and print STDERR "add_tag_index query: $query\nadd_tag_index args: ($term,$biblionumber)\n";
487 $sth = C4::Context->dbh->prepare($query);
488 $sth->execute($term,$biblionumber);
489 return $sth->rows;
490}
491
492sub get_tag { # by tag_id
493 (@_) or return;
494 my $sth = C4::Context->dbh->prepare(TAG_SELECT . "WHERE tag_id = ?");
495 $sth->execute(shift);
496 return $sth->fetchrow_hashref;
497}
498
499sub increment_weights {
500 increment_weight(@_);
501 increment_weight_total(shift);
502}
503sub decrement_weights {
504 decrement_weight(@_);
505 decrement_weight_total(shift);
506}
507sub increment_weight_total {
508 _set_weight_total('weight_total+1',shift);
509}
510sub increment_weight {
511 _set_weight('weight+1',shift,shift);
512}
513sub decrement_weight_total {
514 _set_weight_total('weight_total-1',shift);
515}
516sub decrement_weight {
517 _set_weight('weight-1',shift,shift);
518}
519sub _set_weight_total {
520 my $sth = C4::Context->dbh->prepare("
521 UPDATE tags_approval
522 SET weight_total=" . (shift) . "
523 WHERE term=?
524 "); # note: CANNOT use "?" for weight_total (see the args above).
525 $sth->execute(shift); # just the term
526}
527sub _set_weight {
528 my $dbh = C4::Context->dbh;
529 my $sth = $dbh->prepare("
530 UPDATE tags_index
531 SET weight=" . (shift) . "
532 WHERE term=?
533 AND biblionumber=?
534 ");
535 $sth->execute(@_);
536}
537
538sub add_tag { # biblionumber,term,[borrowernumber,approvernumber]
539 my $biblionumber = shift or return;
540 my $term = shift or return;
541 my $borrowernumber = (@_) ? shift : 0; # the user, default to kohaadmin
542 $term =~ s/^\s+//;
543 $term =~ s/\s+$//;
544 ($term) or return; # must be more than whitespace
545 my $rows = get_tag_rows({biblionumber=>$biblionumber, borrowernumber=>$borrowernumber, term=>$term, limit=>1});
546 my $query = "INSERT INTO tags_all
547 (borrowernumber,biblionumber,term,date_created)
548 VALUES (?,?,?,NOW())";
549 $debug and print STDERR "add_tag query: $query\n",
550 "add_tag query args: ($borrowernumber,$biblionumber,$term)\n";
551 if (scalar @$rows) {
552 $debug and carp "Duplicate tag detected. Tag not added.";
553 return;
554 }
555 # add to tags_all regardless of approaval
556 my $sth = C4::Context->dbh->prepare($query);
557 $sth->execute($borrowernumber,$biblionumber,$term);
558
559 # then
560 if (scalar @_) { # if arg remains, it is the borrowernumber of the approver: tag is pre-approved.
561 my $approver = shift;
562 $debug and print STDERR "term '$term' pre-approved by borrower #$approver\n";
563 add_tag_approval($term,$approver,1);
564 add_tag_index($term,$biblionumber,$approver);
565 } elsif (is_approved($term) >= 1) {
566 $debug and print STDERR "term '$term' approved by whitelist\n";
567 add_tag_approval($term,0,1);
568 add_tag_index($term,$biblionumber,1);
569 } else {
570 $debug and print STDERR "term '$term' NOT approved (yet)\n";
571 add_tag_approval($term);
572 add_tag_index($term,$biblionumber);
573 }
574}
575
576# This takes a set of tags, as returned by C<get_approval_rows> and divides
577# them up into a number of "strata" based on their weight. This is useful
578# to display them in a number of different sizes.
579#
580# Usage:
581# ($min, $max) = stratify_tags($strata, $tags);
582# $stratum: the number of divisions you want
583# $tags: the tags, as provided by get_approval_rows
584# $min: the minumum stratum value
585# $max: the maximum stratum value. This may be the same as $min if there
586# is only one weight. Beware of divide by zeros.
587# This will add a field to the tag called "stratum" containing the calculated
588# value.
589sub stratify_tags {
590 my ( $strata, $tags ) = @_;
591
592 my ( $min, $max );
593 foreach (@$tags) {
594 my $w = $_->{weight_total};
595 $min = $w if ( !defined($min) || $min > $w );
596 $max = $w if ( !defined($max) || $max < $w );
597 }
598
599 # normalise min to zero
600 $max = $max - $min;
601 my $orig_min = $min;
602 $min = 0;
603
604 # if min and max are the same, just make it 1
605 my $span = ( $strata - 1 ) / ( $max || 1 );
606 foreach (@$tags) {
607 my $w = $_->{weight_total};
608 $_->{stratum} = int( ( $w - $orig_min ) * $span );
609 }
610 return ( $min, $max );
611}
612
61318µs1;
614__END__
 
# spent 853µs within C4::Tags::CORE:match which was called 700 times, avg 1µs/call: # 600 times (566µs+0s) by C4::Tags::get_tags at line 236, avg 943ns/call # 75 times (192µs+0s) by C4::Tags::get_tags at line 249, avg 3µs/call # 25 times (95µs+0s) by C4::Tags::get_tags at line 242, avg 4µs/call
sub C4::Tags::CORE:match; # opcode
# spent 1.35ms within C4::Tags::CORE:regcomp which was called 600 times, avg 2µs/call: # 600 times (1.35ms+0s) by C4::Tags::get_tags at line 236, avg 2µs/call
sub C4::Tags::CORE:regcomp; # opcode
# spent 172µs within C4::Tags::CORE:subst which was called 100 times, avg 2µs/call: # 100 times (172µs+0s) by C4::Tags::get_tags at line 269, avg 2µs/call
sub C4::Tags::CORE:subst; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.