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