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