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