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