C4/Letters.pm

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