← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

Filename/mnt/catalyst/koha/C4/Letters.pm
StatementsExecuted 38 statements in 10.5ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11114.8ms17.9msC4::Letters::::BEGIN@23C4::Letters::BEGIN@23
1113.37ms17.5msC4::Letters::::BEGIN@28C4::Letters::BEGIN@28
1113.33ms10.4msC4::Letters::::BEGIN@24C4::Letters::BEGIN@24
1112.28ms2.81msC4::Letters::::BEGIN@31C4::Letters::BEGIN@31
111420µs432µsC4::Letters::::BEGIN@20C4::Letters::BEGIN@20
11112µs40µsC4::Letters::::BEGIN@33C4::Letters::BEGIN@33
11111µs96µsC4::Letters::::BEGIN@32C4::Letters::BEGIN@32
11110µs123µsC4::Letters::::BEGIN@26C4::Letters::BEGIN@26
11110µs88µsC4::Letters::::BEGIN@29C4::Letters::BEGIN@29
11110µs10µsC4::Letters::::BEGIN@40C4::Letters::BEGIN@40
11110µs39µsC4::Letters::::BEGIN@30C4::Letters::BEGIN@30
1119µs27µsC4::Letters::::BEGIN@34C4::Letters::BEGIN@34
1119µs50µsC4::Letters::::BEGIN@35C4::Letters::BEGIN@35
1118µs58µsC4::Letters::::BEGIN@38C4::Letters::BEGIN@38
1118µs31µsC4::Letters::::BEGIN@36C4::Letters::BEGIN@36
1117µs12µsC4::Letters::::BEGIN@21C4::Letters::BEGIN@21
1115µs5µsC4::Letters::::BEGIN@27C4::Letters::BEGIN@27
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
20226µs2444µs
# spent 432µs (420+12) within C4::Letters::BEGIN@20 which was called: # once (420µs+12µs) by C4::Reserves::BEGIN@36 at line 20
use strict;
# spent 432µs making 1 call to C4::Letters::BEGIN@20 # spent 12µs making 1 call to strict::import
21225µs217µs
# spent 12µs (7+5) within C4::Letters::BEGIN@21 which was called: # once (7µs+5µs) by C4::Reserves::BEGIN@36 at line 21
use warnings;
# spent 12µs making 1 call to C4::Letters::BEGIN@21 # spent 5µs making 1 call to warnings::import
22
232819µs117.9ms
# spent 17.9ms (14.8+3.06) within C4::Letters::BEGIN@23 which was called: # once (14.8ms+3.06ms) by C4::Reserves::BEGIN@36 at line 23
use MIME::Lite;
# spent 17.9ms making 1 call to C4::Letters::BEGIN@23
242732µs210.5ms
# spent 10.4ms (3.33+7.08) within C4::Letters::BEGIN@24 which was called: # once (3.33ms+7.08ms) by C4::Reserves::BEGIN@36 at line 24
use Mail::Sendmail;
# spent 10.4ms making 1 call to C4::Letters::BEGIN@24 # spent 75µs making 1 call to Exporter::import
25
26225µs2236µs
# spent 123µs (10+113) within C4::Letters::BEGIN@26 which was called: # once (10µs+113µs) by C4::Reserves::BEGIN@36 at line 26
use C4::Koha qw(GetAuthorisedValueByCode);
# spent 123µs making 1 call to C4::Letters::BEGIN@26 # spent 113µs making 1 call to Exporter::import
27223µs15µs
# spent 5µs within C4::Letters::BEGIN@27 which was called: # once (5µs+0s) by C4::Reserves::BEGIN@36 at line 27
use C4::Members;
# spent 5µs making 1 call to C4::Letters::BEGIN@27
2822.78ms217.5ms
# spent 17.5ms (3.37+14.1) within C4::Letters::BEGIN@28 which was called: # once (3.37ms+14.1ms) by C4::Reserves::BEGIN@36 at line 28
use C4::Members::Attributes qw(GetBorrowerAttributes);
# spent 17.5ms making 1 call to C4::Letters::BEGIN@28 # spent 48µs making 1 call to Exporter::import
29226µs2165µs
# spent 88µs (10+77) within C4::Letters::BEGIN@29 which was called: # once (10µs+77µs) by C4::Reserves::BEGIN@36 at line 29
use C4::Branch;
# spent 88µs making 1 call to C4::Letters::BEGIN@29 # spent 77µs making 1 call to Exporter::import
30223µs269µs
# spent 39µs (10+29) within C4::Letters::BEGIN@30 which was called: # once (10µs+29µs) by C4::Reserves::BEGIN@36 at line 30
use C4::Log;
# spent 39µs making 1 call to C4::Letters::BEGIN@30 # spent 29µs making 1 call to Exporter::import
3122.43ms12.81ms
# spent 2.81ms (2.28+523µs) within C4::Letters::BEGIN@31 which was called: # once (2.28ms+523µs) by C4::Reserves::BEGIN@36 at line 31
use C4::SMS;
# spent 2.81ms making 1 call to C4::Letters::BEGIN@31
32228µs2180µs
# spent 96µs (11+85) within C4::Letters::BEGIN@32 which was called: # once (11µs+85µs) by C4::Reserves::BEGIN@36 at line 32
use C4::Debug;
# spent 96µs making 1 call to C4::Letters::BEGIN@32 # spent 85µs making 1 call to Exporter::import
33226µs268µs
# spent 40µs (12+28) within C4::Letters::BEGIN@33 which was called: # once (12µs+28µs) by C4::Reserves::BEGIN@36 at line 33
use Koha::DateUtils;
# spent 40µs making 1 call to C4::Letters::BEGIN@33 # spent 28µs making 1 call to Exporter::import
34222µs244µs
# spent 27µs (9+17) within C4::Letters::BEGIN@34 which was called: # once (9µs+17µs) by C4::Reserves::BEGIN@36 at line 34
use Date::Calc qw( Add_Delta_Days );
# spent 27µs making 1 call to C4::Letters::BEGIN@34 # spent 17µs making 1 call to Exporter::import
35221µs291µs
# spent 50µs (9+41) within C4::Letters::BEGIN@35 which was called: # once (9µs+41µs) by C4::Reserves::BEGIN@36 at line 35
use Encode;
# spent 50µs making 1 call to C4::Letters::BEGIN@35 # spent 41µs making 1 call to Exporter::import
36225µs255µs
# spent 31µs (8+23) within C4::Letters::BEGIN@36 which was called: # once (8µs+23µs) by C4::Reserves::BEGIN@36 at line 36
use Carp;
# spent 31µs making 1 call to C4::Letters::BEGIN@36 # spent 24µs making 1 call to Exporter::import
37
38275µs2109µs
# spent 58µs (8+51) within C4::Letters::BEGIN@38 which was called: # once (8µs+51µs) by C4::Reserves::BEGIN@36 at line 38
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# spent 58µs making 1 call to C4::Letters::BEGIN@38 # spent 51µs making 1 call to vars::import
39
40
# spent 10µs within C4::Letters::BEGIN@40 which was called: # once (10µs+0s) by C4::Reserves::BEGIN@36 at line 48
BEGIN {
411600ns require Exporter;
42 # set the version for version checking
431900ns $VERSION = 3.07.00.049;
4415µs @ISA = qw(Exporter);
4515µs @EXPORT = qw(
46 &GetLetters &GetPreparedLetter &GetWrappedLetter &addalert &getalert &delalert &findrelatedto &SendAlerts &GetPrintMessages
47 );
4811.80ms110µs}
# spent 10µs making 1 call to C4::Letters::BEGIN@40
49
50=head1 NAME
51
52C4::Letters - Give functions for Letters management
53
54=head1 SYNOPSIS
55
56 use C4::Letters;
57
58=head1 DESCRIPTION
59
60 "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
61 late issues, as well as other tasks like sending a mail to users that have subscribed to a "serial issue alert" (= being warned every time a new issue has arrived at the library)
62
63 Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
64
65=head2 GetLetters([$category])
66
67 $letters = &GetLetters($category);
68 returns informations about letters.
69 if needed, $category filters for letters given category
70 Create a letter selector with the following code
71
72=head3 in PERL SCRIPT
73
74my $letters = GetLetters($cat);
75my @letterloop;
76foreach my $thisletter (keys %$letters) {
77 my $selected = 1 if $thisletter eq $letter;
78 my %row =(
79 value => $thisletter,
80 selected => $selected,
81 lettername => $letters->{$thisletter},
82 );
83 push @letterloop, \%row;
84}
85$template->param(LETTERLOOP => \@letterloop);
86
87=head3 in TEMPLATE
88
89 <select name="letter">
90 <option value="">Default</option>
91 <!-- TMPL_LOOP name="LETTERLOOP" -->
92 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="lettername" --></option>
93 <!-- /TMPL_LOOP -->
94 </select>
95
96=cut
97
98sub GetLetters {
99
100 # returns a reference to a hash of references to ALL letters...
101 my $cat = shift;
102 my %letters;
103 my $dbh = C4::Context->dbh;
104 my $sth;
105 if (defined $cat) {
106 my $query = "SELECT * FROM letter WHERE module = ? ORDER BY name";
107 $sth = $dbh->prepare($query);
108 $sth->execute($cat);
109 }
110 else {
111 my $query = "SELECT * FROM letter ORDER BY name";
112 $sth = $dbh->prepare($query);
113 $sth->execute;
114 }
115 while ( my $letter = $sth->fetchrow_hashref ) {
116 $letters{ $letter->{'code'} } = $letter->{'name'};
117 }
118 return \%letters;
119}
120
121# FIXME: using our here means that a Plack server will need to be
122# restarted fairly regularly when working with this routine.
123# A better option would be to use Koha::Cache and use a cache
124# that actually works in a persistent environment, but as a
125# short-term fix, our will work.
1261300nsour %letter;
127sub getletter {
128 my ( $module, $code, $branchcode ) = @_;
129
130
131 if ( C4::Context->preference('IndependentBranches')
132 and $branchcode
133 and C4::Context->userenv ) {
134
135 $branchcode = C4::Context->userenv->{'branch'};
136 }
137 $branchcode //= '';
138
139 if ( my $l = $letter{$module}{$code}{$branchcode} ) {
140 return { %$l }; # deep copy
141 }
142
143 my $dbh = C4::Context->dbh;
144 my $sth = $dbh->prepare("select * from letter where module=? and code=? and (branchcode = ? or branchcode = '') order by branchcode desc limit 1");
145 $sth->execute( $module, $code, $branchcode );
146 my $line = $sth->fetchrow_hashref
147 or return;
148 $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
149 $letter{$module}{$code}{$branchcode} = $line;
150 return { %$line };
151}
152
153=head2 addalert ($borrowernumber, $type, $externalid)
154
155 parameters :
156 - $borrowernumber : the number of the borrower subscribing to the alert
157 - $type : the type of alert.
158 - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
159
160 create an alert and return the alertid (primary key)
161
162=cut
163
164sub addalert {
165 my ( $borrowernumber, $type, $externalid ) = @_;
166 my $dbh = C4::Context->dbh;
167 my $sth =
168 $dbh->prepare(
169 "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
170 $sth->execute( $borrowernumber, $type, $externalid );
171
172 # get the alert number newly created and return it
173 my $alertid = $dbh->{'mysql_insertid'};
174 return $alertid;
175}
176
177=head2 delalert ($alertid)
178
179 parameters :
180 - alertid : the alert id
181 deletes the alert
182
183=cut
184
185sub delalert {
186 my $alertid = shift or die "delalert() called without valid argument (alertid)"; # it's gonna die anyway.
187 $debug and warn "delalert: deleting alertid $alertid";
188 my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
189 $sth->execute($alertid);
190}
191
192=head2 getalert ([$borrowernumber], [$type], [$externalid])
193
194 parameters :
195 - $borrowernumber : the number of the borrower subscribing to the alert
196 - $type : the type of alert.
197 - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
198 all parameters NON mandatory. If a parameter is omitted, the query is done without the corresponding parameter. For example, without $externalid, returns all alerts for a borrower on a topic.
199
200=cut
201
202sub getalert {
203 my ( $borrowernumber, $type, $externalid ) = @_;
204 my $dbh = C4::Context->dbh;
205 my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE";
206 my @bind;
207 if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
208 $query .= " borrowernumber=? AND ";
209 push @bind, $borrowernumber;
210 }
211 if ($type) {
212 $query .= " type=? AND ";
213 push @bind, $type;
214 }
215 if ($externalid) {
216 $query .= " externalid=? AND ";
217 push @bind, $externalid;
218 }
219 $query =~ s/ AND $//;
220 my $sth = $dbh->prepare($query);
221 $sth->execute(@bind);
222 return $sth->fetchall_arrayref({});
223}
224
225=head2 findrelatedto($type, $externalid)
226
227 parameters :
228 - $type : the type of alert
229 - $externalid : the id of the "object" to query
230
231 In the table alert, a "id" is stored in the externalid field. This "id" is related to another table, depending on the type of the alert.
232 When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
233
234=cut
235
236# outmoded POD:
237# When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
238
239sub findrelatedto {
240 my $type = shift or return;
241 my $externalid = shift or return;
242 my $q = ($type eq 'issue' ) ?
243"select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
244 ($type eq 'borrower') ?
245"select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
246 unless ($q) {
247 warn "findrelatedto(): Illegal type '$type'";
248 return;
249 }
250 my $sth = C4::Context->dbh->prepare($q);
251 $sth->execute($externalid);
252 my ($result) = $sth->fetchrow;
253 return $result;
254}
255
256=head2 SendAlerts
257
258 parameters :
259 - $type : the type of alert
260 - $externalid : the id of the "object" to query
261 - $letter_code : the letter to send.
262
263 send an alert to all borrowers having put an alert on a given subject.
264
265=cut
266
267sub SendAlerts {
268 my ( $type, $externalid, $letter_code ) = @_;
269 my $dbh = C4::Context->dbh;
270 if ( $type eq 'issue' ) {
271
272 # prepare the letter...
273 # search the biblionumber
274 my $sth =
275 $dbh->prepare(
276 "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
277 $sth->execute($externalid);
278 my ($biblionumber) = $sth->fetchrow
279 or warn( "No subscription for '$externalid'" ),
280 return;
281
282 my %letter;
283 # find the list of borrowers to alert
284 my $alerts = getalert( '', 'issue', $externalid );
285 foreach (@$alerts) {
286
287 my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'});
288 my $email = $borinfo->{email} or next;
289
290 # warn "sending issues...";
291 my $userenv = C4::Context->userenv;
292 my $branchdetails = GetBranchDetail($_->{'branchcode'});
293 my $letter = GetPreparedLetter (
294 module => 'serial',
295 letter_code => $letter_code,
296 branchcode => $userenv->{branch},
297 tables => {
298 'branches' => $_->{branchcode},
299 'biblio' => $biblionumber,
300 'biblioitems' => $biblionumber,
301 'borrowers' => $borinfo,
302 },
303 want_librarian => 1,
304 ) or return;
305
306 # ... then send mail
307 my %mail = (
308 To => $email,
309 From => $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
310 Subject => Encode::encode( "utf8", "" . $letter->{title} ),
311 Message => Encode::encode( "utf8", "" . $letter->{content} ),
312 'Content-Type' => 'text/plain; charset="utf8"',
313 );
314 sendmail(%mail) or carp $Mail::Sendmail::error;
315 }
316 }
317 elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' ) {
318
319 # prepare the letter...
320 # search the biblionumber
321 my $strsth = $type eq 'claimacquisition'
322 ? qq{
323 SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*,aqbooksellers.*,
324 aqbooksellers.id AS booksellerid
325 FROM aqorders
326 LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
327 LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
328 LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
329 LEFT JOIN aqbooksellers ON aqbasket.booksellerid=aqbooksellers.id
330 WHERE aqorders.ordernumber IN (
331 }
332 : qq{
333 SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
334 aqbooksellers.id AS booksellerid
335 FROM serial
336 LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
337 LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
338 LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
339 WHERE serial.serialid IN (
340 };
341 $strsth .= join( ",", @$externalid ) . ")";
342 my $sthorders = $dbh->prepare($strsth);
343 $sthorders->execute;
344 my $dataorders = $sthorders->fetchall_arrayref( {} );
345
346 my $sthbookseller =
347 $dbh->prepare("select * from aqbooksellers where id=?");
348 $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
349 my $databookseller = $sthbookseller->fetchrow_hashref;
350
351 my @email;
352 push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
353 push @email, $databookseller->{contemail} if $databookseller->{contemail};
354 unless (@email) {
355 warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
356 return { error => "no_email" };
357 }
358
359 my $userenv = C4::Context->userenv;
360 my $letter = GetPreparedLetter (
361 module => $type,
362 letter_code => $letter_code,
363 branchcode => $userenv->{branch},
364 tables => {
365 'branches' => $userenv->{branch},
366 'aqbooksellers' => $databookseller,
367 },
368 repeat => $dataorders,
369 want_librarian => 1,
370 ) or return;
371
372 # ... then send mail
373 my %mail = (
374 To => join( ',', @email),
375 From => $userenv->{emailaddress},
376 Subject => Encode::encode( "utf8", "" . $letter->{title} ),
377 Message => Encode::encode( "utf8", "" . $letter->{content} ),
378 'Content-Type' => 'text/plain; charset="utf8"',
379 );
380 sendmail(%mail) or carp $Mail::Sendmail::error;
381
382 logaction(
383 "ACQUISITION",
384 $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
385 undef,
386 "To="
387 . $databookseller->{contemail}
388 . " Title="
389 . $letter->{title}
390 . " Content="
391 . $letter->{content}
392 ) if C4::Context->preference("LetterLog");
393 }
394 # send an "account details" notice to a newly created user
395 elsif ( $type eq 'members' ) {
396 my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
397 my $letter = GetPreparedLetter (
398 module => 'members',
399 letter_code => $letter_code,
400 branchcode => $externalid->{'branchcode'},
401 tables => {
402 'branches' => $branchdetails,
403 'borrowers' => $externalid->{'borrowernumber'},
404 },
405 substitute => { 'borrowers.password' => $externalid->{'password'} },
406 want_librarian => 1,
407 ) or return;
408
409 return { error => "no_email" } unless $externalid->{'emailaddr'};
410 my %mail = (
411 To => $externalid->{'emailaddr'},
412 From => $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
413 Subject => Encode::encode( "utf8", $letter->{'title'} ),
414 Message => Encode::encode( "utf8", $letter->{'content'} ),
415 'Content-Type' => 'text/plain; charset="utf8"',
416 );
417 sendmail(%mail) or carp $Mail::Sendmail::error;
418 }
419}
420
421=head2 GetPreparedLetter( %params )
422
423 %params hash:
424 module => letter module, mandatory
425 letter_code => letter code, mandatory
426 branchcode => for letter selection, if missing default system letter taken
427 tables => a hashref with table names as keys. Values are either:
428 - a scalar - primary key value
429 - an arrayref - primary key values
430 - a hashref - full record
431 substitute => custom substitution key/value pairs
432 repeat => records to be substituted on consecutive lines:
433 - an arrayref - tries to guess what needs substituting by
434 taking remaining << >> tokensr; not recommended
435 - a hashref token => @tables - replaces <token> << >> << >> </token>
436 subtemplate for each @tables row; table is a hashref as above
437 want_librarian => boolean, if set to true triggers librarian details
438 substitution from the userenv
439 Return value:
440 letter fields hashref (title & content useful)
441
442=cut
443
444sub GetPreparedLetter {
445 my %params = @_;
446
447 my $module = $params{module} or croak "No module";
448 my $letter_code = $params{letter_code} or croak "No letter_code";
449 my $branchcode = $params{branchcode} || '';
450
451 my $letter = getletter( $module, $letter_code, $branchcode )
452 or warn( "No $module $letter_code letter"),
453 return;
454
455 my $tables = $params{tables};
456 my $substitute = $params{substitute};
457 my $repeat = $params{repeat};
458 $tables || $substitute || $repeat
459 or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
460 return;
461 my $want_librarian = $params{want_librarian};
462
463 if ($substitute) {
464 while ( my ($token, $val) = each %$substitute ) {
465 $letter->{title} =~ s/<<$token>>/$val/g;
466 $letter->{content} =~ s/<<$token>>/$val/g;
467 }
468 }
469
470 my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
471 $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
472
473 if ($want_librarian) {
474 # parsing librarian name
475 my $userenv = C4::Context->userenv;
476 $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
477 $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
478 $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
479 }
480
481 my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
482
483 if ($repeat) {
484 if (ref ($repeat) eq 'ARRAY' ) {
485 $repeat_no_enclosing_tags = $repeat;
486 } else {
487 $repeat_enclosing_tags = $repeat;
488 }
489 }
490
491 if ($repeat_enclosing_tags) {
492 while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
493 if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
494 my $subcontent = $1;
495 my @lines = map {
496 my %subletter = ( title => '', content => $subcontent );
497 _substitute_tables( \%subletter, $_ );
498 $subletter{content};
499 } @$tag_tables;
500 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
501 }
502 }
503 }
504
505 if ($tables) {
506 _substitute_tables( $letter, $tables );
507 }
508
509 if ($repeat_no_enclosing_tags) {
510 if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
511 my $line = $&;
512 my $i = 1;
513 my @lines = map {
514 my $c = $line;
515 $c =~ s/<<count>>/$i/go;
516 foreach my $field ( keys %{$_} ) {
517 $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
518 }
519 $i++;
520 $c;
521 } @$repeat_no_enclosing_tags;
522
523 my $replaceby = join( "\n", @lines );
524 $letter->{content} =~ s/\Q$line\E/$replaceby/s;
525 }
526 }
527
528 $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
529# $letter->{content} =~ s/<<[^>]*>>//go;
530
531 return $letter;
532}
533
534sub _substitute_tables {
535 my ( $letter, $tables ) = @_;
536 while ( my ($table, $param) = each %$tables ) {
537 next unless $param;
538
539 my $ref = ref $param;
540
541 my $values;
542 if ($ref && $ref eq 'HASH') {
543 $values = $param;
544 }
545 else {
546 my @pk;
547 my $sth = _parseletter_sth($table);
548 unless ($sth) {
549 warn "_parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table.";
550 return;
551 }
552 $sth->execute( $ref ? @$param : $param );
553
554 $values = $sth->fetchrow_hashref;
555 $sth->finish();
556 }
557
558 _parseletter ( $letter, $table, $values );
559 }
560}
561
562sub _parseletter_sth {
563 my $table = shift;
564 my $sth;
565 unless ($table) {
566 carp "ERROR: _parseletter_sth() called without argument (table)";
567 return;
568 }
569 # NOTE: we used to check whether we had a statement handle cached in
570 # a %handles module-level variable. This was a dumb move and
571 # broke things for the rest of us. prepare_cached is a better
572 # way to cache statement handles anyway.
573 my $query =
574 ($table eq 'biblio' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
575 ($table eq 'biblioitems' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
576 ($table eq 'items' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
577 ($table eq 'issues' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
578 ($table eq 'old_issues' ) ? "SELECT * FROM $table WHERE itemnumber = ? ORDER BY timestamp DESC LIMIT 1" :
579 ($table eq 'reserves' ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
580 ($table eq 'borrowers' ) ? "SELECT * FROM $table WHERE borrowernumber = ?" :
581 ($table eq 'branches' ) ? "SELECT * FROM $table WHERE branchcode = ?" :
582 ($table eq 'suggestions' ) ? "SELECT * FROM $table WHERE suggestionid = ?" :
583 ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE id = ?" :
584 ($table eq 'aqorders' ) ? "SELECT * FROM $table WHERE ordernumber = ?" :
585 ($table eq 'opac_news' ) ? "SELECT * FROM $table WHERE idnew = ?" :
586 ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE borrowernumber = ? OR verification_token =?":
587 undef ;
588 unless ($query) {
589 warn "ERROR: No _parseletter_sth query for table '$table'";
590 return; # nothing to get
591 }
592 unless ($sth = C4::Context->dbh->prepare_cached($query)) {
593 warn "ERROR: Failed to prepare query: '$query'";
594 return;
595 }
596 return $sth; # now cache is populated for that $table
597}
598
599=head2 _parseletter($letter, $table, $values)
600
601 parameters :
602 - $letter : a hash to letter fields (title & content useful)
603 - $table : the Koha table to parse.
604 - $values : table record hashref
605 parse all fields from a table, and replace values in title & content with the appropriate value
606 (not exported sub, used only internally)
607
608=cut
609
610sub _parseletter {
611 my ( $letter, $table, $values ) = @_;
612
613 if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
614 my @waitingdate = split /-/, $values->{'waitingdate'};
615
616 $values->{'expirationdate'} = '';
617 if( C4::Context->preference('ExpireReservesMaxPickUpDelay') &&
618 C4::Context->preference('ReservesMaxPickUpDelay') ) {
619 my $dt = dt_from_string();
620 $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
621 $values->{'expirationdate'} = output_pref({ dt => $dt, dateonly => 1 });
622 }
623
624 $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
625
626 }
627
628 if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
629 my $todaysdate = output_pref( DateTime->now() );
630 $letter->{content} =~ s/<<today>>/$todaysdate/go;
631 }
632
633 while ( my ($field, $val) = each %$values ) {
634 my $replacetablefield = "<<$table.$field>>";
635 my $replacefield = "<<$field>>";
6361164µs1855µs $val =~ s/\p{P}$// if $val && $table=~/biblio/;
# spent 855µs making 1 call to utf8::SWASHNEW
637 #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
638 #Therefore adding the test on biblio. This includes biblioitems,
639 #but excludes items. Removed unneeded global and lookahead.
640
641 $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
642 my $replacedby = defined ($val) ? $val : '';
643 ($letter->{title} ) and do {
644 $letter->{title} =~ s/$replacetablefield/$replacedby/g;
645 $letter->{title} =~ s/$replacefield/$replacedby/g;
646 };
647 ($letter->{content}) and do {
648 $letter->{content} =~ s/$replacetablefield/$replacedby/g;
649 $letter->{content} =~ s/$replacefield/$replacedby/g;
650 };
651 }
652
653 if ($table eq 'borrowers' && $letter->{content}) {
654 if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
655 my %attr;
656 foreach (@$attributes) {
657 my $code = $_->{code};
658 my $val = $_->{value_description} || $_->{value};
65911.38ms143µs $val =~ s/\p{P}(?=$)//g if $val;
# spent 43µs making 1 call to utf8::SWASHNEW
660 next unless $val gt '';
661 $attr{$code} ||= [];
662 push @{ $attr{$code} }, $val;
663 }
664 while ( my ($code, $val_ar) = each %attr ) {
665 my $replacefield = "<<borrower-attribute:$code>>";
666 my $replacedby = join ',', @$val_ar;
667 $letter->{content} =~ s/$replacefield/$replacedby/g;
668 }
669 }
670 }
671 return $letter;
672}
673
674=head2 EnqueueLetter
675
676 my $success = EnqueueLetter( { letter => $letter,
677 borrowernumber => '12', message_transport_type => 'email' } )
678
679places a letter in the message_queue database table, which will
680eventually get processed (sent) by the process_message_queue.pl
681cronjob when it calls SendQueuedMessages.
682
683return message_id on success
684
685=cut
686
687sub EnqueueLetter {
688 my $params = shift or return;
689
690 return unless exists $params->{'letter'};
691# return unless exists $params->{'borrowernumber'};
692 return unless exists $params->{'message_transport_type'};
693
694 my $content = $params->{letter}->{content};
695 $content =~ s/\s+//g if(defined $content);
696 if ( not defined $content or $content eq '' ) {
697 warn "Trying to add an empty message to the message queue" if $debug;
698 return;
699 }
700
701 # If we have any attachments we should encode then into the body.
702 if ( $params->{'attachments'} ) {
703 $params->{'letter'} = _add_attachments(
704 { letter => $params->{'letter'},
705 attachments => $params->{'attachments'},
706 message => MIME::Lite->new( Type => 'multipart/mixed' ),
707 }
708 );
709 }
710
711 my $dbh = C4::Context->dbh();
712 my $statement = << 'ENDSQL';
713INSERT INTO message_queue
714( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
715VALUES
716( ?, ?, ?, ?, ?, ?, ?, NOW(), ?, ?, ? )
717ENDSQL
718
719 my $sth = $dbh->prepare($statement);
720 my $result = $sth->execute(
721 $params->{'borrowernumber'}, # borrowernumber
722 $params->{'letter'}->{'title'}, # subject
723 $params->{'letter'}->{'content'}, # content
724 $params->{'letter'}->{'metadata'} || '', # metadata
725 $params->{'letter'}->{'code'} || '', # letter_code
726 $params->{'message_transport_type'}, # message_transport_type
727 'pending', # status
728 $params->{'to_address'}, # to_address
729 $params->{'from_address'}, # from_address
730 $params->{'letter'}->{'content-type'}, # content_type
731 );
732 return $dbh->last_insert_id(undef,undef,'message_queue', undef);
733}
734
735=head2 SendQueuedMessages ([$hashref])
736
737 my $sent = SendQueuedMessages( { verbose => 1 } );
738
739sends all of the 'pending' items in the message queue.
740
741returns number of messages sent.
742
743=cut
744
745sub SendQueuedMessages {
746 my $params = shift;
747
748 my $unsent_messages = _get_unsent_messages();
749 MESSAGE: foreach my $message ( @$unsent_messages ) {
750 # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
751 warn sprintf( 'sending %s message to patron: %s',
752 $message->{'message_transport_type'},
753 $message->{'borrowernumber'} || 'Admin' )
754 if $params->{'verbose'} or $debug;
755 # This is just begging for subclassing
756 next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
757 if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
758 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
759 }
760 elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
761 _send_message_by_sms( $message );
762 }
763 }
764 return scalar( @$unsent_messages );
765}
766
767=head2 GetRSSMessages
768
769 my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
770
771returns a listref of all queued RSS messages for a particular person.
772
773=cut
774
775sub GetRSSMessages {
776 my $params = shift;
777
778 return unless $params;
779 return unless ref $params;
780 return unless $params->{'borrowernumber'};
781
782 return _get_unsent_messages( { message_transport_type => 'rss',
783 limit => $params->{'limit'},
784 borrowernumber => $params->{'borrowernumber'}, } );
785}
786
787=head2 GetPrintMessages
788
789 my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
790
791Returns a arrayref of all queued print messages (optionally, for a particular
792person).
793
794=cut
795
796sub GetPrintMessages {
797 my $params = shift || {};
798
799 return _get_unsent_messages( { message_transport_type => 'print',
800 borrowernumber => $params->{'borrowernumber'},
801 } );
802}
803
804=head2 GetQueuedMessages ([$hashref])
805
806 my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
807
808fetches messages out of the message queue.
809
810returns:
811list of hashes, each has represents a message in the message queue.
812
813=cut
814
815sub GetQueuedMessages {
816 my $params = shift;
817
818 my $dbh = C4::Context->dbh();
819 my $statement = << 'ENDSQL';
820SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
821FROM message_queue
822ENDSQL
823
824 my @query_params;
825 my @whereclauses;
826 if ( exists $params->{'borrowernumber'} ) {
827 push @whereclauses, ' borrowernumber = ? ';
828 push @query_params, $params->{'borrowernumber'};
829 }
830
831 if ( @whereclauses ) {
832 $statement .= ' WHERE ' . join( 'AND', @whereclauses );
833 }
834
835 if ( defined $params->{'limit'} ) {
836 $statement .= ' LIMIT ? ';
837 push @query_params, $params->{'limit'};
838 }
839
840 my $sth = $dbh->prepare( $statement );
841 my $result = $sth->execute( @query_params );
842 return $sth->fetchall_arrayref({});
843}
844
845=head2 _add_attachements
846
847named parameters:
848letter - the standard letter hashref
849attachments - listref of attachments. each attachment is a hashref of:
850 type - the mime type, like 'text/plain'
851 content - the actual attachment
852 filename - the name of the attachment.
853message - a MIME::Lite object to attach these to.
854
855returns your letter object, with the content updated.
856
857=cut
858
859sub _add_attachments {
860 my $params = shift;
861
862 my $letter = $params->{'letter'};
863 my $attachments = $params->{'attachments'};
864 return $letter unless @$attachments;
865 my $message = $params->{'message'};
866
867 # First, we have to put the body in as the first attachment
868 $message->attach(
869 Type => $letter->{'content-type'} || 'TEXT',
870 Data => $letter->{'is_html'}
871 ? _wrap_html($letter->{'content'}, $letter->{'title'})
872 : $letter->{'content'},
873 );
874
875 foreach my $attachment ( @$attachments ) {
876 $message->attach(
877 Type => $attachment->{'type'},
878 Data => $attachment->{'content'},
879 Filename => $attachment->{'filename'},
880 );
881 }
882 # we're forcing list context here to get the header, not the count back from grep.
883 ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
884 $letter->{'content-type'} =~ s/^Content-Type:\s+//;
885 $letter->{'content'} = $message->body_as_string;
886
887 return $letter;
888
889}
890
891sub _get_unsent_messages {
892 my $params = shift;
893
894 my $dbh = C4::Context->dbh();
895 my $statement = << 'ENDSQL';
896SELECT 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
897 FROM message_queue mq
898 LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
899 WHERE status = ?
900ENDSQL
901
902 my @query_params = ('pending');
903 if ( ref $params ) {
904 if ( $params->{'message_transport_type'} ) {
905 $statement .= ' AND message_transport_type = ? ';
906 push @query_params, $params->{'message_transport_type'};
907 }
908 if ( $params->{'borrowernumber'} ) {
909 $statement .= ' AND borrowernumber = ? ';
910 push @query_params, $params->{'borrowernumber'};
911 }
912 if ( $params->{'limit'} ) {
913 $statement .= ' limit ? ';
914 push @query_params, $params->{'limit'};
915 }
916 }
917
918 $debug and warn "_get_unsent_messages SQL: $statement";
919 $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
920 my $sth = $dbh->prepare( $statement );
921 my $result = $sth->execute( @query_params );
922 return $sth->fetchall_arrayref({});
923}
924
925sub _send_message_by_email {
926 my $message = shift or return;
927 my ($username, $password, $method) = @_;
928
929 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
930 my $to_address = $message->{'to_address'};
931 unless ($to_address) {
932 unless ($member) {
933 warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
934 _set_message_status( { message_id => $message->{'message_id'},
935 status => 'failed' } );
936 return;
937 }
938 $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
939 unless ($to_address) {
940 # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
941 # warning too verbose for this more common case?
942 _set_message_status( { message_id => $message->{'message_id'},
943 status => 'failed' } );
944 return;
945 }
946 }
947
948 my $utf8 = decode('MIME-Header', $message->{'subject'} );
949 $message->{subject}= encode('MIME-Header', $utf8);
950 my $subject = encode('utf8', $message->{'subject'});
951 my $content = encode('utf8', $message->{'content'});
952 my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
953 my $is_html = $content_type =~ m/html/io;
954
955 my $branch_email = ( $member ) ? GetBranchDetail( $member->{'branchcode'} )->{'branchemail'} : undef;
956
957 my %sendmail_params = (
958 To => $to_address,
959 From => $message->{'from_address'} || $branch_email || C4::Context->preference('KohaAdminEmailAddress'),
960 Subject => $subject,
961 charset => 'utf8',
962 Message => $is_html ? _wrap_html($content, $subject) : $content,
963 'content-type' => $content_type,
964 );
965 $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
966 if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
967 $sendmail_params{ Bcc } = $bcc;
968 }
969
970 _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
971 if ( sendmail( %sendmail_params ) ) {
972 _set_message_status( { message_id => $message->{'message_id'},
973 status => 'sent' } );
974 return 1;
975 } else {
976 _set_message_status( { message_id => $message->{'message_id'},
977 status => 'failed' } );
978 carp $Mail::Sendmail::error;
979 return;
980 }
981}
982
983sub _wrap_html {
984 my ($content, $title) = @_;
985
986 my $css = C4::Context->preference("NoticeCSS") || '';
987 $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
988 return <<EOS;
989<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
990 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
991<html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
992<head>
993<title>$title</title>
994<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
995$css
996</head>
997<body>
998$content
999</body>
1000</html>
1001EOS
1002}
1003
1004sub _send_message_by_sms {
1005 my $message = shift or return;
1006 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1007 return unless $member->{'smsalertnumber'};
1008
1009 my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1010 message => $message->{'content'},
1011 } );
1012 _set_message_status( { message_id => $message->{'message_id'},
1013 status => ($success ? 'sent' : 'failed') } );
1014 return $success;
1015}
1016
1017sub _update_message_to_address {
1018 my ($id, $to)= @_;
1019 my $dbh = C4::Context->dbh();
1020 $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1021}
1022
1023sub _set_message_status {
1024 my $params = shift or return;
1025
1026 foreach my $required_parameter ( qw( message_id status ) ) {
1027 return unless exists $params->{ $required_parameter };
1028 }
1029
1030 my $dbh = C4::Context->dbh();
1031 my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1032 my $sth = $dbh->prepare( $statement );
1033 my $result = $sth->execute( $params->{'status'},
1034 $params->{'message_id'} );
1035 return $result;
1036}
1037
1038
103913µs1;
1040__END__
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.