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}(?=$)//g if $val;
 624         my $replacedby   = defined ($val) ? $val : '';
 625         ($letter->{title}  ) and do {
 626             $letter->{title}   =~ s/$replacetablefield/$replacedby/g;
 627             $letter->{title}   =~ s/$replacefield/$replacedby/g;
 628         };
 629         ($letter->{content}) and do {
 630             $letter->{content} =~ s/$replacetablefield/$replacedby/g;
 631             $letter->{content} =~ s/$replacefield/$replacedby/g;
 632         };
 633     }
 634
 635     if ($table eq 'borrowers' && $letter->{content}) {
 636         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 637             my %attr;
 638             foreach (@$attributes) {
 639                 my $code = $_->{code};
 640                 my $val  = $_->{value_description} || $_->{value};
 641                 $val =~ s/\p{P}(?=$)//g if $val;
 642                 next unless $val gt '';
 643                 $attr{$code} ||= [];
 644                 push @{ $attr{$code} }, $val;
 645             }
 646             while ( my ($code, $val_ar) = each %attr ) {
 647                 my $replacefield = "<<borrower-attribute:$code>>";
 648                 my $replacedby   = join ',', @$val_ar;
 649                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 650             }
 651         }
 652     }
 653     return $letter;
 654 }
 655
 656 =head2 EnqueueLetter
 657
 658   my $success = EnqueueLetter( { letter => $letter,
 659         borrowernumber => '12', message_transport_type => 'email' } )
 660
 661 places a letter in the message_queue database table, which will
 662 eventually get processed (sent) by the process_message_queue.pl
 663 cronjob when it calls SendQueuedMessages.
 664
 665 return message_id on success
 666
 667 =cut
 668
 669 sub EnqueueLetter {
 670     my $params = shift or return;
 671
 672     return unless exists $params->{'letter'};
 673 #   return unless exists $params->{'borrowernumber'};
 674     return unless exists $params->{'message_transport_type'};
 675
 676     my $content = $params->{letter}->{content};
 677     $content =~ s/\s+//g if(defined $content);
 678     if ( not defined $content or $content eq '' ) {
 679         warn "Trying to add an empty message to the message queue" if $debug;
 680         return;
 681     }
 682
 683     # If we have any attachments we should encode then into the body.
 684     if ( $params->{'attachments'} ) {
 685         $params->{'letter'} = _add_attachments(
 686             {   letter      => $params->{'letter'},
 687                 attachments => $params->{'attachments'},
 688                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 689             }
 690         );
 691     }
 692
 693     my $dbh       = C4::Context->dbh();
 694     my $statement = << 'ENDSQL';
 695 INSERT INTO message_queue
 696 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 697 VALUES
 698 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 699 ENDSQL
 700
 701     my $sth    = $dbh->prepare($statement);
 702     my $result = $sth->execute(
 703         $params->{'borrowernumber'},              # borrowernumber
 704         $params->{'letter'}->{'title'},           # subject
 705         $params->{'letter'}->{'content'},         # content
 706         $params->{'letter'}->{'metadata'} || '',  # metadata
 707         $params->{'letter'}->{'code'}     || '',  # letter_code
 708         $params->{'message_transport_type'},      # message_transport_type
 709         'pending',                                # status
 710         $params->{'to_address'},                  # to_address
 711         $params->{'from_address'},                # from_address
 712         $params->{'letter'}->{'content-type'},    # content_type
 713     );
 714     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 715 }
 716
 717 =head2 SendQueuedMessages ([$hashref])
 718
 719   my $sent = SendQueuedMessages( { verbose => 1 } );
 720
 721 sends all of the 'pending' items in the message queue.
 722
 723 returns number of messages sent.
 724
 725 =cut
 726
 727 sub SendQueuedMessages {
 728     my $params = shift;
 729
 730     my $unsent_messages = _get_unsent_messages();
 731     MESSAGE: foreach my $message ( @$unsent_messages ) {
 732         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 733         warn sprintf( 'sending %s message to patron: %s',
 734                       $message->{'message_transport_type'},
 735                       $message->{'borrowernumber'} || 'Admin' )
 736           if $params->{'verbose'} or $debug;
 737         # This is just begging for subclassing
 738         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 739         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 740             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 741         }
 742         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 743             _send_message_by_sms( $message );
 744         }
 745     }
 746     return scalar( @$unsent_messages );
 747 }
 748
 749 =head2 GetRSSMessages
 750
 751   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 752
 753 returns a listref of all queued RSS messages for a particular person.
 754
 755 =cut
 756
 757 sub GetRSSMessages {
 758     my $params = shift;
 759
 760     return unless $params;
 761     return unless ref $params;
 762     return unless $params->{'borrowernumber'};
 763
 764     return _get_unsent_messages( { message_transport_type => 'rss',
 765                                    limit                  => $params->{'limit'},
 766                                    borrowernumber         => $params->{'borrowernumber'}, } );
 767 }
 768
 769 =head2 GetPrintMessages
 770
 771   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 772
 773 Returns a arrayref of all queued print messages (optionally, for a particular
 774 person).
 775
 776 =cut
 777
 778 sub GetPrintMessages {
 779     my $params = shift || {};
 780
 781     return _get_unsent_messages( { message_transport_type => 'print',
 782                                    borrowernumber         => $params->{'borrowernumber'},
 783                                  } );
 784 }
 785
 786 =head2 GetQueuedMessages ([$hashref])
 787
 788   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 789
 790 fetches messages out of the message queue.
 791
 792 returns:
 793 list of hashes, each has represents a message in the message queue.
 794
 795 =cut
 796
 797 sub GetQueuedMessages {
 798     my $params = shift;
 799
 800     my $dbh = C4::Context->dbh();
 801     my $statement = << 'ENDSQL';
 802 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 803 FROM message_queue
 804 ENDSQL
 805
 806     my @query_params;
 807     my @whereclauses;
 808     if ( exists $params->{'borrowernumber'} ) {
 809         push @whereclauses, ' borrowernumber = ? ';
 810         push @query_params, $params->{'borrowernumber'};
 811     }
 812
 813     if ( @whereclauses ) {
 814         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 815     }
 816
 817     if ( defined $params->{'limit'} ) {
 818         $statement .= ' LIMIT ? ';
 819         push @query_params, $params->{'limit'};
 820     }
 821
 822     my $sth = $dbh->prepare( $statement );
 823     my $result = $sth->execute( @query_params );
 824     return $sth->fetchall_arrayref({});
 825 }
 826
 827 =head2 _add_attachements
 828
 829 named parameters:
 830 letter - the standard letter hashref
 831 attachments - listref of attachments. each attachment is a hashref of:
 832   type - the mime type, like 'text/plain'
 833   content - the actual attachment
 834   filename - the name of the attachment.
 835 message - a MIME::Lite object to attach these to.
 836
 837 returns your letter object, with the content updated.
 838
 839 =cut
 840
 841 sub _add_attachments {
 842     my $params = shift;
 843
 844     my $letter = $params->{'letter'};
 845     my $attachments = $params->{'attachments'};
 846     return $letter unless @$attachments;
 847     my $message = $params->{'message'};
 848
 849     # First, we have to put the body in as the first attachment
 850     $message->attach(
 851         Type => $letter->{'content-type'} || 'TEXT',
 852         Data => $letter->{'is_html'}
 853             ? _wrap_html($letter->{'content'}, $letter->{'title'})
 854             : $letter->{'content'},
 855     );
 856
 857     foreach my $attachment ( @$attachments ) {
 858         $message->attach(
 859             Type     => $attachment->{'type'},
 860             Data     => $attachment->{'content'},
 861             Filename => $attachment->{'filename'},
 862         );
 863     }
 864     # we're forcing list context here to get the header, not the count back from grep.
 865     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 866     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 867     $letter->{'content'} = $message->body_as_string;
 868
 869     return $letter;
 870
 871 }
 872
 873 sub _get_unsent_messages {
 874     my $params = shift;
 875
 876     my $dbh = C4::Context->dbh();
 877     my $statement = << 'ENDSQL';
 878 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
 879   FROM message_queue mq
 880   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
 881  WHERE status = ?
 882 ENDSQL
 883
 884     my @query_params = ('pending');
 885     if ( ref $params ) {
 886         if ( $params->{'message_transport_type'} ) {
 887             $statement .= ' AND message_transport_type = ? ';
 888             push @query_params, $params->{'message_transport_type'};
 889         }
 890         if ( $params->{'borrowernumber'} ) {
 891             $statement .= ' AND borrowernumber = ? ';
 892             push @query_params, $params->{'borrowernumber'};
 893         }
 894         if ( $params->{'limit'} ) {
 895             $statement .= ' limit ? ';
 896             push @query_params, $params->{'limit'};
 897         }
 898     }
 899
 900     $debug and warn "_get_unsent_messages SQL: $statement";
 901     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 902     my $sth = $dbh->prepare( $statement );
 903     my $result = $sth->execute( @query_params );
 904     return $sth->fetchall_arrayref({});
 905 }
 906
 907 sub _send_message_by_email {
 908     my $message = shift or return;
 909     my ($username, $password, $method) = @_;
 910
 911     my $to_address = $message->{to_address};
 912     unless ($to_address) {
 913         my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 914         unless ($member) {
 915             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 916             _set_message_status( { message_id => $message->{'message_id'},
 917                                    status     => 'failed' } );
 918             return;
 919         }
 920         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
 921         unless ($to_address) {
 922             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 923             # warning too verbose for this more common case?
 924             _set_message_status( { message_id => $message->{'message_id'},
 925                                    status     => 'failed' } );
 926             return;
 927         }
 928     }
 929
 930     my $utf8   = decode('MIME-Header', $message->{'subject'} );
 931     $message->{subject}= encode('MIME-Header', $utf8);
 932     my $subject = encode('utf8', $message->{'subject'});
 933     my $content = encode('utf8', $message->{'content'});
 934     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
 935     my $is_html = $content_type =~ m/html/io;
 936     my %sendmail_params = (
 937         To   => $to_address,
 938         From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'),
 939         Subject => $subject,
 940         charset => 'utf8',
 941         Message => $is_html ? _wrap_html($content, $subject) : $content,
 942         'content-type' => $content_type,
 943     );
 944     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
 945     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
 946        $sendmail_params{ Bcc } = $bcc;
 947     }
 948
 949     _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
 950     if ( sendmail( %sendmail_params ) ) {
 951         _set_message_status( { message_id => $message->{'message_id'},
 952                 status     => 'sent' } );
 953         return 1;
 954     } else {
 955         _set_message_status( { message_id => $message->{'message_id'},
 956                 status     => 'failed' } );
 957         carp $Mail::Sendmail::error;
 958         return;
 959     }
 960 }
 961
 962 sub _wrap_html {
 963     my ($content, $title) = @_;
 964
 965     my $css = C4::Context->preference("NoticeCSS") || '';
 966     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
 967     return <<EOS;
 968 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 969     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 970 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
 971 <head>
 972 <title>$title</title>
 973 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 974 $css
 975 </head>
 976 <body>
 977 $content
 978 </body>
 979 </html>
 980 EOS
 981 }
 982
 983 sub _send_message_by_sms {
 984     my $message = shift or return;
 985     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 986     return unless $member->{'smsalertnumber'};
 987
 988     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
 989                                        message     => $message->{'content'},
 990                                      } );
 991     _set_message_status( { message_id => $message->{'message_id'},
 992                            status     => ($success ? 'sent' : 'failed') } );
 993     return $success;
 994 }
 995
 996 sub _update_message_to_address {
 997     my ($id, $to)= @_;
 998     my $dbh = C4::Context->dbh();
 999     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1000 }
1001
1002 sub _set_message_status {
1003     my $params = shift or return;
1004
1005     foreach my $required_parameter ( qw( message_id status ) ) {
1006         return unless exists $params->{ $required_parameter };
1007     }
1008
1009     my $dbh = C4::Context->dbh();
1010     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1011     my $sth = $dbh->prepare( $statement );
1012     my $result = $sth->execute( $params->{'status'},
1013                                 $params->{'message_id'} );
1014     return $result;
1015 }
1016
1017
1018 1;
1019 __END__