3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
24 use Date
::Calc
qw( Add_Delta_Days );
28 use Module
::Load
::Conditional
qw(can_load);
31 use C4
::Members
::Attributes
qw(GetBorrowerAttributes);
36 use Koha
::SMS
::Providers
;
39 use Koha
::Notice
::Messages
;
40 use Koha
::DateUtils
qw( format_sqldatetime dt_from_string );
42 use Koha
::Subscriptions
;
44 use vars
qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
50 &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &SendAlerts &GetPrintMessages &GetMessageTransportTypes
56 C4::Letters - Give functions for Letters management
64 "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
65 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)
67 Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
69 =head2 GetLetters([$module])
71 $letters = &GetLetters($module);
72 returns informations about letters.
73 if needed, $module filters for letters given module
75 DEPRECATED - You must use Koha::Notice::Templates instead
76 The group by clause is confusing and can lead to issues
82 my $module = $filters->{module
};
83 my $code = $filters->{code
};
84 my $branchcode = $filters->{branchcode
};
85 my $dbh = C4
::Context
->dbh;
86 my $letters = $dbh->selectall_arrayref(
88 SELECT code
, module
, name
92 . ( $module ? q
| AND module
= ?
| : q
|| )
93 . ( $code ? q
| AND code
= ?
| : q
|| )
94 . ( defined $branchcode ? q
| AND branchcode
= ?
| : q
|| )
95 . q
| GROUP BY code
, module
, name ORDER BY name
|, { Slice
=> {} }
96 , ( $module ?
$module : () )
97 , ( $code ?
$code : () )
98 , ( defined $branchcode ?
$branchcode : () )
104 =head2 GetLetterTemplates
106 my $letter_templates = GetLetterTemplates(
108 module => 'circulation',
110 branchcode => 'CPL', # '' for default,
114 Return a hashref of letter templates.
118 sub GetLetterTemplates
{
121 my $module = $params->{module
};
122 my $code = $params->{code
};
123 my $branchcode = $params->{branchcode
} // '';
124 my $dbh = C4
::Context
->dbh;
125 my $letters = $dbh->selectall_arrayref(
127 SELECT module
, code
, branchcode
, name
, is_html
, title
, content
, message_transport_type
, lang
134 , $module, $code, $branchcode
140 =head2 GetLettersAvailableForALibrary
142 my $letters = GetLettersAvailableForALibrary(
144 branchcode => 'CPL', # '' for default
145 module => 'circulation',
149 Return an arrayref of letters, sorted by name.
150 If a specific letter exist for the given branchcode, it will be retrieve.
151 Otherwise the default letter will be.
155 sub GetLettersAvailableForALibrary
{
157 my $branchcode = $filters->{branchcode
};
158 my $module = $filters->{module
};
160 croak
"module should be provided" unless $module;
162 my $dbh = C4
::Context
->dbh;
163 my $default_letters = $dbh->selectall_arrayref(
165 SELECT module
, code
, branchcode
, name
169 . q
| AND branchcode
= ''|
170 . ( $module ? q
| AND module
= ?
| : q
|| )
171 . q
| ORDER BY name
|, { Slice
=> {} }
172 , ( $module ?
$module : () )
175 my $specific_letters;
177 $specific_letters = $dbh->selectall_arrayref(
179 SELECT module
, code
, branchcode
, name
183 . q
| AND branchcode
= ?
|
184 . ( $module ? q
| AND module
= ?
| : q
|| )
185 . q
| ORDER BY name
|, { Slice
=> {} }
187 , ( $module ?
$module : () )
192 for my $l (@
$default_letters) {
193 $letters{ $l->{code
} } = $l;
195 for my $l (@
$specific_letters) {
196 # Overwrite the default letter with the specific one.
197 $letters{ $l->{code
} } = $l;
200 return [ map { $letters{$_} }
201 sort { $letters{$a}->{name
} cmp $letters{$b}->{name
} }
207 my ( $module, $code, $branchcode, $message_transport_type, $lang) = @_;
208 $message_transport_type //= '%';
209 $lang = 'default' unless( $lang && C4
::Context
->preference('TranslateNotices') );
212 my $only_my_library = C4
::Context
->only_my_library;
213 if ( $only_my_library and $branchcode ) {
214 $branchcode = C4
::Context
::mybranch
();
218 my $dbh = C4
::Context
->dbh;
219 my $sth = $dbh->prepare(q{
222 WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
223 AND message_transport_type LIKE ?
225 ORDER BY branchcode DESC LIMIT 1
227 $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
228 my $line = $sth->fetchrow_hashref
230 $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html
};
240 module => 'circulation',
246 Delete the letter. The mtt parameter is facultative.
247 If not given, all templates mathing the other parameters will be removed.
253 my $branchcode = $params->{branchcode
};
254 my $module = $params->{module
};
255 my $code = $params->{code
};
256 my $mtt = $params->{mtt
};
257 my $lang = $params->{lang
};
258 my $dbh = C4
::Context
->dbh;
265 . ( $mtt ? q
| AND message_transport_type
= ?
| : q
|| )
266 . ( $lang? q
| AND lang
= ?
| : q
|| )
267 , undef, $branchcode, $module, $code, ( $mtt ?
$mtt : () ), ( $lang ?
$lang : () ) );
272 my $err = &SendAlerts($type, $externalid, $letter_code);
275 - $type : the type of alert
276 - $externalid : the id of the "object" to query
277 - $letter_code : the notice template to use
279 C<&SendAlerts> sends an email notice directly to a patron or a vendor.
281 Currently it supports ($type):
282 - claim serial issues (claimissues)
283 - claim acquisition orders (claimacquisition)
284 - send acquisition orders to the vendor (orderacquisition)
285 - notify patrons about newly received serial issues (issue)
286 - notify patrons when their account is created (members)
288 Returns undef or { error => 'message } on failure.
289 Returns true on success.
294 my ( $type, $externalid, $letter_code ) = @_;
295 my $dbh = C4
::Context
->dbh;
296 if ( $type eq 'issue' ) {
298 # prepare the letter...
299 # search the subscriptionid
302 "SELECT subscriptionid FROM serial WHERE serialid=?");
303 $sth->execute($externalid);
304 my ($subscriptionid) = $sth->fetchrow
305 or warn( "No subscription for '$externalid'" ),
308 # search the biblionumber
311 "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
312 $sth->execute($subscriptionid);
313 my ($biblionumber) = $sth->fetchrow
314 or warn( "No biblionumber for '$subscriptionid'" ),
318 # find the list of subscribers to notify
319 my $subscription = Koha
::Subscriptions
->find( $subscriptionid );
320 my $subscribers = $subscription->subscribers;
321 while ( my $patron = $subscribers->next ) {
322 my $email = $patron->email or next;
324 # warn "sending issues...";
325 my $userenv = C4
::Context
->userenv;
326 my $library = $patron->library;
327 my $letter = GetPreparedLetter
(
329 letter_code
=> $letter_code,
330 branchcode
=> $userenv->{branch
},
332 'branches' => $library->branchcode,
333 'biblio' => $biblionumber,
334 'biblioitems' => $biblionumber,
335 'borrowers' => $patron->unblessed,
336 'subscription' => $subscriptionid,
337 'serial' => $externalid,
343 my $message = Koha
::Email
->new();
344 my %mail = $message->create_message_headers(
347 from
=> $library->branchemail,
348 replyto
=> $library->branchreplyto,
349 sender
=> $library->branchreturnpath,
350 subject
=> Encode
::encode
( "UTF-8", "" . $letter->{title
} ),
351 message
=> $letter->{'is_html'}
352 ? _wrap_html
( Encode
::encode
( "UTF-8", $letter->{'content'} ),
353 Encode
::encode
( "UTF-8", "" . $letter->{'title'} ))
354 : Encode
::encode
( "UTF-8", "" . $letter->{'content'} ),
355 contenttype
=> $letter->{'is_html'}
356 ?
'text/html; charset="utf-8"'
357 : 'text/plain; charset="utf-8"',
360 unless( Mail
::Sendmail
::sendmail
(%mail) ) {
361 carp
$Mail::Sendmail
::error
;
362 return { error
=> $Mail::Sendmail
::error
};
366 elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
368 # prepare the letter...
373 if ( $type eq 'claimacquisition') {
375 SELECT aqorders
.*,aqbasket
.*,biblio
.*,biblioitems
.*
377 LEFT JOIN aqbasket ON aqbasket
.basketno
=aqorders
.basketno
378 LEFT JOIN biblio ON aqorders
.biblionumber
=biblio
.biblionumber
379 LEFT JOIN biblioitems ON aqorders
.biblionumber
=biblioitems
.biblionumber
380 WHERE aqorders
.ordernumber IN
(
384 carp
"No order selected";
385 return { error
=> "no_order_selected" };
387 $strsth .= join( ",", ('?') x @
$externalid ) . ")";
388 $action = "ACQUISITION CLAIM";
389 $sthorders = $dbh->prepare($strsth);
390 $sthorders->execute( @
$externalid );
391 $dataorders = $sthorders->fetchall_arrayref( {} );
394 if ($type eq 'claimissues') {
396 SELECT serial
.*,subscription
.*, biblio
.*, biblioitems
.*, aqbooksellers
.*,
397 aqbooksellers
.id AS booksellerid
399 LEFT JOIN subscription ON serial
.subscriptionid
=subscription
.subscriptionid
400 LEFT JOIN biblio ON serial
.biblionumber
=biblio
.biblionumber
401 LEFT JOIN biblioitems ON serial
.biblionumber
= biblioitems
.biblionumber
402 LEFT JOIN aqbooksellers ON subscription
.aqbooksellerid
=aqbooksellers
.id
403 WHERE serial
.serialid IN
(
407 carp
"No issues selected";
408 return { error
=> "no_issues_selected" };
411 $strsth .= join( ",", ('?') x @
$externalid ) . ")";
412 $action = "SERIAL CLAIM";
413 $sthorders = $dbh->prepare($strsth);
414 $sthorders->execute( @
$externalid );
415 $dataorders = $sthorders->fetchall_arrayref( {} );
418 if ( $type eq 'orderacquisition') {
420 SELECT aqorders
.*,aqbasket
.*,biblio
.*,biblioitems
.*
422 LEFT JOIN aqbasket ON aqbasket
.basketno
=aqorders
.basketno
423 LEFT JOIN biblio ON aqorders
.biblionumber
=biblio
.biblionumber
424 LEFT JOIN biblioitems ON aqorders
.biblionumber
=biblioitems
.biblionumber
425 WHERE aqbasket
.basketno
= ?
426 AND orderstatus IN
('new','ordered')
430 carp
"No basketnumber given";
431 return { error
=> "no_basketno" };
433 $action = "ACQUISITION ORDER";
434 $sthorders = $dbh->prepare($strsth);
435 $sthorders->execute($externalid);
436 $dataorders = $sthorders->fetchall_arrayref( {} );
440 $dbh->prepare("select * from aqbooksellers where id=?");
441 $sthbookseller->execute( $dataorders->[0]->{booksellerid
} );
442 my $databookseller = $sthbookseller->fetchrow_hashref;
444 my $addressee = $type eq 'claimacquisition' || $type eq 'orderacquisition' ?
'acqprimary' : 'serialsprimary';
447 $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
448 $sthcontact->execute( $dataorders->[0]->{booksellerid
} );
449 my $datacontact = $sthcontact->fetchrow_hashref;
453 push @email, $databookseller->{bookselleremail
} if $databookseller->{bookselleremail
};
454 push @email, $datacontact->{email
} if ( $datacontact && $datacontact->{email
} );
456 warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
457 return { error
=> "no_email" };
460 while ($addlcontact = $sthcontact->fetchrow_hashref) {
461 push @cc, $addlcontact->{email
} if ( $addlcontact && $addlcontact->{email
} );
464 my $userenv = C4
::Context
->userenv;
465 my $letter = GetPreparedLetter
(
467 letter_code
=> $letter_code,
468 branchcode
=> $userenv->{branch
},
470 'branches' => $userenv->{branch
},
471 'aqbooksellers' => $databookseller,
472 'aqcontacts' => $datacontact,
474 repeat
=> $dataorders,
476 ) or return { error
=> "no_letter" };
478 # Remove the order tag
479 $letter->{content
} =~ s/<order>(.*?)<\/order>/$1/gxms
;
482 my $library = Koha
::Libraries
->find( $userenv->{branch
} );
483 my $email = Koha
::Email
->new();
484 my %mail = $email->create_message_headers(
486 to
=> join( ',', @email ),
487 cc
=> join( ',', @cc ),
490 C4
::Context
->preference("ClaimsBccCopy")
491 && ( $type eq 'claimacquisition'
492 || $type eq 'claimissues' )
493 ) ?
( bcc
=> $userenv->{emailaddress
} )
496 from
=> $library->branchemail
497 || C4
::Context
->preference('KohaAdminEmailAddress'),
498 subject
=> Encode
::encode
( "UTF-8", "" . $letter->{title
} ),
499 message
=> $letter->{'is_html'} ? _wrap_html
(
500 Encode
::encode
( "UTF-8", $letter->{'content'} ),
501 Encode
::encode
( "UTF-8", "" . $letter->{'title'} )
503 : Encode
::encode
( "UTF-8", "" . $letter->{'content'} ),
504 contenttype
=> $letter->{'is_html'}
505 ?
'text/html; charset="utf-8"'
506 : 'text/plain; charset="utf-8"',
510 unless ( Mail
::Sendmail
::sendmail
(%mail) ) {
511 carp
$Mail::Sendmail
::error
;
512 return { error
=> $Mail::Sendmail
::error
};
520 . join( ',', @email )
525 ) if C4
::Context
->preference("LetterLog");
527 # send an "account details" notice to a newly created user
528 elsif ( $type eq 'members' ) {
529 my $library = Koha
::Libraries
->find( $externalid->{branchcode
} )->unblessed;
530 my $letter = GetPreparedLetter
(
532 letter_code
=> $letter_code,
533 branchcode
=> $externalid->{'branchcode'},
534 lang
=> $externalid->{lang
} || 'default',
536 'branches' => $library,
537 'borrowers' => $externalid->{'borrowernumber'},
539 substitute
=> { 'borrowers.password' => $externalid->{'password'} },
542 return { error
=> "no_email" } unless $externalid->{'emailaddr'};
543 my $email = Koha
::Email
->new();
544 my %mail = $email->create_message_headers(
546 to
=> $externalid->{'emailaddr'},
547 from
=> $library->{branchemail
},
548 replyto
=> $library->{branchreplyto
},
549 sender
=> $library->{branchreturnpath
},
550 subject
=> Encode
::encode
( "UTF-8", "" . $letter->{'title'} ),
551 message
=> $letter->{'is_html'}
552 ? _wrap_html
( Encode
::encode
( "UTF-8", $letter->{'content'} ),
553 Encode
::encode
( "UTF-8", "" . $letter->{'title'} ) )
554 : Encode
::encode
( "UTF-8", "" . $letter->{'content'} ),
555 contenttype
=> $letter->{'is_html'}
556 ?
'text/html; charset="utf-8"'
557 : 'text/plain; charset="utf-8"',
560 unless( Mail
::Sendmail
::sendmail
(%mail) ) {
561 carp
$Mail::Sendmail
::error
;
562 return { error
=> $Mail::Sendmail
::error
};
566 # If we come here, return an OK status
570 =head2 GetPreparedLetter( %params )
573 module => letter module, mandatory
574 letter_code => letter code, mandatory
575 branchcode => for letter selection, if missing default system letter taken
576 tables => a hashref with table names as keys. Values are either:
577 - a scalar - primary key value
578 - an arrayref - primary key values
579 - a hashref - full record
580 substitute => custom substitution key/value pairs
581 repeat => records to be substituted on consecutive lines:
582 - an arrayref - tries to guess what needs substituting by
583 taking remaining << >> tokensr; not recommended
584 - a hashref token => @tables - replaces <token> << >> << >> </token>
585 subtemplate for each @tables row; table is a hashref as above
586 want_librarian => boolean, if set to true triggers librarian details
587 substitution from the userenv
589 letter fields hashref (title & content useful)
593 sub GetPreparedLetter
{
596 my $letter = $params{letter
};
599 my $module = $params{module
} or croak
"No module";
600 my $letter_code = $params{letter_code
} or croak
"No letter_code";
601 my $branchcode = $params{branchcode
} || '';
602 my $mtt = $params{message_transport_type
} || 'email';
603 my $lang = $params{lang
} || 'default';
605 $letter = getletter
( $module, $letter_code, $branchcode, $mtt, $lang );
608 $letter = getletter
( $module, $letter_code, $branchcode, $mtt, 'default' )
609 or warn( "No $module $letter_code letter transported by " . $mtt ),
614 my $tables = $params{tables
} || {};
615 my $substitute = $params{substitute
} || {};
616 my $loops = $params{loops
} || {}; # loops is not supported for historical notices syntax
617 my $repeat = $params{repeat
};
618 %$tables || %$substitute || $repeat || %$loops
619 or carp
( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
621 my $want_librarian = $params{want_librarian
};
624 while ( my ($token, $val) = each %$substitute ) {
625 if ( $token eq 'items.content' ) {
626 $val =~ s
|\n|<br
/>|g
if $letter->{is_html
};
629 $letter->{title
} =~ s/<<$token>>/$val/g;
630 $letter->{content
} =~ s/<<$token>>/$val/g;
634 my $OPACBaseURL = C4
::Context
->preference('OPACBaseURL');
635 $letter->{content
} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
637 if ($want_librarian) {
638 # parsing librarian name
639 my $userenv = C4
::Context
->userenv;
640 $letter->{content
} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
641 $letter->{content
} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
642 $letter->{content
} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
645 my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
648 if (ref ($repeat) eq 'ARRAY' ) {
649 $repeat_no_enclosing_tags = $repeat;
651 $repeat_enclosing_tags = $repeat;
655 if ($repeat_enclosing_tags) {
656 while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
657 if ( $letter->{content
} =~ m!<$tag>(.*)</$tag>!s ) {
660 my %subletter = ( title
=> '', content
=> $subcontent );
661 _substitute_tables
( \
%subletter, $_ );
664 $letter->{content
} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
670 _substitute_tables
( $letter, $tables );
673 if ($repeat_no_enclosing_tags) {
674 if ( $letter->{content
} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
679 $c =~ s/<<count>>/$i/go;
680 foreach my $field ( keys %{$_} ) {
681 $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
685 } @
$repeat_no_enclosing_tags;
687 my $replaceby = join( "\n", @lines );
688 $letter->{content
} =~ s/\Q$line\E/$replaceby/s;
692 $letter->{content
} = _process_tt
(
694 content
=> $letter->{content
},
697 substitute
=> $substitute,
701 $letter->{content
} =~ s/<<\S*>>//go; #remove any stragglers
706 sub _substitute_tables
{
707 my ( $letter, $tables ) = @_;
708 while ( my ($table, $param) = each %$tables ) {
711 my $ref = ref $param;
714 if ($ref && $ref eq 'HASH') {
718 my $sth = _parseletter_sth
($table);
720 warn "_parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table.";
723 $sth->execute( $ref ? @
$param : $param );
725 $values = $sth->fetchrow_hashref;
729 _parseletter
( $letter, $table, $values );
733 sub _parseletter_sth
{
737 carp
"ERROR: _parseletter_sth() called without argument (table)";
740 # NOTE: we used to check whether we had a statement handle cached in
741 # a %handles module-level variable. This was a dumb move and
742 # broke things for the rest of us. prepare_cached is a better
743 # way to cache statement handles anyway.
745 ($table eq 'biblio' ) ?
"SELECT * FROM $table WHERE biblionumber = ?" :
746 ($table eq 'biblioitems' ) ?
"SELECT * FROM $table WHERE biblionumber = ?" :
747 ($table eq 'items' ) ?
"SELECT * FROM $table WHERE itemnumber = ?" :
748 ($table eq 'issues' ) ?
"SELECT * FROM $table WHERE itemnumber = ?" :
749 ($table eq 'old_issues' ) ?
"SELECT * FROM $table WHERE itemnumber = ? ORDER BY timestamp DESC LIMIT 1" :
750 ($table eq 'reserves' ) ?
"SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
751 ($table eq 'borrowers' ) ?
"SELECT * FROM $table WHERE borrowernumber = ?" :
752 ($table eq 'branches' ) ?
"SELECT * FROM $table WHERE branchcode = ?" :
753 ($table eq 'suggestions' ) ?
"SELECT * FROM $table WHERE suggestionid = ?" :
754 ($table eq 'aqbooksellers') ?
"SELECT * FROM $table WHERE id = ?" :
755 ($table eq 'aqorders' ) ?
"SELECT * FROM $table WHERE ordernumber = ?" :
756 ($table eq 'opac_news' ) ?
"SELECT * FROM $table WHERE idnew = ?" :
757 ($table eq 'article_requests') ?
"SELECT * FROM $table WHERE id = ?" :
758 ($table eq 'borrower_modifications') ?
"SELECT * FROM $table WHERE verification_token = ?" :
759 ($table eq 'subscription') ?
"SELECT * FROM $table WHERE subscriptionid = ?" :
760 ($table eq 'serial') ?
"SELECT * FROM $table WHERE serialid = ?" :
763 warn "ERROR: No _parseletter_sth query for table '$table'";
764 return; # nothing to get
766 unless ($sth = C4
::Context
->dbh->prepare_cached($query)) {
767 warn "ERROR: Failed to prepare query: '$query'";
770 return $sth; # now cache is populated for that $table
773 =head2 _parseletter($letter, $table, $values)
776 - $letter : a hash to letter fields (title & content useful)
777 - $table : the Koha table to parse.
778 - $values_in : table record hashref
779 parse all fields from a table, and replace values in title & content with the appropriate value
780 (not exported sub, used only internally)
785 my ( $letter, $table, $values_in ) = @_;
787 # Work on a local copy of $values_in (passed by reference) to avoid side effects
788 # in callers ( by changing / formatting values )
789 my $values = $values_in ?
{ %$values_in } : {};
791 if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
792 $values->{'dateexpiry'} = output_pref
({ dt
=> dt_from_string
( $values->{'dateexpiry'} ), dateonly
=> 1 });
795 if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
796 $values->{'waitingdate'} = output_pref
({ dt
=> dt_from_string
( $values->{'waitingdate'} ), dateonly
=> 1 });
799 if ($letter->{content
} && $letter->{content
} =~ /<<today>>/) {
800 my $todaysdate = output_pref
( DateTime
->now() );
801 $letter->{content
} =~ s/<<today>>/$todaysdate/go;
804 while ( my ($field, $val) = each %$values ) {
805 $val =~ s/\p{P}$// if $val && $table=~/biblio/;
806 #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
807 #Therefore adding the test on biblio. This includes biblioitems,
808 #but excludes items. Removed unneeded global and lookahead.
810 if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
811 my $av = Koha
::AuthorisedValues
->search({ category
=> 'ROADTYPE', authorised_value
=> $val });
812 $val = $av->count ?
$av->next->lib : '';
816 my $replacedby = defined ($val) ?
$val : '';
818 and not $replacedby =~ m
|0000-00-00|
819 and not $replacedby =~ m
|9999-12-31|
820 and $replacedby =~ m
|^\d
{4}-\d
{2}-\d
{2}( \d
{2}:\d
{2}:\d
{2})?
$| )
822 # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
823 my $dateonly = defined $1 ?
0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
824 my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
826 for my $letter_field ( qw( title content ) ) {
827 my $filter_string_used = q{};
828 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
829 # We overwrite $dateonly if the filter exists and we have a time in the datetime
830 $filter_string_used = $1 || q{};
831 $dateonly = $1 unless $dateonly;
833 my $replacedby_date = eval {
834 output_pref
({ dt
=> dt_from_string
( $replacedby ), dateonly
=> $dateonly });
837 if ( $letter->{ $letter_field } ) {
838 $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
839 $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
843 # Other fields replacement
845 for my $letter_field ( qw( title content ) ) {
846 if ( $letter->{ $letter_field } ) {
847 $letter->{ $letter_field } =~ s/<<$table.$field>>/$replacedby/g;
848 $letter->{ $letter_field } =~ s/<<$field>>/$replacedby/g;
854 if ($table eq 'borrowers' && $letter->{content
}) {
855 if ( my $attributes = GetBorrowerAttributes
($values->{borrowernumber
}) ) {
857 foreach (@
$attributes) {
858 my $code = $_->{code
};
859 my $val = $_->{value_description
} || $_->{value
};
860 $val =~ s/\p{P}(?=$)//g if $val;
861 next unless $val gt '';
863 push @
{ $attr{$code} }, $val;
865 while ( my ($code, $val_ar) = each %attr ) {
866 my $replacefield = "<<borrower-attribute:$code>>";
867 my $replacedby = join ',', @
$val_ar;
868 $letter->{content
} =~ s/$replacefield/$replacedby/g;
877 my $success = EnqueueLetter( { letter => $letter,
878 borrowernumber => '12', message_transport_type => 'email' } )
880 places a letter in the message_queue database table, which will
881 eventually get processed (sent) by the process_message_queue.pl
882 cronjob when it calls SendQueuedMessages.
884 return message_id on success
889 my $params = shift or return;
891 return unless exists $params->{'letter'};
892 # return unless exists $params->{'borrowernumber'};
893 return unless exists $params->{'message_transport_type'};
895 my $content = $params->{letter
}->{content
};
896 $content =~ s/\s+//g if(defined $content);
897 if ( not defined $content or $content eq '' ) {
898 warn "Trying to add an empty message to the message queue" if $debug;
902 # If we have any attachments we should encode then into the body.
903 if ( $params->{'attachments'} ) {
904 $params->{'letter'} = _add_attachments
(
905 { letter
=> $params->{'letter'},
906 attachments
=> $params->{'attachments'},
907 message
=> MIME
::Lite
->new( Type
=> 'multipart/mixed' ),
912 my $dbh = C4
::Context
->dbh();
913 my $statement = << 'ENDSQL';
914 INSERT INTO message_queue
915 ( borrowernumber
, subject
, content
, metadata
, letter_code
, message_transport_type
, status
, time_queued
, to_address
, from_address
, content_type
)
917 ( ?
, ?
, ?
, ?
, ?
, ?
, ?
, NOW
(), ?
, ?
, ?
)
920 my $sth = $dbh->prepare($statement);
921 my $result = $sth->execute(
922 $params->{'borrowernumber'}, # borrowernumber
923 $params->{'letter'}->{'title'}, # subject
924 $params->{'letter'}->{'content'}, # content
925 $params->{'letter'}->{'metadata'} || '', # metadata
926 $params->{'letter'}->{'code'} || '', # letter_code
927 $params->{'message_transport_type'}, # message_transport_type
929 $params->{'to_address'}, # to_address
930 $params->{'from_address'}, # from_address
931 $params->{'letter'}->{'content-type'}, # content_type
933 return $dbh->last_insert_id(undef,undef,'message_queue', undef);
936 =head2 SendQueuedMessages ([$hashref])
938 my $sent = SendQueuedMessages({
939 letter_code => $letter_code,
940 borrowernumber => $who_letter_is_for,
946 Sends all of the 'pending' items in the message queue, unless
947 parameters are passed.
949 The letter_code, borrowernumber and limit parameters are used
950 to build a parameter set for _get_unsent_messages, thus limiting
951 which pending messages will be processed. They are all optional.
953 The verbose parameter can be used to generate debugging output.
956 Returns number of messages sent.
960 sub SendQueuedMessages
{
963 my $which_unsent_messages = {
964 'limit' => $params->{'limit'} // 0,
965 'borrowernumber' => $params->{'borrowernumber'} // q{},
966 'letter_code' => $params->{'letter_code'} // q{},
967 'type' => $params->{'type'} // q{},
969 my $unsent_messages = _get_unsent_messages
( $which_unsent_messages );
970 MESSAGE
: foreach my $message ( @
$unsent_messages ) {
971 my $message_object = Koha
::Notice
::Messages
->find( $message->{message_id
} );
972 # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
973 $message_object->make_column_dirty('status');
974 return unless $message_object->store;
976 # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
977 warn sprintf( 'sending %s message to patron: %s',
978 $message->{'message_transport_type'},
979 $message->{'borrowernumber'} || 'Admin' )
980 if $params->{'verbose'} or $debug;
981 # This is just begging for subclassing
982 next MESSAGE
if ( lc($message->{'message_transport_type'}) eq 'rss' );
983 if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
984 _send_message_by_email
( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
986 elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
987 if ( C4
::Context
->preference('SMSSendDriver') eq 'Email' ) {
988 my $patron = Koha
::Patrons
->find( $message->{borrowernumber
} );
989 my $sms_provider = Koha
::SMS
::Providers
->find( $patron->sms_provider_id );
990 unless ( $sms_provider ) {
991 warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
992 _set_message_status
( { message_id
=> $message->{'message_id'}, status
=> 'failed' } );
995 unless ( $patron->smsalertnumber ) {
996 _set_message_status
( { message_id
=> $message->{'message_id'}, status
=> 'failed' } );
997 warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1000 $message->{to_address
} = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1001 $message->{to_address
} .= '@' . $sms_provider->domain();
1003 # Check for possible from_address override
1004 my $from_address = C4
::Context
->preference('EmailSMSSendDriverFromAddress');
1005 if ($from_address && $message->{from_address
} ne $from_address) {
1006 $message->{from_address
} = $from_address;
1007 _update_message_from_address
($message->{'message_id'}, $message->{from_address
});
1010 _update_message_to_address
($message->{'message_id'}, $message->{to_address
});
1011 _send_message_by_email
( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1013 _send_message_by_sms
( $message );
1017 return scalar( @
$unsent_messages );
1020 =head2 GetRSSMessages
1022 my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1024 returns a listref of all queued RSS messages for a particular person.
1028 sub GetRSSMessages
{
1031 return unless $params;
1032 return unless ref $params;
1033 return unless $params->{'borrowernumber'};
1035 return _get_unsent_messages
( { message_transport_type
=> 'rss',
1036 limit
=> $params->{'limit'},
1037 borrowernumber
=> $params->{'borrowernumber'}, } );
1040 =head2 GetPrintMessages
1042 my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1044 Returns a arrayref of all queued print messages (optionally, for a particular
1049 sub GetPrintMessages
{
1050 my $params = shift || {};
1052 return _get_unsent_messages
( { message_transport_type
=> 'print',
1053 borrowernumber
=> $params->{'borrowernumber'},
1057 =head2 GetQueuedMessages ([$hashref])
1059 my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1061 fetches messages out of the message queue.
1064 list of hashes, each has represents a message in the message queue.
1068 sub GetQueuedMessages
{
1071 my $dbh = C4
::Context
->dbh();
1072 my $statement = << 'ENDSQL';
1073 SELECT message_id
, borrowernumber
, subject
, content
, message_transport_type
, status
, time_queued
1079 if ( exists $params->{'borrowernumber'} ) {
1080 push @whereclauses, ' borrowernumber = ? ';
1081 push @query_params, $params->{'borrowernumber'};
1084 if ( @whereclauses ) {
1085 $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1088 if ( defined $params->{'limit'} ) {
1089 $statement .= ' LIMIT ? ';
1090 push @query_params, $params->{'limit'};
1093 my $sth = $dbh->prepare( $statement );
1094 my $result = $sth->execute( @query_params );
1095 return $sth->fetchall_arrayref({});
1098 =head2 GetMessageTransportTypes
1100 my @mtt = GetMessageTransportTypes();
1102 returns an arrayref of transport types
1106 sub GetMessageTransportTypes
{
1107 my $dbh = C4
::Context
->dbh();
1108 my $mtts = $dbh->selectcol_arrayref("
1109 SELECT message_transport_type
1110 FROM message_transport_types
1111 ORDER BY message_transport_type
1118 my $message = C4::Letters::Message($message_id);
1123 my ( $message_id ) = @_;
1124 return unless $message_id;
1125 my $dbh = C4
::Context
->dbh;
1126 return $dbh->selectrow_hashref(q
|
1127 SELECT message_id
, borrowernumber
, subject
, content
, metadata
, letter_code
, message_transport_type
, status
, time_queued
, to_address
, from_address
, content_type
1129 WHERE message_id
= ?
1130 |, {}, $message_id );
1133 =head2 ResendMessage
1135 Attempt to resend a message which has failed previously.
1137 my $has_been_resent = C4::Letters::ResendMessage($message_id);
1139 Updates the message to 'pending' status so that
1140 it will be resent later on.
1142 returns 1 on success, 0 on failure, undef if no message was found
1147 my $message_id = shift;
1148 return unless $message_id;
1150 my $message = GetMessage
( $message_id );
1151 return unless $message;
1153 if ( $message->{status
} ne 'pending' ) {
1154 $rv = C4
::Letters
::_set_message_status
({
1155 message_id
=> $message_id,
1156 status
=> 'pending',
1158 $rv = $rv > 0?
1: 0;
1159 # Clear destination email address to force address update
1160 _update_message_to_address
( $message_id, undef ) if $rv &&
1161 $message->{message_transport_type
} eq 'email';
1166 =head2 _add_attachements
1169 letter - the standard letter hashref
1170 attachments - listref of attachments. each attachment is a hashref of:
1171 type - the mime type, like 'text/plain'
1172 content - the actual attachment
1173 filename - the name of the attachment.
1174 message - a MIME::Lite object to attach these to.
1176 returns your letter object, with the content updated.
1180 sub _add_attachments
{
1183 my $letter = $params->{'letter'};
1184 my $attachments = $params->{'attachments'};
1185 return $letter unless @
$attachments;
1186 my $message = $params->{'message'};
1188 # First, we have to put the body in as the first attachment
1190 Type
=> $letter->{'content-type'} || 'TEXT',
1191 Data
=> $letter->{'is_html'}
1192 ? _wrap_html
($letter->{'content'}, $letter->{'title'})
1193 : $letter->{'content'},
1196 foreach my $attachment ( @
$attachments ) {
1198 Type
=> $attachment->{'type'},
1199 Data
=> $attachment->{'content'},
1200 Filename
=> $attachment->{'filename'},
1203 # we're forcing list context here to get the header, not the count back from grep.
1204 ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1205 $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1206 $letter->{'content'} = $message->body_as_string;
1212 =head2 _get_unsent_messages
1214 This function's parameter hash reference takes the following
1215 optional named parameters:
1216 message_transport_type: method of message sending (e.g. email, sms, etc.)
1217 borrowernumber : who the message is to be sent
1218 letter_code : type of message being sent (e.g. PASSWORD_RESET)
1219 limit : maximum number of messages to send
1221 This function returns an array of matching hash referenced rows from
1222 message_queue with some borrower information added.
1226 sub _get_unsent_messages
{
1229 my $dbh = C4
::Context
->dbh();
1231 SELECT 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
, mq
.letter_code
1232 FROM message_queue mq
1233 LEFT JOIN borrowers b ON b
.borrowernumber
= mq
.borrowernumber
1237 my @query_params = ('pending');
1238 if ( ref $params ) {
1239 if ( $params->{'message_transport_type'} ) {
1240 $statement .= ' AND mq.message_transport_type = ? ';
1241 push @query_params, $params->{'message_transport_type'};
1243 if ( $params->{'borrowernumber'} ) {
1244 $statement .= ' AND mq.borrowernumber = ? ';
1245 push @query_params, $params->{'borrowernumber'};
1247 if ( $params->{'letter_code'} ) {
1248 $statement .= ' AND mq.letter_code = ? ';
1249 push @query_params, $params->{'letter_code'};
1251 if ( $params->{'type'} ) {
1252 $statement .= ' AND message_transport_type = ? ';
1253 push @query_params, $params->{'type'};
1255 if ( $params->{'limit'} ) {
1256 $statement .= ' limit ? ';
1257 push @query_params, $params->{'limit'};
1261 $debug and warn "_get_unsent_messages SQL: $statement";
1262 $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1263 my $sth = $dbh->prepare( $statement );
1264 my $result = $sth->execute( @query_params );
1265 return $sth->fetchall_arrayref({});
1268 sub _send_message_by_email
{
1269 my $message = shift or return;
1270 my ($username, $password, $method) = @_;
1272 my $patron = Koha
::Patrons
->find( $message->{borrowernumber
} );
1273 my $to_address = $message->{'to_address'};
1274 unless ($to_address) {
1276 warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1277 _set_message_status
( { message_id
=> $message->{'message_id'},
1278 status
=> 'failed' } );
1281 $to_address = $patron->notice_email_address;
1282 unless ($to_address) {
1283 # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1284 # warning too verbose for this more common case?
1285 _set_message_status
( { message_id
=> $message->{'message_id'},
1286 status
=> 'failed' } );
1291 # Encode subject line separately
1292 $message->{subject
} = encode
('MIME-Header', $message->{'subject'} );
1293 my $subject = $message->{'subject'};
1295 my $content = encode
('UTF-8', $message->{'content'});
1296 my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1297 my $is_html = $content_type =~ m/html/io;
1298 my $branch_email = undef;
1299 my $branch_replyto = undef;
1300 my $branch_returnpath = undef;
1302 my $library = $patron->library;
1303 $branch_email = $library->branchemail;
1304 $branch_replyto = $library->branchreplyto;
1305 $branch_returnpath = $library->branchreturnpath;
1307 my $email = Koha
::Email
->new();
1308 my %sendmail_params = $email->create_message_headers(
1312 C4
::Context
->preference('NoticeBcc')
1313 ?
( bcc
=> C4
::Context
->preference('NoticeBcc') )
1316 from
=> $message->{'from_address'} || $branch_email,
1317 replyto
=> $branch_replyto,
1318 sender
=> $branch_returnpath,
1319 subject
=> $subject,
1320 message
=> $is_html ? _wrap_html
( $content, $subject ) : $content,
1321 contenttype
=> $content_type
1325 $sendmail_params{'Auth'} = {user
=> $username, pass
=> $password, method
=> $method} if $username;
1327 _update_message_to_address
($message->{'message_id'},$sendmail_params{To
}) if !$message->{to_address
} || $message->{to_address
} ne $sendmail_params{To
}; #if initial message address was empty, coming here means that a to address was found and queue should be updated; same if to address was overriden by create_message_headers
1329 if ( Mail
::Sendmail
::sendmail
( %sendmail_params ) ) {
1330 _set_message_status
( { message_id
=> $message->{'message_id'},
1331 status
=> 'sent' } );
1334 _set_message_status
( { message_id
=> $message->{'message_id'},
1335 status
=> 'failed' } );
1336 carp
$Mail::Sendmail
::error
;
1342 my ($content, $title) = @_;
1344 my $css = C4
::Context
->preference("NoticeCSS") || '';
1345 $css = qq{<link rel
="stylesheet" type
="text/css" href
="$css">} if $css;
1347 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1348 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1349 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1351 <title>$title</title>
1352 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1363 my ( $message ) = @_;
1364 my $dbh = C4
::Context
->dbh;
1365 my $count = $dbh->selectrow_array(q
|
1368 WHERE message_transport_type
= ?
1369 AND borrowernumber
= ?
1371 AND CAST
(time_queued AS date
) = CAST
(NOW
() AS date
)
1374 |, {}, $message->{message_transport_type
}, $message->{borrowernumber
}, $message->{letter_code
}, $message->{content
} );
1378 sub _send_message_by_sms
{
1379 my $message = shift or return;
1380 my $patron = Koha
::Patrons
->find( $message->{borrowernumber
} );
1382 unless ( $patron and $patron->smsalertnumber ) {
1383 _set_message_status
( { message_id
=> $message->{'message_id'},
1384 status
=> 'failed' } );
1388 if ( _is_duplicate
( $message ) ) {
1389 _set_message_status
( { message_id
=> $message->{'message_id'},
1390 status
=> 'failed' } );
1394 my $success = C4
::SMS
->send_sms( { destination
=> $patron->smsalertnumber,
1395 message
=> $message->{'content'},
1397 _set_message_status
( { message_id
=> $message->{'message_id'},
1398 status
=> ($success ?
'sent' : 'failed') } );
1402 sub _update_message_to_address
{
1404 my $dbh = C4
::Context
->dbh();
1405 $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1408 sub _update_message_from_address
{
1409 my ($message_id, $from_address) = @_;
1410 my $dbh = C4
::Context
->dbh();
1411 $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1414 sub _set_message_status
{
1415 my $params = shift or return;
1417 foreach my $required_parameter ( qw( message_id status ) ) {
1418 return unless exists $params->{ $required_parameter };
1421 my $dbh = C4
::Context
->dbh();
1422 my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1423 my $sth = $dbh->prepare( $statement );
1424 my $result = $sth->execute( $params->{'status'},
1425 $params->{'message_id'} );
1430 my ( $params ) = @_;
1432 my $content = $params->{content
};
1433 my $tables = $params->{tables
};
1434 my $loops = $params->{loops
};
1435 my $substitute = $params->{substitute
} || {};
1437 my $use_template_cache = C4
::Context
->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE
};
1438 my $template = Template
->new(
1442 PLUGIN_BASE
=> 'Koha::Template::Plugin',
1443 COMPILE_EXT
=> $use_template_cache ?
'.ttc' : '',
1444 COMPILE_DIR
=> $use_template_cache ? C4
::Context
->config('template_cache_dir') : '',
1446 ENCODING
=> 'UTF-8',
1448 ) or die Template
->error();
1450 my $tt_params = { %{ _get_tt_params
( $tables ) }, %{ _get_tt_params
( $loops, 'is_a_loop' ) }, %$substitute };
1452 $content = add_tt_filters
( $content );
1453 $content = qq|[% USE KohaDates
%][% USE Remove_MARC_punctuation
%]$content|;
1456 $template->process( \
$content, $tt_params, \
$output ) || croak
"ERROR PROCESSING TEMPLATE: " . $template->error();
1461 sub _get_tt_params
{
1462 my ($tables, $is_a_loop) = @_;
1468 article_requests
=> {
1469 module
=> 'Koha::ArticleRequests',
1470 singular
=> 'article_request',
1471 plural
=> 'article_requests',
1475 module
=> 'Koha::Biblios',
1476 singular
=> 'biblio',
1477 plural
=> 'biblios',
1478 pk
=> 'biblionumber',
1481 module
=> 'Koha::Biblioitems',
1482 singular
=> 'biblioitem',
1483 plural
=> 'biblioitems',
1484 pk
=> 'biblioitemnumber',
1487 module
=> 'Koha::Patrons',
1488 singular
=> 'borrower',
1489 plural
=> 'borrowers',
1490 pk
=> 'borrowernumber',
1493 module
=> 'Koha::Libraries',
1494 singular
=> 'branch',
1495 plural
=> 'branches',
1499 module
=> 'Koha::Items',
1505 module
=> 'Koha::News',
1511 module
=> 'Koha::Acquisition::Orders',
1512 singular
=> 'order',
1514 pk
=> 'ordernumber',
1517 module
=> 'Koha::Holds',
1520 fk
=> [ 'borrowernumber', 'biblionumber' ],
1523 module
=> 'Koha::Serials',
1524 singular
=> 'serial',
1525 plural
=> 'serials',
1529 module
=> 'Koha::Subscriptions',
1530 singular
=> 'subscription',
1531 plural
=> 'subscriptions',
1532 pk
=> 'subscriptionid',
1535 module
=> 'Koha::Suggestions',
1536 singular
=> 'suggestion',
1537 plural
=> 'suggestions',
1538 pk
=> 'suggestionid',
1541 module
=> 'Koha::Checkouts',
1542 singular
=> 'checkout',
1543 plural
=> 'checkouts',
1547 module
=> 'Koha::Old::Checkouts',
1548 singular
=> 'old_checkout',
1549 plural
=> 'old_checkouts',
1553 module
=> 'Koha::Checkouts',
1554 singular
=> 'overdue',
1555 plural
=> 'overdues',
1558 borrower_modifications
=> {
1559 module
=> 'Koha::Patron::Modifications',
1560 singular
=> 'patron_modification',
1561 plural
=> 'patron_modifications',
1562 fk
=> 'verification_token',
1566 foreach my $table ( keys %$tables ) {
1567 next unless $config->{$table};
1569 my $ref = ref( $tables->{$table} ) || q{};
1570 my $module = $config->{$table}->{module
};
1572 if ( can_load
( modules
=> { $module => undef } ) ) {
1573 my $pk = $config->{$table}->{pk
};
1574 my $fk = $config->{$table}->{fk
};
1577 my $values = $tables->{$table} || [];
1578 unless ( ref( $values ) eq 'ARRAY' ) {
1579 croak
"ERROR processing table $table. Wrong API call.";
1581 my $key = $pk ?
$pk : $fk;
1582 # $key does not come from user input
1583 my $objects = $module->search(
1584 { $key => $values },
1586 # We want to retrieve the data in the same order
1588 # field is a MySQLism, but they are no other way to do it
1589 # To be generic we could do it in perl, but we will need to fetch
1590 # all the data then order them
1591 @
$values ?
( order_by
=> \
[ "field($key, " . join( ', ', @
$values ) . ")" ] ) : ()
1594 $params->{ $config->{$table}->{plural
} } = $objects;
1596 elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1597 my $id = ref $ref eq 'HASH' ?
$tables->{$table}->{$pk} : $tables->{$table};
1599 if ( $fk ) { # Using a foreign key for lookup
1600 if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1602 foreach my $key ( @
$fk ) {
1603 $search->{$key} = $id->{$key};
1605 $object = $module->search( $search )->last();
1606 } else { # Foreign key is single column
1607 $object = $module->search( { $fk => $id } )->last();
1609 } else { # using the table's primary key for lookup
1610 $object = $module->find($id);
1612 $params->{ $config->{$table}->{singular
} } = $object;
1614 else { # $ref eq 'ARRAY'
1616 if ( @
{ $tables->{$table} } == 1 ) { # Param is a single key
1617 $object = $module->search( { $pk => $tables->{$table} } )->last();
1619 else { # Params are mutliple foreign keys
1620 croak
"Multiple foreign keys (table $table) should be passed using an hashref";
1622 $params->{ $config->{$table}->{singular
} } = $object;
1626 croak
"ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1630 $params->{today
} = output_pref
({ dt
=> dt_from_string
, dateformat
=> 'iso' });
1635 =head3 add_tt_filters
1637 $content = add_tt_filters( $content );
1639 Add TT filters to some specific fields if needed.
1641 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1645 sub add_tt_filters
{
1646 my ( $content ) = @_;
1647 $content =~ s
|\
[%\s
*biblio\
.(.*?
)\s
*%\
]|[% biblio
.$1 \
| \
$Remove_MARC_punctuation %]|gxms
;
1648 $content =~ s
|\
[%\s
*biblioitem\
.(.*?
)\s
*%\
]|[% biblioitem
.$1 \
| \
$Remove_MARC_punctuation %]|gxms
;
1652 =head2 get_item_content
1654 my $item = Koha::Items->find(...)->unblessed;
1655 my @item_content_fields = qw( date_due title barcode author itemnumber );
1656 my $item_content = C4::Letters::get_item_content({
1658 item_content_fields => \@item_content_fields
1661 This function generates a tab-separated list of values for the passed item. Dates
1662 are formatted following the current setup.
1666 sub get_item_content
{
1667 my ( $params ) = @_;
1668 my $item = $params->{item
};
1669 my $dateonly = $params->{dateonly
} || 0;
1670 my $item_content_fields = $params->{item_content_fields
} || [];
1672 return unless $item;
1674 my @item_info = map {
1678 { dt
=> dt_from_string
( $item->{$_} ), dateonly
=> $dateonly } );
1682 } @
$item_content_fields;
1683 return join( "\t", @item_info ) . "\n";