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