File: | C4/Letters.pm |
Coverage: | 9.7% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package 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 | ||||||
20 | 13 13 13 | 19235 46 380 | use strict; | |||
21 | 13 13 13 | 99 89 1263 | use warnings; | |||
22 | ||||||
23 | 13 13 13 | 59878 404137 648 | use MIME::Lite; | |||
24 | 13 13 13 | 4915 328671 1717 | use Mail::Sendmail; | |||
25 | ||||||
26 | 13 13 13 | 836 153 4103 | use C4::Members; | |||
27 | 13 13 13 | 2186 115 3560 | use C4::Branch; | |||
28 | 13 13 13 | 141 95 1565 | use C4::Log; | |||
29 | 13 13 13 | 2630 47 454 | use C4::SMS; | |||
30 | 13 13 13 | 112 41 1286 | use C4::Debug; | |||
31 | 13 13 13 | 81 34 741 | use Date::Calc qw( Add_Delta_Days ); | |||
32 | 13 13 13 | 71 28 1306 | use Encode; | |||
33 | 13 13 13 | 91 29 958 | use Carp; | |||
34 | ||||||
35 | 13 13 13 | 80 44 1568 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); | |||
36 | ||||||
37 | BEGIN { | |||||
38 | 13 | 76 | require Exporter; | |||
39 | # set the version for version checking | |||||
40 | 13 | 63 | $VERSION = 3.01; | |||
41 | 13 | 1041 | @ISA = qw(Exporter); | |||
42 | 13 | 78833 | @EXPORT = qw( | |||
43 | &GetLetters &getletter &addalert &getalert &delalert &findrelatedto &SendAlerts GetPrintMessages | |||||
44 | ); | |||||
45 | } | |||||
46 | ||||||
47 - 93 | =head1 NAME C4::Letters - Give functions for Letters management =head1 SYNOPSIS use C4::Letters; =head1 DESCRIPTION "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like 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) Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too. =head2 GetLetters([$category]) $letters = &GetLetters($category); returns informations about letters. if needed, $category filters for letters given category Create a letter selector with the following code =head3 in PERL SCRIPT my $letters = GetLetters($cat); my @letterloop; foreach my $thisletter (keys %$letters) { my $selected = 1 if $thisletter eq $letter; my %row =( value => $thisletter, selected => $selected, lettername => $letters->{$thisletter}, ); push @letterloop, \%row; } $template->param(LETTERLOOP => \@letterloop); =head3 in TEMPLATE <select name="letter"> <option value="">Default</option> <!-- TMPL_LOOP name="LETTERLOOP" --> <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="lettername" --></option> <!-- /TMPL_LOOP --> </select> =cut | |||||
94 | ||||||
95 | sub GetLetters (;$) { | |||||
96 | ||||||
97 | # returns a reference to a hash of references to ALL letters... | |||||
98 | 0 | my $cat = shift; | ||||
99 | 0 | my %letters; | ||||
100 | 0 | my $dbh = C4::Context->dbh; | ||||
101 | 0 | my $sth; | ||||
102 | 0 | if (defined $cat) { | ||||
103 | 0 | my $query = "SELECT * FROM letter WHERE module = ? ORDER BY name"; | ||||
104 | 0 | $sth = $dbh->prepare($query); | ||||
105 | 0 | $sth->execute($cat); | ||||
106 | } | |||||
107 | else { | |||||
108 | 0 | my $query = "SELECT * FROM letter ORDER BY name"; | ||||
109 | 0 | $sth = $dbh->prepare($query); | ||||
110 | 0 | $sth->execute; | ||||
111 | } | |||||
112 | 0 | while ( my $letter = $sth->fetchrow_hashref ) { | ||||
113 | 0 | $letters{ $letter->{'code'} } = $letter->{'name'}; | ||||
114 | } | |||||
115 | 0 | return \%letters; | ||||
116 | } | |||||
117 | ||||||
118 | sub getletter ($$) { | |||||
119 | 0 | my ( $module, $code ) = @_; | ||||
120 | 0 | my $dbh = C4::Context->dbh; | ||||
121 | 0 | my $sth = $dbh->prepare("select * from letter where module=? and code=?"); | ||||
122 | 0 | $sth->execute( $module, $code ); | ||||
123 | 0 | my $line = $sth->fetchrow_hashref; | ||||
124 | 0 | return $line; | ||||
125 | } | |||||
126 | ||||||
127 - 136 | =head2 addalert ($borrowernumber, $type, $externalid) parameters : - $borrowernumber : the number of the borrower subscribing to the alert - $type : the type of alert. - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid. create an alert and return the alertid (primary key) =cut | |||||
137 | ||||||
138 | sub addalert ($$$) { | |||||
139 | 0 | my ( $borrowernumber, $type, $externalid ) = @_; | ||||
140 | 0 | my $dbh = C4::Context->dbh; | ||||
141 | 0 | my $sth = | ||||
142 | $dbh->prepare( | |||||
143 | "insert into alert (borrowernumber, type, externalid) values (?,?,?)"); | |||||
144 | 0 | $sth->execute( $borrowernumber, $type, $externalid ); | ||||
145 | ||||||
146 | # get the alert number newly created and return it | |||||
147 | 0 | my $alertid = $dbh->{'mysql_insertid'}; | ||||
148 | 0 | return $alertid; | ||||
149 | } | |||||
150 | ||||||
151 - 157 | =head2 delalert ($alertid) parameters : - alertid : the alert id deletes the alert =cut | |||||
158 | ||||||
159 | sub delalert ($) { | |||||
160 | 0 | my $alertid = shift or die "delalert() called without valid argument (alertid)"; # it's gonna die anyway. | ||||
161 | 0 | $debug and warn "delalert: deleting alertid $alertid"; | ||||
162 | 0 | my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?"); | ||||
163 | 0 | $sth->execute($alertid); | ||||
164 | } | |||||
165 | ||||||
166 - 174 | =head2 getalert ([$borrowernumber], [$type], [$externalid]) parameters : - $borrowernumber : the number of the borrower subscribing to the alert - $type : the type of alert. - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid. 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. =cut | |||||
175 | ||||||
176 | sub getalert (;$$$) { | |||||
177 | 0 | my ( $borrowernumber, $type, $externalid ) = @_; | ||||
178 | 0 | my $dbh = C4::Context->dbh; | ||||
179 | 0 | my $query = "SELECT * FROM alert WHERE"; | ||||
180 | 0 | my @bind; | ||||
181 | 0 | if ($borrowernumber and $borrowernumber =~ /^\d+$/) { | ||||
182 | 0 | $query .= " borrowernumber=? AND "; | ||||
183 | 0 | push @bind, $borrowernumber; | ||||
184 | } | |||||
185 | 0 | if ($type) { | ||||
186 | 0 | $query .= " type=? AND "; | ||||
187 | 0 | push @bind, $type; | ||||
188 | } | |||||
189 | 0 | if ($externalid) { | ||||
190 | 0 | $query .= " externalid=? AND "; | ||||
191 | 0 | push @bind, $externalid; | ||||
192 | } | |||||
193 | 0 | $query =~ s/ AND $//; | ||||
194 | 0 | my $sth = $dbh->prepare($query); | ||||
195 | 0 | $sth->execute(@bind); | ||||
196 | 0 | return $sth->fetchall_arrayref({}); | ||||
197 | } | |||||
198 | ||||||
199 - 208 | =head2 findrelatedto($type, $externalid) parameters : - $type : the type of alert - $externalid : the id of the "object" to query 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. When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio. =cut | |||||
209 | ||||||
210 | # outmoded POD: | |||||
211 | # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub | |||||
212 | ||||||
213 | sub findrelatedto ($$) { | |||||
214 | 0 | my $type = shift or return undef; | ||||
215 | 0 | my $externalid = shift or return undef; | ||||
216 | 0 | my $q = ($type eq 'issue' ) ? | ||||
217 | "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" : | |||||
218 | ($type eq 'borrower') ? | |||||
219 | "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef; | |||||
220 | 0 | unless ($q) { | ||||
221 | 0 | warn "findrelatedto(): Illegal type '$type'"; | ||||
222 | 0 | return undef; | ||||
223 | } | |||||
224 | 0 | my $sth = C4::Context->dbh->prepare($q); | ||||
225 | 0 | $sth->execute($externalid); | ||||
226 | 0 | my ($result) = $sth->fetchrow; | ||||
227 | 0 | return $result; | ||||
228 | } | |||||
229 | ||||||
230 - 239 | =head2 SendAlerts parameters : - $type : the type of alert - $externalid : the id of the "object" to query - $letter : the letter to send. send an alert to all borrowers having put an alert on a given subject. =cut | |||||
240 | ||||||
241 | sub SendAlerts { | |||||
242 | 0 | my ( $type, $externalid, $letter ) = @_; | ||||
243 | 0 | my $dbh = C4::Context->dbh; | ||||
244 | 0 | my $strsth; | ||||
245 | 0 | if ( $type eq 'issue' ) { | ||||
246 | ||||||
247 | # warn "sending issues..."; | |||||
248 | 0 | my $letter = getletter( 'serial', $letter ); | ||||
249 | ||||||
250 | # prepare the letter... | |||||
251 | # search the biblionumber | |||||
252 | 0 | my $sth = | ||||
253 | $dbh->prepare( | |||||
254 | "SELECT biblionumber FROM subscription WHERE subscriptionid=?"); | |||||
255 | 0 | $sth->execute($externalid); | ||||
256 | 0 | my ($biblionumber) = $sth->fetchrow; | ||||
257 | ||||||
258 | # parsing branch info | |||||
259 | 0 | my $userenv = C4::Context->userenv; | ||||
260 | 0 | parseletter( $letter, 'branches', $userenv->{branch} ); | ||||
261 | ||||||
262 | # parsing librarian name | |||||
263 | 0 | $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g; | ||||
264 | 0 | $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g; | ||||
265 | 0 | $letter->{content} =~ | ||||
266 | s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g; | |||||
267 | ||||||
268 | # parsing biblio information | |||||
269 | 0 | parseletter( $letter, 'biblio', $biblionumber ); | ||||
270 | 0 | parseletter( $letter, 'biblioitems', $biblionumber ); | ||||
271 | ||||||
272 | # find the list of borrowers to alert | |||||
273 | 0 | my $alerts = getalert( '', 'issue', $externalid ); | ||||
274 | 0 | foreach (@$alerts) { | ||||
275 | ||||||
276 | # and parse borrower ... | |||||
277 | 0 | my $innerletter = $letter; | ||||
278 | 0 | my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'}); | ||||
279 | 0 | parseletter( $innerletter, 'borrowers', $_->{'borrowernumber'} ); | ||||
280 | ||||||
281 | # ... then send mail | |||||
282 | 0 | if ( $borinfo->{email} ) { | ||||
283 | 0 | my %mail = ( | ||||
284 | To => $borinfo->{email}, | |||||
285 | From => $borinfo->{email}, | |||||
286 | Subject => "" . $innerletter->{title}, | |||||
287 | Message => "" . $innerletter->{content}, | |||||
288 | 'Content-Type' => 'text/plain; charset="utf8"', | |||||
289 | ); | |||||
290 | 0 | sendmail(%mail) or carp $Mail::Sendmail::error; | ||||
291 | ||||||
292 | } | |||||
293 | } | |||||
294 | } | |||||
295 | elsif ( $type eq 'claimacquisition' ) { | |||||
296 | ||||||
297 | 0 | $letter = getletter( 'claimacquisition', $letter ); | ||||
298 | ||||||
299 | # prepare the letter... | |||||
300 | # search the biblionumber | |||||
301 | 0 | $strsth = qq{ | ||||
302 | SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*,aqbooksellers.* | |||||
303 | FROM aqorders | |||||
304 | LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno | |||||
305 | LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber | |||||
306 | LEFT JOIN biblioitems ON aqorders.biblioitemnumber=biblioitems.biblioitemnumber | |||||
307 | LEFT JOIN aqbooksellers ON aqbasket.booksellerid=aqbooksellers.id | |||||
308 | WHERE aqorders.ordernumber IN ( | |||||
309 | } | |||||
310 | . join( ",", @$externalid ) . ")"; | |||||
311 | } | |||||
312 | elsif ( $type eq 'claimissues' ) { | |||||
313 | ||||||
314 | 0 | $letter = getletter( 'claimissues', $letter ); | ||||
315 | ||||||
316 | # prepare the letter... | |||||
317 | # search the biblionumber | |||||
318 | 0 | $strsth = qq{ | ||||
319 | SELECT serial.*,subscription.*, biblio.*, aqbooksellers.* | |||||
320 | FROM serial | |||||
321 | LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid | |||||
322 | LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber | |||||
323 | LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id | |||||
324 | WHERE serial.serialid IN ( | |||||
325 | } | |||||
326 | . join( ",", @$externalid ) . ")"; | |||||
327 | } | |||||
328 | ||||||
329 | 0 | if ( $type eq 'claimacquisition' or $type eq 'claimissues' ) { | ||||
330 | 0 | my $sthorders = $dbh->prepare($strsth); | ||||
331 | 0 | $sthorders->execute; | ||||
332 | 0 | my @fields = map { | ||||
333 | 0 | $sthorders->{mysql_table}[$_] . "." . $sthorders->{NAME}[$_] } | ||||
334 | 0 | (0 .. $#{$sthorders->{NAME}} ) ; | ||||
335 | ||||||
336 | 0 | my @orders_infos; | ||||
337 | 0 | while ( my $row = $sthorders->fetchrow_arrayref() ) { | ||||
338 | 0 | my %rec = (); | ||||
339 | 0 | @rec{@fields} = @$row; | ||||
340 | 0 | push @orders_infos, \%rec; | ||||
341 | } | |||||
342 | ||||||
343 | # parsing branch info | |||||
344 | 0 | my $userenv = C4::Context->userenv; | ||||
345 | 0 | parseletter( $letter, 'branches', $userenv->{branch} ); | ||||
346 | ||||||
347 | # parsing librarian name | |||||
348 | 0 | $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g; | ||||
349 | 0 | $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g; | ||||
350 | 0 | $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g; | ||||
351 | ||||||
352 | # Get Fields remplacement | |||||
353 | 0 | my $order_format = $1 if ( $letter->{content} =~ m/(<order>.*<\/order>)/xms ); | ||||
354 | ||||||
355 | # Foreach field to remplace | |||||
356 | 0 | while ( $letter->{content} =~ m/<<([^>]*)>>/g ) { | ||||
357 | 0 | my $field = $1; | ||||
358 | 0 | my $value = $orders_infos[0]->{$field} || ""; | ||||
359 | 0 | $value = sprintf("%.2f", $value) if $field =~ /price/; | ||||
360 | 0 | $letter->{content} =~ s/<<$field>>/$value/g; | ||||
361 | } | |||||
362 | ||||||
363 | 0 | if ( $order_format ) { | ||||
364 | # For each order | |||||
365 | 0 | foreach my $infos ( @orders_infos ) { | ||||
366 | 0 | my $order_content = $order_format; | ||||
367 | # We replace by value | |||||
368 | 0 | while ( $order_content =~ m/<<([^>]*)>>/g ) { | ||||
369 | 0 | my $field = $1; | ||||
370 | 0 | my $value = $infos->{$field} || ""; | ||||
371 | 0 | $value = sprintf("%.2f", $value) if $field =~ /price/; | ||||
372 | 0 | $order_content =~ s/(<<$field>>)/$value/g; | ||||
373 | } | |||||
374 | 0 | $order_content =~ s/<\/{0,1}?order>//g; | ||||
375 | 0 | $letter->{content} =~ s/<order>.*<\/order>/$order_content\n$order_format/xms; | ||||
376 | } | |||||
377 | 0 | $letter->{content} =~ s/<order>.*<\/order>//xms; | ||||
378 | } | |||||
379 | ||||||
380 | 0 | my $innerletter = $letter; | ||||
381 | ||||||
382 | # ... then send mail | |||||
383 | 0 | if ( $orders_infos[0]->{'aqbooksellers.bookselleremail'} | ||||
384 | || $orders_infos[0]->{'aqbooksellers.contemail'} ) { | |||||
385 | 0 | my $to = $orders_infos[0]->{'aqbooksellers.bookselleremail'}; | ||||
386 | 0 | $to .= ", " if $to; | ||||
387 | 0 | $to .= $orders_infos[0]->{'aqbooksellers.contemail'} || ""; | ||||
388 | 0 | my %mail = ( | ||||
389 | To => $to, | |||||
390 | From => $userenv->{emailaddress}, | |||||
391 | Subject => Encode::encode( "utf8", "" . $innerletter->{title} ), | |||||
392 | Message => Encode::encode( "utf8", "" . $innerletter->{content} ), | |||||
393 | 'Content-Type' => 'text/plain; charset="utf8"', | |||||
394 | ); | |||||
395 | 0 | sendmail(%mail) or carp $Mail::Sendmail::error; | ||||
396 | 0 | warn "sending to $mail{To} From $mail{From} subj $mail{Subject} Mess $mail{Message}" if $debug; | ||||
397 | 0 | if ( C4::Context->preference("LetterLog") ) { | ||||
398 | 0 | logaction( "ACQUISITION", "Send Acquisition claim letter", "", "order list : " . join( ",", @$externalid ) . "\n$innerletter->{title}\n$innerletter->{content}" ) if $type eq 'claimacquisition'; | ||||
399 | 0 | logaction( "ACQUISITION", "CLAIM ISSUE", undef, "To=" . $mail{To} . " Title=" . $innerletter->{title} . " Content=" . $innerletter->{content} ) if $type eq 'claimissues'; | ||||
400 | } | |||||
401 | } else { | |||||
402 | 0 | return {error => "no_email" }; | ||||
403 | } | |||||
404 | ||||||
405 | 0 | warn "sending to From $userenv->{emailaddress} subj $innerletter->{title} Mess $innerletter->{content}" if $debug; | ||||
406 | } | |||||
407 | ||||||
408 | # send an "account details" notice to a newly created user | |||||
409 | elsif ( $type eq 'members' ) { | |||||
410 | # must parse the password special, before it's hashed. | |||||
411 | 0 | $letter->{content} =~ s/<<borrowers.password>>/$externalid->{'password'}/g; | ||||
412 | ||||||
413 | 0 | parseletter( $letter, 'borrowers', $externalid->{'borrowernumber'}); | ||||
414 | 0 | parseletter( $letter, 'branches', $externalid->{'branchcode'} ); | ||||
415 | ||||||
416 | 0 | my $branchdetails = GetBranchDetail($externalid->{'branchcode'}); | ||||
417 | 0 | my %mail = ( | ||||
418 | To => $externalid->{'emailaddr'}, | |||||
419 | From => $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"), | |||||
420 | Subject => $letter->{'title'}, | |||||
421 | Message => $letter->{'content'}, | |||||
422 | 'Content-Type' => 'text/plain; charset="utf8"', | |||||
423 | ); | |||||
424 | 0 | sendmail(%mail) or carp $Mail::Sendmail::error; | ||||
425 | } | |||||
426 | } | |||||
427 | ||||||
428 - 437 | =head2 parseletter($letter, $table, $pk) parameters : - $letter : a hash to letter fields (title & content useful) - $table : the Koha table to parse. - $pk : the primary key to query on the $table table parse all fields from a table, and replace values in title & content with the appropriate value (not exported sub, used only internally) =cut | |||||
438 | ||||||
439 | our %handles = (); | |||||
440 | our %columns = (); | |||||
441 | ||||||
442 | sub parseletter_sth { | |||||
443 | 0 | my $table = shift; | ||||
444 | 0 | unless ($table) { | ||||
445 | 0 | carp "ERROR: parseletter_sth() called without argument (table)"; | ||||
446 | 0 | return; | ||||
447 | } | |||||
448 | # check cache first | |||||
449 | 0 | (defined $handles{$table}) and return $handles{$table}; | ||||
450 | 0 | my $query = | ||||
451 | ($table eq 'biblio' ) ? "SELECT * FROM $table WHERE biblionumber = ?" : | |||||
452 | ($table eq 'biblioitems' ) ? "SELECT * FROM $table WHERE biblionumber = ?" : | |||||
453 | ($table eq 'items' ) ? "SELECT * FROM $table WHERE itemnumber = ?" : | |||||
454 | ($table eq 'issues' ) ? "SELECT * FROM $table WHERE itemnumber = ?" : | |||||
455 | ($table eq 'reserves' ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" : | |||||
456 | ($table eq 'borrowers' ) ? "SELECT * FROM $table WHERE borrowernumber = ?" : | |||||
457 | ($table eq 'branches' ) ? "SELECT * FROM $table WHERE branchcode = ?" : | |||||
458 | ($table eq 'suggestions' ) ? "SELECT * FROM $table WHERE suggestionid = ?" : | |||||
459 | ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE id = ?" : undef ; | |||||
460 | 0 | unless ($query) { | ||||
461 | 0 | warn "ERROR: No parseletter_sth query for table '$table'"; | ||||
462 | 0 | return; # nothing to get | ||||
463 | } | |||||
464 | 0 | unless ($handles{$table} = C4::Context->dbh->prepare($query)) { | ||||
465 | 0 | warn "ERROR: Failed to prepare query: '$query'"; | ||||
466 | 0 | return; | ||||
467 | } | |||||
468 | 0 | return $handles{$table}; # now cache is populated for that $table | ||||
469 | } | |||||
470 | ||||||
471 | sub parseletter { | |||||
472 | 0 | my ( $letter, $table, $pk, $pk2 ) = @_; | ||||
473 | 0 | unless ($letter) { | ||||
474 | 0 | carp "ERROR: parseletter() 1st argument 'letter' empty"; | ||||
475 | 0 | return; | ||||
476 | } | |||||
477 | 0 | my $sth = parseletter_sth($table); | ||||
478 | 0 | unless ($sth) { | ||||
479 | 0 | warn "parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table."; | ||||
480 | 0 | return; | ||||
481 | } | |||||
482 | 0 | if ( $pk2 ) { | ||||
483 | 0 | $sth->execute($pk, $pk2); | ||||
484 | } else { | |||||
485 | 0 | $sth->execute($pk); | ||||
486 | } | |||||
487 | ||||||
488 | 0 | my $values = $sth->fetchrow_hashref; | ||||
489 | ||||||
490 | # TEMPORARY hack until the expirationdate column is added to reserves | |||||
491 | 0 | if ( $table eq 'reserves' && $values->{'waitingdate'} ) { | ||||
492 | 0 | my @waitingdate = split /-/, $values->{'waitingdate'}; | ||||
493 | ||||||
494 | 0 | $values->{'expirationdate'} = C4::Dates->new( | ||||
495 | sprintf( | |||||
496 | '%04d-%02d-%02d', | |||||
497 | Add_Delta_Days( @waitingdate, C4::Context->preference( 'ReservesMaxPickUpDelay' ) ) | |||||
498 | ), | |||||
499 | 'iso' | |||||
500 | )->output(); | |||||
501 | } | |||||
502 | ||||||
503 | ||||||
504 | # and get all fields from the table | |||||
505 | 0 | my $columns = C4::Context->dbh->prepare("SHOW COLUMNS FROM $table"); | ||||
506 | 0 | $columns->execute; | ||||
507 | 0 | while ( ( my $field ) = $columns->fetchrow_array ) { | ||||
508 | 0 | my $replacefield = "<<$table.$field>>"; | ||||
509 | 0 | $values->{$field} =~ s/\p{P}(?=$)//g if $values->{$field}; | ||||
510 | 0 | my $replacedby = $values->{$field} || ''; | ||||
511 | 0 | ($letter->{title} ) and $letter->{title} =~ s/$replacefield/$replacedby/g; | ||||
512 | 0 | ($letter->{content}) and $letter->{content} =~ s/$replacefield/$replacedby/g; | ||||
513 | } | |||||
514 | 0 | return $letter; | ||||
515 | } | |||||
516 | ||||||
517 - 528 | =head2 EnqueueLetter my $success = EnqueueLetter( { letter => $letter, borrowernumber => '12', message_transport_type => 'email' } ) places a letter in the message_queue database table, which will eventually get processed (sent) by the process_message_queue.pl cronjob when it calls SendQueuedMessages. return true on success =cut | |||||
529 | ||||||
530 | sub EnqueueLetter ($) { | |||||
531 | 0 | my $params = shift or return undef; | ||||
532 | ||||||
533 | 0 | return unless exists $params->{'letter'}; | ||||
534 | 0 | return unless exists $params->{'borrowernumber'}; | ||||
535 | 0 | return unless exists $params->{'message_transport_type'}; | ||||
536 | ||||||
537 | # If we have any attachments we should encode then into the body. | |||||
538 | 0 | if ( $params->{'attachments'} ) { | ||||
539 | 0 | $params->{'letter'} = _add_attachments( | ||||
540 | { letter => $params->{'letter'}, | |||||
541 | attachments => $params->{'attachments'}, | |||||
542 | message => MIME::Lite->new( Type => 'multipart/mixed' ), | |||||
543 | } | |||||
544 | ); | |||||
545 | } | |||||
546 | ||||||
547 | 0 | my $dbh = C4::Context->dbh(); | ||||
548 | 0 | my $statement = << 'ENDSQL'; | ||||
549 | INSERT INTO message_queue | |||||
550 | ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type ) | |||||
551 | VALUES | |||||
552 | ( ?, ?, ?, ?, ?, ?, ?, NOW(), ?, ?, ? ) | |||||
553 | ENDSQL | |||||
554 | ||||||
555 | 0 | my $sth = $dbh->prepare($statement); | ||||
556 | 0 | my $result = $sth->execute( | ||||
557 | $params->{'borrowernumber'}, # borrowernumber | |||||
558 | $params->{'letter'}->{'title'}, # subject | |||||
559 | $params->{'letter'}->{'content'}, # content | |||||
560 | $params->{'letter'}->{'metadata'} || '', # metadata | |||||
561 | $params->{'letter'}->{'code'} || '', # letter_code | |||||
562 | $params->{'message_transport_type'}, # message_transport_type | |||||
563 | 'pending', # status | |||||
564 | $params->{'to_address'}, # to_address | |||||
565 | $params->{'from_address'}, # from_address | |||||
566 | $params->{'letter'}->{'content-type'}, # content_type | |||||
567 | ); | |||||
568 | 0 | return $result; | ||||
569 | } | |||||
570 | ||||||
571 - 579 | =head2 SendQueuedMessages ([$hashref]) my $sent = SendQueuedMessages( { verbose => 1 } ); sends all of the 'pending' items in the message queue. returns number of messages sent. =cut | |||||
580 | ||||||
581 | sub SendQueuedMessages (;$) { | |||||
582 | 0 | my $params = shift; | ||||
583 | ||||||
584 | 0 | my $unsent_messages = _get_unsent_messages(); | ||||
585 | 0 | MESSAGE: foreach my $message ( @$unsent_messages ) { | ||||
586 | # warn Data::Dumper->Dump( [ $message ], [ 'message' ] ); | |||||
587 | 0 | warn sprintf( 'sending %s message to patron: %s', | ||||
588 | $message->{'message_transport_type'}, | |||||
589 | $message->{'borrowernumber'} || 'Admin' ) | |||||
590 | if $params->{'verbose'} or $debug; | |||||
591 | # This is just begging for subclassing | |||||
592 | 0 | next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' ); | ||||
593 | 0 | if ( lc( $message->{'message_transport_type'} ) eq 'email' ) { | ||||
594 | 0 | _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} ); | ||||
595 | } | |||||
596 | elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) { | |||||
597 | 0 | _send_message_by_sms( $message ); | ||||
598 | } | |||||
599 | } | |||||
600 | 0 | return scalar( @$unsent_messages ); | ||||
601 | } | |||||
602 | ||||||
603 - 609 | =head2 GetRSSMessages my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } ) returns a listref of all queued RSS messages for a particular person. =cut | |||||
610 | ||||||
611 | sub GetRSSMessages { | |||||
612 | 0 | my $params = shift; | ||||
613 | ||||||
614 | 0 | return unless $params; | ||||
615 | 0 | return unless ref $params; | ||||
616 | 0 | return unless $params->{'borrowernumber'}; | ||||
617 | ||||||
618 | 0 | return _get_unsent_messages( { message_transport_type => 'rss', | ||||
619 | limit => $params->{'limit'}, | |||||
620 | borrowernumber => $params->{'borrowernumber'}, } ); | |||||
621 | } | |||||
622 | ||||||
623 - 630 | =head2 GetPrintMessages my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } ) Returns a arrayref of all queued print messages (optionally, for a particular person). =cut | |||||
631 | ||||||
632 | sub GetPrintMessages { | |||||
633 | 0 | my $params = shift || {}; | ||||
634 | ||||||
635 | 0 | return _get_unsent_messages( { message_transport_type => 'print', | ||||
636 | borrowernumber => $params->{'borrowernumber'}, } ); | |||||
637 | } | |||||
638 | ||||||
639 - 648 | =head2 GetQueuedMessages ([$hashref]) my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } ); fetches messages out of the message queue. returns: list of hashes, each has represents a message in the message queue. =cut | |||||
649 | ||||||
650 | sub GetQueuedMessages { | |||||
651 | 0 | my $params = shift; | ||||
652 | ||||||
653 | 0 | my $dbh = C4::Context->dbh(); | ||||
654 | 0 | my $statement = << 'ENDSQL'; | ||||
655 | SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued | |||||
656 | FROM message_queue | |||||
657 | ENDSQL | |||||
658 | ||||||
659 | 0 | my @query_params; | ||||
660 | 0 | my @whereclauses; | ||||
661 | 0 | if ( exists $params->{'borrowernumber'} ) { | ||||
662 | 0 | push @whereclauses, ' borrowernumber = ? '; | ||||
663 | 0 | push @query_params, $params->{'borrowernumber'}; | ||||
664 | } | |||||
665 | ||||||
666 | 0 | if ( @whereclauses ) { | ||||
667 | 0 | $statement .= ' WHERE ' . join( 'AND', @whereclauses ); | ||||
668 | } | |||||
669 | ||||||
670 | 0 | if ( defined $params->{'limit'} ) { | ||||
671 | 0 | $statement .= ' LIMIT ? '; | ||||
672 | 0 | push @query_params, $params->{'limit'}; | ||||
673 | } | |||||
674 | ||||||
675 | 0 | my $sth = $dbh->prepare( $statement ); | ||||
676 | 0 | my $result = $sth->execute( @query_params ); | ||||
677 | 0 | return $sth->fetchall_arrayref({}); | ||||
678 | } | |||||
679 | ||||||
680 - 692 | =head2 _add_attachements named parameters: letter - the standard letter hashref attachments - listref of attachments. each attachment is a hashref of: type - the mime type, like 'text/plain' content - the actual attachment filename - the name of the attachment. message - a MIME::Lite object to attach these to. returns your letter object, with the content updated. =cut | |||||
693 | ||||||
694 | sub _add_attachments { | |||||
695 | 0 | my $params = shift; | ||||
696 | ||||||
697 | 0 | return unless 'HASH' eq ref $params; | ||||
698 | 0 | foreach my $required_parameter (qw( letter attachments message )) { | ||||
699 | 0 | return unless exists $params->{$required_parameter}; | ||||
700 | } | |||||
701 | 0 0 | return $params->{'letter'} unless @{ $params->{'attachments'} }; | ||||
702 | ||||||
703 | # First, we have to put the body in as the first attachment | |||||
704 | 0 | $params->{'message'}->attach( | ||||
705 | Type => 'TEXT', | |||||
706 | Data => $params->{'letter'}->{'content'}, | |||||
707 | ); | |||||
708 | ||||||
709 | 0 0 | foreach my $attachment ( @{ $params->{'attachments'} } ) { | ||||
710 | 0 | $params->{'message'}->attach( | ||||
711 | Type => $attachment->{'type'}, | |||||
712 | Data => $attachment->{'content'}, | |||||
713 | Filename => $attachment->{'filename'}, | |||||
714 | ); | |||||
715 | } | |||||
716 | # we're forcing list context here to get the header, not the count back from grep. | |||||
717 | 0 | ( $params->{'letter'}->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) ); | ||||
718 | 0 | $params->{'letter'}->{'content-type'} =~ s/^Content-Type:\s+//; | ||||
719 | 0 | $params->{'letter'}->{'content'} = $params->{'message'}->body_as_string; | ||||
720 | ||||||
721 | 0 | return $params->{'letter'}; | ||||
722 | ||||||
723 | } | |||||
724 | ||||||
725 | sub _get_unsent_messages (;$) { | |||||
726 | 0 | my $params = shift; | ||||
727 | ||||||
728 | 0 | my $dbh = C4::Context->dbh(); | ||||
729 | 0 | my $statement = << 'ENDSQL'; | ||||
730 | SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, from_address, to_address, content_type | |||||
731 | FROM message_queue | |||||
732 | WHERE status = ? | |||||
733 | ENDSQL | |||||
734 | ||||||
735 | 0 | my @query_params = ('pending'); | ||||
736 | 0 | if ( ref $params ) { | ||||
737 | 0 | if ( $params->{'message_transport_type'} ) { | ||||
738 | 0 | $statement .= ' AND message_transport_type = ? '; | ||||
739 | 0 | push @query_params, $params->{'message_transport_type'}; | ||||
740 | } | |||||
741 | 0 | if ( $params->{'borrowernumber'} ) { | ||||
742 | 0 | $statement .= ' AND borrowernumber = ? '; | ||||
743 | 0 | push @query_params, $params->{'borrowernumber'}; | ||||
744 | } | |||||
745 | 0 | if ( $params->{'limit'} ) { | ||||
746 | 0 | $statement .= ' limit ? '; | ||||
747 | 0 | push @query_params, $params->{'limit'}; | ||||
748 | } | |||||
749 | } | |||||
750 | 0 | $debug and warn "_get_unsent_messages SQL: $statement"; | ||||
751 | 0 | $debug and warn "_get_unsent_messages params: " . join(',',@query_params); | ||||
752 | 0 | my $sth = $dbh->prepare( $statement ); | ||||
753 | 0 | my $result = $sth->execute( @query_params ); | ||||
754 | 0 | return $sth->fetchall_arrayref({}); | ||||
755 | } | |||||
756 | ||||||
757 | sub _send_message_by_email ($;$$$) { | |||||
758 | 0 | my $message = shift or return; | ||||
759 | 0 | my ($username, $password, $method) = @_; | ||||
760 | ||||||
761 | 0 | my $to_address = $message->{to_address}; | ||||
762 | 0 | unless ($to_address) { | ||||
763 | 0 | my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} ); | ||||
764 | 0 | unless ($member) { | ||||
765 | 0 | warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})"; | ||||
766 | 0 | _set_message_status( { message_id => $message->{'message_id'}, | ||||
767 | status => 'failed' } ); | |||||
768 | 0 | return; | ||||
769 | } | |||||
770 | 0 | my $which_address = C4::Context->preference('AutoEmailPrimaryAddress'); | ||||
771 | # If the system preference is set to 'first valid' (value == OFF), look up email address | |||||
772 | 0 | if ($which_address eq 'OFF') { | ||||
773 | 0 | $to_address = GetFirstValidEmailAddress( $message->{'borrowernumber'} ); | ||||
774 | } else { | |||||
775 | 0 | $to_address = $member->{$which_address}; | ||||
776 | } | |||||
777 | 0 | unless ($to_address) { | ||||
778 | # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})"; | |||||
779 | # warning too verbose for this more common case? | |||||
780 | 0 | _set_message_status( { message_id => $message->{'message_id'}, | ||||
781 | status => 'failed' } ); | |||||
782 | 0 | return; | ||||
783 | } | |||||
784 | } | |||||
785 | ||||||
786 | 0 | my $utf8 = decode('MIME-Header', $message->{'subject'} ); | ||||
787 | 0 | $message->{subject}= encode('MIME-Header', $utf8); | ||||
788 | 0 | my $content = encode('utf8', $message->{'content'}); | ||||
789 | 0 | my %sendmail_params = ( | ||||
790 | To => $to_address, | |||||
791 | From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'), | |||||
792 | Subject => encode('utf8', $message->{'subject'}), | |||||
793 | charset => 'utf8', | |||||
794 | Message => $content, | |||||
795 | 'content-type' => $message->{'content_type'} || 'text/plain; charset="UTF-8"', | |||||
796 | ); | |||||
797 | 0 | $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username; | ||||
798 | 0 | if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) { | ||||
799 | 0 | $sendmail_params{ Bcc } = $bcc; | ||||
800 | } | |||||
801 | ||||||
802 | 0 | _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 | ||||
803 | 0 | if ( sendmail( %sendmail_params ) ) { | ||||
804 | 0 | _set_message_status( { message_id => $message->{'message_id'}, | ||||
805 | status => 'sent' } ); | |||||
806 | 0 | return 1; | ||||
807 | } else { | |||||
808 | 0 | _set_message_status( { message_id => $message->{'message_id'}, | ||||
809 | status => 'failed' } ); | |||||
810 | 0 | carp $Mail::Sendmail::error; | ||||
811 | 0 | return; | ||||
812 | } | |||||
813 | } | |||||
814 | ||||||
815 | sub _send_message_by_sms ($) { | |||||
816 | 0 | my $message = shift or return undef; | ||||
817 | 0 | my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} ); | ||||
818 | 0 | return unless $member->{'smsalertnumber'}; | ||||
819 | ||||||
820 | 0 | my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'}, | ||||
821 | message => $message->{'content'}, | |||||
822 | } ); | |||||
823 | 0 | _set_message_status( { message_id => $message->{'message_id'}, | ||||
824 | status => ($success ? 'sent' : 'failed') } ); | |||||
825 | 0 | return $success; | ||||
826 | } | |||||
827 | ||||||
828 | sub _update_message_to_address { | |||||
829 | 0 | my ($id, $to)= @_; | ||||
830 | 0 | my $dbh = C4::Context->dbh(); | ||||
831 | 0 | $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id)); | ||||
832 | } | |||||
833 | ||||||
834 | sub _set_message_status ($) { | |||||
835 | 0 | my $params = shift or return undef; | ||||
836 | ||||||
837 | 0 | foreach my $required_parameter ( qw( message_id status ) ) { | ||||
838 | 0 | return undef unless exists $params->{ $required_parameter }; | ||||
839 | } | |||||
840 | ||||||
841 | 0 | my $dbh = C4::Context->dbh(); | ||||
842 | 0 | my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?'; | ||||
843 | 0 | my $sth = $dbh->prepare( $statement ); | ||||
844 | 0 | my $result = $sth->execute( $params->{'status'}, | ||||
845 | $params->{'message_id'} ); | |||||
846 | 0 | return $result; | ||||
847 | } | |||||
848 | ||||||
849 | ||||||
850 | 1; |