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