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