C4/Letters.pm

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