← 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 11:58:52 2013
Reported on Tue Oct 15 12:01:06 2013

Filename/usr/share/koha/lib/C4/Letters.pm
StatementsExecuted 51 statements in 5.99ms

NOTE!

While profiling this file Perl noted the use of one or more special variables that impact the performance of all regular expressions in the program.

Use of the "$`", "$&", and "$'" variables should be replaced with faster alternatives. See the WARNING at the end of the Capture Buffers section of the perlre documentation.

The use is detected by perl at compile time but by NYTProf during execution. NYTProf first noted it when executing line 47. That was probably the first statement executed by the program after perl compiled the code containing the variables. If the variables can't be found by studying the source code, try using the Devel::FindAmpersand module.

Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11111.1ms13.8msC4::Letters::::BEGIN@23C4::Letters::BEGIN@23
1113.92ms9.16msC4::Letters::::BEGIN@24C4::Letters::BEGIN@24
1111.61ms9.43msC4::Letters::::BEGIN@27C4::Letters::BEGIN@27
1111.17ms7.32msC4::Letters::::BEGIN@32C4::Letters::BEGIN@32
111465µs574µsC4::Letters::::BEGIN@30C4::Letters::BEGIN@30
11122µs189µsC4::Letters::::BEGIN@28C4::Letters::BEGIN@28
11119µs72µsC4::Letters::::BEGIN@29C4::Letters::BEGIN@29
11119µs129µsC4::Letters::::BEGIN@34C4::Letters::BEGIN@34
11119µs23µsC4::Letters::::BEGIN@20C4::Letters::BEGIN@20
11119µs19µsC4::Letters::::BEGIN@39C4::Letters::BEGIN@39
11117µs205µsC4::Letters::::BEGIN@31C4::Letters::BEGIN@31
11117µs55µsC4::Letters::::BEGIN@33C4::Letters::BEGIN@33
11116µs16µsC4::Letters::::BEGIN@26C4::Letters::BEGIN@26
11115µs160µsC4::Letters::::BEGIN@37C4::Letters::BEGIN@37
11111µs24µsC4::Letters::::BEGIN@21C4::Letters::BEGIN@21
11111µs56µsC4::Letters::::BEGIN@35C4::Letters::BEGIN@35
0000s0sC4::Letters::::EnqueueLetterC4::Letters::EnqueueLetter
0000s0sC4::Letters::::GetLettersC4::Letters::GetLetters
0000s0sC4::Letters::::GetPreparedLetterC4::Letters::GetPreparedLetter
0000s0sC4::Letters::::GetPrintMessagesC4::Letters::GetPrintMessages
0000s0sC4::Letters::::GetQueuedMessagesC4::Letters::GetQueuedMessages
0000s0sC4::Letters::::GetRSSMessagesC4::Letters::GetRSSMessages
0000s0sC4::Letters::::SendAlertsC4::Letters::SendAlerts
0000s0sC4::Letters::::SendQueuedMessagesC4::Letters::SendQueuedMessages
0000s0sC4::Letters::::_add_attachmentsC4::Letters::_add_attachments
0000s0sC4::Letters::::_get_unsent_messagesC4::Letters::_get_unsent_messages
0000s0sC4::Letters::::_parseletterC4::Letters::_parseletter
0000s0sC4::Letters::::_parseletter_sthC4::Letters::_parseletter_sth
0000s0sC4::Letters::::_send_message_by_emailC4::Letters::_send_message_by_email
0000s0sC4::Letters::::_send_message_by_smsC4::Letters::_send_message_by_sms
0000s0sC4::Letters::::_set_message_statusC4::Letters::_set_message_status
0000s0sC4::Letters::::_substitute_tablesC4::Letters::_substitute_tables
0000s0sC4::Letters::::_update_message_to_addressC4::Letters::_update_message_to_address
0000s0sC4::Letters::::_wrap_htmlC4::Letters::_wrap_html
0000s0sC4::Letters::::addalertC4::Letters::addalert
0000s0sC4::Letters::::delalertC4::Letters::delalert
0000s0sC4::Letters::::findrelatedtoC4::Letters::findrelatedto
0000s0sC4::Letters::::getalertC4::Letters::getalert
0000s0sC4::Letters::::getletterC4::Letters::getletter
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package C4::Letters;
2
3# Copyright 2000-2002 Katipo Communications
4#
5# This file is part of Koha.
6#
7# Koha is free software; you can redistribute it and/or modify it under the
8# terms of the GNU General Public License as published by the Free Software
9# Foundation; either version 2 of the License, or (at your option) any later
10# version.
11#
12# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License along
17# with Koha; if not, write to the Free Software Foundation, Inc.,
18# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20328µs228µs
# spent 23µs (19+5) within C4::Letters::BEGIN@20 which was called: # once (19µs+5µs) by C4::Reserves::BEGIN@36 at line 20
use strict;
# spent 23µs making 1 call to C4::Letters::BEGIN@20 # spent 5µs making 1 call to strict::import
21328µs237µs
# spent 24µs (11+13) within C4::Letters::BEGIN@21 which was called: # once (11µs+13µs) by C4::Reserves::BEGIN@36 at line 21
use warnings;
# spent 24µs making 1 call to C4::Letters::BEGIN@21 # spent 13µs making 1 call to warnings::import
22
233143µs113.8ms
# spent 13.8ms (11.1+2.77) within C4::Letters::BEGIN@23 which was called: # once (11.1ms+2.77ms) by C4::Reserves::BEGIN@36 at line 23
use MIME::Lite;
# spent 13.8ms making 1 call to C4::Letters::BEGIN@23
243175µs29.34ms
# spent 9.16ms (3.92+5.24) within C4::Letters::BEGIN@24 which was called: # once (3.92ms+5.24ms) by C4::Reserves::BEGIN@36 at line 24
use Mail::Sendmail;
# spent 9.16ms making 1 call to C4::Letters::BEGIN@24 # spent 186µs making 1 call to Exporter::import
25
26341µs116µs
# spent 16µs within C4::Letters::BEGIN@26 which was called: # once (16µs+0s) by C4::Reserves::BEGIN@36 at line 26
use C4::Members;
# spent 16µs making 1 call to C4::Letters::BEGIN@26
273172µs29.58ms
# spent 9.43ms (1.61+7.83) within C4::Letters::BEGIN@27 which was called: # once (1.61ms+7.83ms) by C4::Reserves::BEGIN@36 at line 27
use C4::Members::Attributes qw(GetBorrowerAttributes);
# spent 9.43ms making 1 call to C4::Letters::BEGIN@27 # spent 150µs making 1 call to Exporter::import
28343µs2357µs
# spent 189µs (22+167) within C4::Letters::BEGIN@28 which was called: # once (22µs+167µs) by C4::Reserves::BEGIN@36 at line 28
use C4::Branch;
# spent 189µs making 1 call to C4::Letters::BEGIN@28 # spent 167µs making 1 call to Exporter::import
29338µs2125µs
# spent 72µs (19+53) within C4::Letters::BEGIN@29 which was called: # once (19µs+53µs) by C4::Reserves::BEGIN@36 at line 29
use C4::Log;
# spent 72µs making 1 call to C4::Letters::BEGIN@29 # spent 53µs making 1 call to Exporter::import
303142µs1574µs
# spent 574µs (465+109) within C4::Letters::BEGIN@30 which was called: # once (465µs+109µs) by C4::Reserves::BEGIN@36 at line 30
use C4::SMS;
# spent 574µs making 1 call to C4::Letters::BEGIN@30
31345µs2393µs
# spent 205µs (17+188) within C4::Letters::BEGIN@31 which was called: # once (17µs+188µs) by C4::Reserves::BEGIN@36 at line 31
use C4::Debug;
# spent 205µs making 1 call to C4::Letters::BEGIN@31 # spent 188µs making 1 call to Exporter::import
323162µs27.38ms
# spent 7.32ms (1.17+6.15) within C4::Letters::BEGIN@32 which was called: # once (1.17ms+6.15ms) by C4::Reserves::BEGIN@36 at line 32
use Koha::DateUtils;
# spent 7.32ms making 1 call to C4::Letters::BEGIN@32 # spent 65µs making 1 call to Exporter::import
33337µs293µs
# spent 55µs (17+38) within C4::Letters::BEGIN@33 which was called: # once (17µs+38µs) by C4::Reserves::BEGIN@36 at line 33
use Date::Calc qw( Add_Delta_Days );
# spent 55µs making 1 call to C4::Letters::BEGIN@33 # spent 38µs making 1 call to Exporter::import
34339µs2239µs
# spent 129µs (19+110) within C4::Letters::BEGIN@34 which was called: # once (19µs+110µs) by C4::Reserves::BEGIN@36 at line 34
use Encode;
# spent 129µs making 1 call to C4::Letters::BEGIN@34 # spent 110µs making 1 call to Exporter::import
35343µs2101µs
# spent 56µs (11+45) within C4::Letters::BEGIN@35 which was called: # once (11µs+45µs) by C4::Reserves::BEGIN@36 at line 35
use Carp;
# spent 56µs making 1 call to C4::Letters::BEGIN@35 # spent 45µs making 1 call to Exporter::import
36
37394µs2305µs
# spent 160µs (15+145) within C4::Letters::BEGIN@37 which was called: # once (15µs+145µs) by C4::Reserves::BEGIN@36 at line 37
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# spent 160µs making 1 call to C4::Letters::BEGIN@37 # spent 145µs making 1 call to vars::import
38
39
# spent 19µs within C4::Letters::BEGIN@39 which was called: # once (19µs+0s) by C4::Reserves::BEGIN@36 at line 47
BEGIN {
40419µs require Exporter;
41 # set the version for version checking
42 $VERSION = 3.07.00.049;
43 @ISA = qw(Exporter);
44 @EXPORT = qw(
45 &GetLetters &GetPreparedLetter &GetWrappedLetter &addalert &getalert &delalert &findrelatedto &SendAlerts &GetPrintMessages
46 );
4714.73ms119µs}
# spent 19µs making 1 call to C4::Letters::BEGIN@39
48
49=head1 NAME
50
- -
97sub GetLetters {
98
99 # returns a reference to a hash of references to ALL letters...
100 my $cat = shift;
101 my %letters;
102 my $dbh = C4::Context->dbh;
103 my $sth;
104 if (defined $cat) {
105 my $query = "SELECT * FROM letter WHERE module = ? ORDER BY name";
106 $sth = $dbh->prepare($query);
107 $sth->execute($cat);
108 }
109 else {
110 my $query = "SELECT * FROM letter ORDER BY name";
111 $sth = $dbh->prepare($query);
112 $sth->execute;
113 }
114 while ( my $letter = $sth->fetchrow_hashref ) {
115 $letters{ $letter->{'code'} } = $letter->{'name'};
116 }
117 return \%letters;
118}
119
120# FIXME: using our here means that a Plack server will need to be
121# restarted fairly regularly when working with this routine.
122# A better option would be to use Koha::Cache and use a cache
123# that actually works in a persistent environment, but as a
124# short-term fix, our will work.
1251700nsour %letter;
126sub getletter {
127 my ( $module, $code, $branchcode ) = @_;
128
129 $branchcode ||= '';
130
131 if ( C4::Context->preference('IndependantBranches')
132 and $branchcode
133 and C4::Context->userenv ) {
134
135 $branchcode = C4::Context->userenv->{'branch'};
136 }
137
138 if ( my $l = $letter{$module}{$code}{$branchcode} ) {
139 return { %$l }; # deep copy
140 }
141
142 my $dbh = C4::Context->dbh;
143 my $sth = $dbh->prepare("select * from letter where module=? and code=? and (branchcode = ? or branchcode = '') order by branchcode desc limit 1");
144 $sth->execute( $module, $code, $branchcode );
145 my $line = $sth->fetchrow_hashref
146 or return;
147 $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
148 $letter{$module}{$code}{$branchcode} = $line;
149 return { %$line };
150}
151
152=head2 addalert ($borrowernumber, $type, $externalid)
153
- -
163sub addalert {
164 my ( $borrowernumber, $type, $externalid ) = @_;
165 my $dbh = C4::Context->dbh;
166 my $sth =
167 $dbh->prepare(
168 "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
169 $sth->execute( $borrowernumber, $type, $externalid );
170
171 # get the alert number newly created and return it
172 my $alertid = $dbh->{'mysql_insertid'};
173 return $alertid;
174}
175
176=head2 delalert ($alertid)
177
- -
184sub delalert {
185 my $alertid = shift or die "delalert() called without valid argument (alertid)"; # it's gonna die anyway.
186 $debug and warn "delalert: deleting alertid $alertid";
187 my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
188 $sth->execute($alertid);
189}
190
191=head2 getalert ([$borrowernumber], [$type], [$externalid])
192
- -
201sub getalert {
202 my ( $borrowernumber, $type, $externalid ) = @_;
203 my $dbh = C4::Context->dbh;
204 my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE";
205 my @bind;
206 if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
207 $query .= " borrowernumber=? AND ";
208 push @bind, $borrowernumber;
209 }
210 if ($type) {
211 $query .= " type=? AND ";
212 push @bind, $type;
213 }
214 if ($externalid) {
215 $query .= " externalid=? AND ";
216 push @bind, $externalid;
217 }
218 $query =~ s/ AND $//;
219 my $sth = $dbh->prepare($query);
220 $sth->execute(@bind);
221 return $sth->fetchall_arrayref({});
222}
223
224=head2 findrelatedto($type, $externalid)
225
- -
235# outmoded POD:
236# When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
237
238sub findrelatedto {
239 my $type = shift or return;
240 my $externalid = shift or return;
241 my $q = ($type eq 'issue' ) ?
242"select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
243 ($type eq 'borrower') ?
244"select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
245 unless ($q) {
246 warn "findrelatedto(): Illegal type '$type'";
247 return;
248 }
249 my $sth = C4::Context->dbh->prepare($q);
250 $sth->execute($externalid);
251 my ($result) = $sth->fetchrow;
252 return $result;
253}
254
255=head2 SendAlerts
256
- -
266sub SendAlerts {
267 my ( $type, $externalid, $letter_code ) = @_;
268 my $dbh = C4::Context->dbh;
269 if ( $type eq 'issue' ) {
270
271 # prepare the letter...
272 # search the biblionumber
273 my $sth =
274 $dbh->prepare(
275 "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
276 $sth->execute($externalid);
277 my ($biblionumber) = $sth->fetchrow
278 or warn( "No subscription for '$externalid'" ),
279 return;
280
281 my %letter;
282 # find the list of borrowers to alert
283 my $alerts = getalert( '', 'issue', $externalid );
284 foreach (@$alerts) {
285
286 my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'});
287 my $email = $borinfo->{email} or next;
288
289 # warn "sending issues...";
290 my $userenv = C4::Context->userenv;
291 my $letter = GetPreparedLetter (
292 module => 'serial',
293 letter_code => $letter_code,
294 branchcode => $userenv->{branch},
295 tables => {
296 'branches' => $_->{branchcode},
297 'biblio' => $biblionumber,
298 'biblioitems' => $biblionumber,
299 'borrowers' => $borinfo,
300 },
301 want_librarian => 1,
302 ) or return;
303
304 # ... then send mail
305 my %mail = (
306 To => $email,
307 From => $email,
308 Subject => Encode::encode( "utf8", "" . $letter->{title} ),
309 Message => Encode::encode( "utf8", "" . $letter->{content} ),
310 'Content-Type' => 'text/plain; charset="utf8"',
311 );
312 sendmail(%mail) or carp $Mail::Sendmail::error;
313 }
314 }
315 elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' ) {
316
317 # prepare the letter...
318 # search the biblionumber
319 my $strsth = $type eq 'claimacquisition'
320 ? qq{
321 SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*,aqbooksellers.*,
322 aqbooksellers.id AS booksellerid
323 FROM aqorders
324 LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
325 LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
326 LEFT JOIN biblioitems ON aqorders.biblioitemnumber=biblioitems.biblioitemnumber
327 LEFT JOIN aqbooksellers ON aqbasket.booksellerid=aqbooksellers.id
328 WHERE aqorders.ordernumber IN (
329 }
330 : qq{
331 SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
332 aqbooksellers.id AS booksellerid
333 FROM serial
334 LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
335 LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
336 LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
337 WHERE serial.serialid IN (
338 };
339 $strsth .= join( ",", @$externalid ) . ")";
340 my $sthorders = $dbh->prepare($strsth);
341 $sthorders->execute;
342 my $dataorders = $sthorders->fetchall_arrayref( {} );
343
344 my $sthbookseller =
345 $dbh->prepare("select * from aqbooksellers where id=?");
346 $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
347 my $databookseller = $sthbookseller->fetchrow_hashref;
348
349 my @email;
350 push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
351 push @email, $databookseller->{contemail} if $databookseller->{contemail};
352 unless (@email) {
353 warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
354 return { error => "no_email" };
355 }
356
357 my $userenv = C4::Context->userenv;
358 my $letter = GetPreparedLetter (
359 module => $type,
360 letter_code => $letter_code,
361 branchcode => $userenv->{branch},
362 tables => {
363 'branches' => $userenv->{branch},
364 'aqbooksellers' => $databookseller,
365 },
366 repeat => $dataorders,
367 want_librarian => 1,
368 ) or return;
369
370 # ... then send mail
371 my %mail = (
372 To => join( ',', @email),
373 From => $userenv->{emailaddress},
374 Subject => Encode::encode( "utf8", "" . $letter->{title} ),
375 Message => Encode::encode( "utf8", "" . $letter->{content} ),
376 'Content-Type' => 'text/plain; charset="utf8"',
377 );
378 sendmail(%mail) or carp $Mail::Sendmail::error;
379
380 logaction(
381 "ACQUISITION",
382 $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
383 undef,
384 "To="
385 . $databookseller->{contemail}
386 . " Title="
387 . $letter->{title}
388 . " Content="
389 . $letter->{content}
390 ) if C4::Context->preference("LetterLog");
391 }
392 # send an "account details" notice to a newly created user
393 elsif ( $type eq 'members' ) {
394 my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
395 my $letter = GetPreparedLetter (
396 module => 'members',
397 letter_code => $letter_code,
398 branchcode => $externalid->{'branchcode'},
399 tables => {
400 'branches' => $branchdetails,
401 'borrowers' => $externalid->{'borrowernumber'},
402 },
403 substitute => { 'borrowers.password' => $externalid->{'password'} },
404 want_librarian => 1,
405 ) or return;
406
407 return { error => "no_email" } unless $externalid->{'emailaddr'};
408 my %mail = (
409 To => $externalid->{'emailaddr'},
410 From => $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
411 Subject => Encode::encode( "utf8", $letter->{'title'} ),
412 Message => Encode::encode( "utf8", $letter->{'content'} ),
413 'Content-Type' => 'text/plain; charset="utf8"',
414 );
415 sendmail(%mail) or carp $Mail::Sendmail::error;
416 }
417}
418
419=head2 GetPreparedLetter( %params )
420
- -
442sub GetPreparedLetter {
443 my %params = @_;
444
445 my $module = $params{module} or croak "No module";
446 my $letter_code = $params{letter_code} or croak "No letter_code";
447 my $branchcode = $params{branchcode} || '';
448
449 my $letter = getletter( $module, $letter_code, $branchcode )
450 or warn( "No $module $letter_code letter"),
451 return;
452
453 my $tables = $params{tables};
454 my $substitute = $params{substitute};
455 my $repeat = $params{repeat};
456 $tables || $substitute || $repeat
457 or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
458 return;
459 my $want_librarian = $params{want_librarian};
460
461 if ($substitute) {
462 while ( my ($token, $val) = each %$substitute ) {
463 $letter->{title} =~ s/<<$token>>/$val/g;
464 $letter->{content} =~ s/<<$token>>/$val/g;
465 }
466 }
467
468 my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
469 $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
470
471 if ($want_librarian) {
472 # parsing librarian name
473 my $userenv = C4::Context->userenv;
474 $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
475 $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
476 $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
477 }
478
479 my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
480
481 if ($repeat) {
482 if (ref ($repeat) eq 'ARRAY' ) {
483 $repeat_no_enclosing_tags = $repeat;
484 } else {
485 $repeat_enclosing_tags = $repeat;
486 }
487 }
488
489 if ($repeat_enclosing_tags) {
490 while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
491 if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
492 my $subcontent = $1;
493 my @lines = map {
494 my %subletter = ( title => '', content => $subcontent );
495 _substitute_tables( \%subletter, $_ );
496 $subletter{content};
497 } @$tag_tables;
498 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
499 }
500 }
501 }
502
503 if ($tables) {
504 _substitute_tables( $letter, $tables );
505 }
506
507 if ($repeat_no_enclosing_tags) {
508 if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
509 my $line = $&;
510 my $i = 1;
511 my @lines = map {
512 my $c = $line;
513 $c =~ s/<<count>>/$i/go;
514 foreach my $field ( keys %{$_} ) {
515 $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
516 }
517 $i++;
518 $c;
519 } @$repeat_no_enclosing_tags;
520
521 my $replaceby = join( "\n", @lines );
522 $letter->{content} =~ s/\Q$line\E/$replaceby/s;
523 }
524 }
525
526 $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
527# $letter->{content} =~ s/<<[^>]*>>//go;
528
529 return $letter;
530}
531
532sub _substitute_tables {
533 my ( $letter, $tables ) = @_;
534 while ( my ($table, $param) = each %$tables ) {
535 next unless $param;
536
537 my $ref = ref $param;
538
539 my $values;
540 if ($ref && $ref eq 'HASH') {
541 $values = $param;
542 }
543 else {
544 my @pk;
545 my $sth = _parseletter_sth($table);
546 unless ($sth) {
547 warn "_parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table.";
548 return;
549 }
550 $sth->execute( $ref ? @$param : $param );
551
552 $values = $sth->fetchrow_hashref;
553 }
554
555 _parseletter ( $letter, $table, $values );
556 }
557}
558
559sub _parseletter_sth {
560 my $table = shift;
561 my $sth;
562 unless ($table) {
563 carp "ERROR: _parseletter_sth() called without argument (table)";
564 return;
565 }
566 # NOTE: we used to check whether we had a statement handle cached in
567 # a %handles module-level variable. This was a dumb move and
568 # broke things for the rest of us. prepare_cached is a better
569 # way to cache statement handles anyway.
570 my $query =
571 ($table eq 'biblio' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
572 ($table eq 'biblioitems' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
573 ($table eq 'items' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
574 ($table eq 'issues' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
575 ($table eq 'old_issues' ) ? "SELECT * FROM $table WHERE itemnumber = ? ORDER BY timestamp DESC LIMIT 1" :
576 ($table eq 'reserves' ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
577 ($table eq 'borrowers' ) ? "SELECT * FROM $table WHERE borrowernumber = ?" :
578 ($table eq 'branches' ) ? "SELECT * FROM $table WHERE branchcode = ?" :
579 ($table eq 'suggestions' ) ? "SELECT * FROM $table WHERE suggestionid = ?" :
580 ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE id = ?" :
581 ($table eq 'aqorders' ) ? "SELECT * FROM $table WHERE ordernumber = ?" :
582 ($table eq 'opac_news' ) ? "SELECT * FROM $table WHERE idnew = ?" :
583 ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE borrowernumber = ? OR verification_token =?":
584 undef ;
585 unless ($query) {
586 warn "ERROR: No _parseletter_sth query for table '$table'";
587 return; # nothing to get
588 }
589 unless ($sth = C4::Context->dbh->prepare_cached($query)) {
590 warn "ERROR: Failed to prepare query: '$query'";
591 return;
592 }
593 return $sth; # now cache is populated for that $table
594}
595
596=head2 _parseletter($letter, $table, $values)
597
- -
607sub _parseletter {
608 my ( $letter, $table, $values ) = @_;
609
610 if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
611 my @waitingdate = split /-/, $values->{'waitingdate'};
612
613 my $dt = dt_from_string();
614 $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
615 $values->{'expirationdate'} = output_pref( $dt, undef, 1 );
616
617 $values->{'waitingdate'} = output_pref( dt_from_string( $values->{'waitingdate'} ), undef, 1 );
618
619 }
620
621 if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
622 my $todaysdate = output_pref( DateTime->now() );
623 $letter->{content} =~ s/<<today>>/$todaysdate/go;
624 }
625
626 while ( my ($field, $val) = each %$values ) {
627 my $replacetablefield = "<<$table.$field>>";
628 my $replacefield = "<<$field>>";
629 $val =~ s/\p{P}$// if $val && $table=~/biblio/;
630 #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
631 #Therefore adding the test on biblio. This includes biblioitems,
632 #but excludes items. Removed unneeded global and lookahead.
633
634 my $replacedby = defined ($val) ? $val : '';
635 ($letter->{title} ) and do {
636 $letter->{title} =~ s/$replacetablefield/$replacedby/g;
637 $letter->{title} =~ s/$replacefield/$replacedby/g;
638 };
639 ($letter->{content}) and do {
640 $letter->{content} =~ s/$replacetablefield/$replacedby/g;
641 $letter->{content} =~ s/$replacefield/$replacedby/g;
642 };
643 }
644
645 if ($table eq 'borrowers' && $letter->{content}) {
646 if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
647 my %attr;
648 foreach (@$attributes) {
649 my $code = $_->{code};
650 my $val = $_->{value_description} || $_->{value};
651 $val =~ s/\p{P}(?=$)//g if $val;
652 next unless $val gt '';
653 $attr{$code} ||= [];
654 push @{ $attr{$code} }, $val;
655 }
656 while ( my ($code, $val_ar) = each %attr ) {
657 my $replacefield = "<<borrower-attribute:$code>>";
658 my $replacedby = join ',', @$val_ar;
659 $letter->{content} =~ s/$replacefield/$replacedby/g;
660 }
661 }
662 }
663 return $letter;
664}
665
666=head2 EnqueueLetter
667
- -
679sub EnqueueLetter {
680 my $params = shift or return;
681
682 return unless exists $params->{'letter'};
683# return unless exists $params->{'borrowernumber'};
684 return unless exists $params->{'message_transport_type'};
685
686 my $content = $params->{letter}->{content};
687 $content =~ s/\s+//g if(defined $content);
688 if ( not defined $content or $content eq '' ) {
689 warn "Trying to add an empty message to the message queue" if $debug;
690 return;
691 }
692
693 # If we have any attachments we should encode then into the body.
694 if ( $params->{'attachments'} ) {
695 $params->{'letter'} = _add_attachments(
696 { letter => $params->{'letter'},
697 attachments => $params->{'attachments'},
698 message => MIME::Lite->new( Type => 'multipart/mixed' ),
699 }
700 );
701 }
702
703 my $dbh = C4::Context->dbh();
704 my $statement = << 'ENDSQL';
705INSERT INTO message_queue
706( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
707VALUES
708( ?, ?, ?, ?, ?, ?, ?, NOW(), ?, ?, ? )
709ENDSQL
710
711 my $sth = $dbh->prepare($statement);
712 my $result = $sth->execute(
713 $params->{'borrowernumber'}, # borrowernumber
714 $params->{'letter'}->{'title'}, # subject
715 $params->{'letter'}->{'content'}, # content
716 $params->{'letter'}->{'metadata'} || '', # metadata
717 $params->{'letter'}->{'code'} || '', # letter_code
718 $params->{'message_transport_type'}, # message_transport_type
719 'pending', # status
720 $params->{'to_address'}, # to_address
721 $params->{'from_address'}, # from_address
722 $params->{'letter'}->{'content-type'}, # content_type
723 );
724 return $dbh->last_insert_id(undef,undef,'message_queue', undef);
725}
726
727=head2 SendQueuedMessages ([$hashref])
728
- -
737sub SendQueuedMessages {
738 my $params = shift;
739
740 my $unsent_messages = _get_unsent_messages();
741 MESSAGE: foreach my $message ( @$unsent_messages ) {
742 # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
743 warn sprintf( 'sending %s message to patron: %s',
744 $message->{'message_transport_type'},
745 $message->{'borrowernumber'} || 'Admin' )
746 if $params->{'verbose'} or $debug;
747 # This is just begging for subclassing
748 next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
749 if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
750 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
751 }
752 elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
753 _send_message_by_sms( $message );
754 }
755 }
756 return scalar( @$unsent_messages );
757}
758
759=head2 GetRSSMessages
760
- -
767sub GetRSSMessages {
768 my $params = shift;
769
770 return unless $params;
771 return unless ref $params;
772 return unless $params->{'borrowernumber'};
773
774 return _get_unsent_messages( { message_transport_type => 'rss',
775 limit => $params->{'limit'},
776 borrowernumber => $params->{'borrowernumber'}, } );
777}
778
779=head2 GetPrintMessages
780
- -
788sub GetPrintMessages {
789 my $params = shift || {};
790
791 return _get_unsent_messages( { message_transport_type => 'print',
792 borrowernumber => $params->{'borrowernumber'},
793 } );
794}
795
796=head2 GetQueuedMessages ([$hashref])
797
- -
807sub GetQueuedMessages {
808 my $params = shift;
809
810 my $dbh = C4::Context->dbh();
811 my $statement = << 'ENDSQL';
812SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
813FROM message_queue
814ENDSQL
815
816 my @query_params;
817 my @whereclauses;
818 if ( exists $params->{'borrowernumber'} ) {
819 push @whereclauses, ' borrowernumber = ? ';
820 push @query_params, $params->{'borrowernumber'};
821 }
822
823 if ( @whereclauses ) {
824 $statement .= ' WHERE ' . join( 'AND', @whereclauses );
825 }
826
827 if ( defined $params->{'limit'} ) {
828 $statement .= ' LIMIT ? ';
829 push @query_params, $params->{'limit'};
830 }
831
832 my $sth = $dbh->prepare( $statement );
833 my $result = $sth->execute( @query_params );
834 return $sth->fetchall_arrayref({});
835}
836
837=head2 _add_attachements
838
- -
851sub _add_attachments {
852 my $params = shift;
853
854 my $letter = $params->{'letter'};
855 my $attachments = $params->{'attachments'};
856 return $letter unless @$attachments;
857 my $message = $params->{'message'};
858
859 # First, we have to put the body in as the first attachment
860 $message->attach(
861 Type => $letter->{'content-type'} || 'TEXT',
862 Data => $letter->{'is_html'}
863 ? _wrap_html($letter->{'content'}, $letter->{'title'})
864 : $letter->{'content'},
865 );
866
867 foreach my $attachment ( @$attachments ) {
868 $message->attach(
869 Type => $attachment->{'type'},
870 Data => $attachment->{'content'},
871 Filename => $attachment->{'filename'},
872 );
873 }
874 # we're forcing list context here to get the header, not the count back from grep.
875 ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
876 $letter->{'content-type'} =~ s/^Content-Type:\s+//;
877 $letter->{'content'} = $message->body_as_string;
878
879 return $letter;
880
881}
882
883sub _get_unsent_messages {
884 my $params = shift;
885
886 my $dbh = C4::Context->dbh();
887 my $statement = << 'ENDSQL';
888SELECT mq.message_id, mq.borrowernumber, mq.subject, mq.content, mq.message_transport_type, mq.status, mq.time_queued, mq.from_address, mq.to_address, mq.content_type, b.branchcode
889 FROM message_queue mq
890 LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
891 WHERE status = ?
892ENDSQL
893
894 my @query_params = ('pending');
895 if ( ref $params ) {
896 if ( $params->{'message_transport_type'} ) {
897 $statement .= ' AND message_transport_type = ? ';
898 push @query_params, $params->{'message_transport_type'};
899 }
900 if ( $params->{'borrowernumber'} ) {
901 $statement .= ' AND borrowernumber = ? ';
902 push @query_params, $params->{'borrowernumber'};
903 }
904 if ( $params->{'limit'} ) {
905 $statement .= ' limit ? ';
906 push @query_params, $params->{'limit'};
907 }
908 }
909
910 $debug and warn "_get_unsent_messages SQL: $statement";
911 $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
912 my $sth = $dbh->prepare( $statement );
913 my $result = $sth->execute( @query_params );
914 return $sth->fetchall_arrayref({});
915}
916
917sub _send_message_by_email {
918 my $message = shift or return;
919 my ($username, $password, $method) = @_;
920
921 my $to_address = $message->{to_address};
922 unless ($to_address) {
923 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
924 unless ($member) {
925 warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
926 _set_message_status( { message_id => $message->{'message_id'},
927 status => 'failed' } );
928 return;
929 }
930 $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
931 unless ($to_address) {
932 # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
933 # warning too verbose for this more common case?
934 _set_message_status( { message_id => $message->{'message_id'},
935 status => 'failed' } );
936 return;
937 }
938 }
939
940 my $utf8 = decode('MIME-Header', $message->{'subject'} );
941 $message->{subject}= encode('MIME-Header', $utf8);
942 my $subject = encode('utf8', $message->{'subject'});
943 my $content = encode('utf8', $message->{'content'});
944 my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
945 my $is_html = $content_type =~ m/html/io;
946 my %sendmail_params = (
947 To => $to_address,
948 From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'),
949 Subject => $subject,
950 charset => 'utf8',
951 Message => $is_html ? _wrap_html($content, $subject) : $content,
952 'content-type' => $content_type,
953 );
954 $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
955 if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
956 $sendmail_params{ Bcc } = $bcc;
957 }
958
959 _update_message_to_address($message->{'message_id'},$to_address) unless $message->{to_address}; #if initial message address was empty, coming here means that a to address was found and queue should be updated
960 if ( sendmail( %sendmail_params ) ) {
961 _set_message_status( { message_id => $message->{'message_id'},
962 status => 'sent' } );
963 return 1;
964 } else {
965 _set_message_status( { message_id => $message->{'message_id'},
966 status => 'failed' } );
967 carp $Mail::Sendmail::error;
968 return;
969 }
970}
971
972sub _wrap_html {
973 my ($content, $title) = @_;
974
975 my $css = C4::Context->preference("NoticeCSS") || '';
976 $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
977 return <<EOS;
978<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
979 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
980<html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
981<head>
982<title>$title</title>
983<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
984$css
985</head>
986<body>
987$content
988</body>
989</html>
990EOS
991}
992
993sub _send_message_by_sms {
994 my $message = shift or return;
995 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
996 return unless $member->{'smsalertnumber'};
997
998 my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
999 message => $message->{'content'},
1000 } );
1001 _set_message_status( { message_id => $message->{'message_id'},
1002 status => ($success ? 'sent' : 'failed') } );
1003 return $success;
1004}
1005
1006sub _update_message_to_address {
1007 my ($id, $to)= @_;
1008 my $dbh = C4::Context->dbh();
1009 $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1010}
1011
1012sub _set_message_status {
1013 my $params = shift or return;
1014
1015 foreach my $required_parameter ( qw( message_id status ) ) {
1016 return unless exists $params->{ $required_parameter };
1017 }
1018
1019 my $dbh = C4::Context->dbh();
1020 my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1021 my $sth = $dbh->prepare( $statement );
1022 my $result = $sth->execute( $params->{'status'},
1023 $params->{'message_id'} );
1024 return $result;
1025}
1026
1027
102816µs1;
1029__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.