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