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, $message_transport_type ) = @_;
 102     $message_transport_type ||= 'email';
 103     my %letters;
 104     my $dbh = C4::Context->dbh;
 105     my $sth;
 106     my $query = q{
 107         SELECT * FROM letter WHERE
 108     };
 109     $query .= q{ module = ? AND } if defined $cat;
 110     $query .= q{ message_transport_type = ? ORDER BY name};
 111     $sth = $dbh->prepare($query);
 112     $sth->execute((defined $cat ? $cat : ()), $message_transport_type);
 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, $message_transport_type ) = @_;
 128     $message_transport_type ||= 'email';
 129
 130
 131     if ( C4::Context->preference('IndependentBranches')
 132             and $branchcode
 133             and C4::Context->userenv ) {
 134
 135         $branchcode = C4::Context->userenv->{'branch'};
 136     }
 137     $branchcode //= '';
 138
 139     if ( my $l = $letter{$module}{$code}{$branchcode}{$message_transport_type} ) {
 140         return { %$l }; # deep copy
 141     }
 142
 143     my $dbh = C4::Context->dbh;
 144     my $sth = $dbh->prepare(q{
 145         SELECT *
 146         FROM letter
 147         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '') AND message_transport_type = ?
 148         ORDER BY branchcode DESC LIMIT 1
 149     });
 150     $sth->execute( $module, $code, $branchcode, $message_transport_type );
 151     my $line = $sth->fetchrow_hashref
 152       or return;
 153     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 154     $letter{$module}{$code}{$branchcode}{$message_transport_type} = $line;
 155     return { %$line };
 156 }
 157
 158 =head2 addalert ($borrowernumber, $type, $externalid)
 159
 160     parameters :
 161     - $borrowernumber : the number of the borrower subscribing to the alert
 162     - $type : the type of alert.
 163     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 164
 165     create an alert and return the alertid (primary key)
 166
 167 =cut
 168
 169 sub addalert {
 170     my ( $borrowernumber, $type, $externalid ) = @_;
 171     my $dbh = C4::Context->dbh;
 172     my $sth =
 173       $dbh->prepare(
 174         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 175     $sth->execute( $borrowernumber, $type, $externalid );
 176
 177     # get the alert number newly created and return it
 178     my $alertid = $dbh->{'mysql_insertid'};
 179     return $alertid;
 180 }
 181
 182 =head2 delalert ($alertid)
 183
 184     parameters :
 185     - alertid : the alert id
 186     deletes the alert
 187
 188 =cut
 189
 190 sub delalert {
 191     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 192     $debug and warn "delalert: deleting alertid $alertid";
 193     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 194     $sth->execute($alertid);
 195 }
 196
 197 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 198
 199     parameters :
 200     - $borrowernumber : the number of the borrower subscribing to the alert
 201     - $type : the type of alert.
 202     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 203     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.
 204
 205 =cut
 206
 207 sub getalert {
 208     my ( $borrowernumber, $type, $externalid ) = @_;
 209     my $dbh   = C4::Context->dbh;
 210     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE";
 211     my @bind;
 212     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 213         $query .= " borrowernumber=? AND ";
 214         push @bind, $borrowernumber;
 215     }
 216     if ($type) {
 217         $query .= " type=? AND ";
 218         push @bind, $type;
 219     }
 220     if ($externalid) {
 221         $query .= " externalid=? AND ";
 222         push @bind, $externalid;
 223     }
 224     $query =~ s/ AND $//;
 225     my $sth = $dbh->prepare($query);
 226     $sth->execute(@bind);
 227     return $sth->fetchall_arrayref({});
 228 }
 229
 230 =head2 findrelatedto($type, $externalid)
 231
 232         parameters :
 233         - $type : the type of alert
 234         - $externalid : the id of the "object" to query
 235
 236         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.
 237         When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 238
 239 =cut
 240
 241 # outmoded POD:
 242 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 243
 244 sub findrelatedto {
 245     my $type       = shift or return;
 246     my $externalid = shift or return;
 247     my $q = ($type eq 'issue'   ) ?
 248 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 249             ($type eq 'borrower') ?
 250 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 251     unless ($q) {
 252         warn "findrelatedto(): Illegal type '$type'";
 253         return;
 254     }
 255     my $sth = C4::Context->dbh->prepare($q);
 256     $sth->execute($externalid);
 257     my ($result) = $sth->fetchrow;
 258     return $result;
 259 }
 260
 261 =head2 SendAlerts
 262
 263     parameters :
 264     - $type : the type of alert
 265     - $externalid : the id of the "object" to query
 266     - $letter_code : the letter to send.
 267
 268     send an alert to all borrowers having put an alert on a given subject.
 269
 270 =cut
 271
 272 sub SendAlerts {
 273     my ( $type, $externalid, $letter_code ) = @_;
 274     my $dbh = C4::Context->dbh;
 275     if ( $type eq 'issue' ) {
 276
 277         # prepare the letter...
 278         # search the biblionumber
 279         my $sth =
 280           $dbh->prepare(
 281             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 282         $sth->execute($externalid);
 283         my ($biblionumber) = $sth->fetchrow
 284           or warn( "No subscription for '$externalid'" ),
 285              return;
 286
 287         my %letter;
 288         # find the list of borrowers to alert
 289         my $alerts = getalert( '', 'issue', $externalid );
 290         foreach (@$alerts) {
 291
 292             my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'});
 293             my $email = $borinfo->{email} or next;
 294
 295             #           warn "sending issues...";
 296             my $userenv = C4::Context->userenv;
 297             my $branchdetails = GetBranchDetail($_->{'branchcode'});
 298             my $letter = GetPreparedLetter (
 299                 module => 'serial',
 300                 letter_code => $letter_code,
 301                 branchcode => $userenv->{branch},
 302                 tables => {
 303                     'branches'    => $_->{branchcode},
 304                     'biblio'      => $biblionumber,
 305                     'biblioitems' => $biblionumber,
 306                     'borrowers'   => $borinfo,
 307                 },
 308                 want_librarian => 1,
 309             ) or return;
 310
 311             # ... then send mail
 312             my %mail = (
 313                 To      => $email,
 314                 From    => $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
 315                 Subject => Encode::encode( "utf8", "" . $letter->{title} ),
 316                 Message => Encode::encode( "utf8", "" . $letter->{content} ),
 317                 'Content-Type' => 'text/plain; charset="utf8"',
 318                 );
 319             sendmail(%mail) or carp $Mail::Sendmail::error;
 320         }
 321     }
 322     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' ) {
 323
 324         # prepare the letter...
 325         # search the biblionumber
 326         my $strsth =  $type eq 'claimacquisition'
 327             ? qq{
 328             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*,aqbooksellers.*,
 329             aqbooksellers.id AS booksellerid
 330             FROM aqorders
 331             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 332             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 333             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 334             LEFT JOIN aqbooksellers ON aqbasket.booksellerid=aqbooksellers.id
 335             WHERE aqorders.ordernumber IN (
 336             }
 337             : qq{
 338             SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
 339             aqbooksellers.id AS booksellerid
 340             FROM serial
 341             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 342             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 343             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 344             WHERE serial.serialid IN (
 345             };
 346         $strsth .= join( ",", @$externalid ) . ")";
 347         my $sthorders = $dbh->prepare($strsth);
 348         $sthorders->execute;
 349         my $dataorders = $sthorders->fetchall_arrayref( {} );
 350
 351         my $sthbookseller =
 352           $dbh->prepare("select * from aqbooksellers where id=?");
 353         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 354         my $databookseller = $sthbookseller->fetchrow_hashref;
 355
 356         my @email;
 357         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
 358         push @email, $databookseller->{contemail}       if $databookseller->{contemail};
 359         unless (@email) {
 360             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 361             return { error => "no_email" };
 362         }
 363
 364         my $userenv = C4::Context->userenv;
 365         my $letter = GetPreparedLetter (
 366             module => $type,
 367             letter_code => $letter_code,
 368             branchcode => $userenv->{branch},
 369             tables => {
 370                 'branches'    => $userenv->{branch},
 371                 'aqbooksellers' => $databookseller,
 372             },
 373             repeat => $dataorders,
 374             want_librarian => 1,
 375         ) or return;
 376
 377         # ... then send mail
 378         my %mail = (
 379             To => join( ',', @email),
 380             From           => $userenv->{emailaddress},
 381             Subject        => Encode::encode( "utf8", "" . $letter->{title} ),
 382             Message        => Encode::encode( "utf8", "" . $letter->{content} ),
 383             'Content-Type' => 'text/plain; charset="utf8"',
 384         );
 385         sendmail(%mail) or carp $Mail::Sendmail::error;
 386
 387         logaction(
 388             "ACQUISITION",
 389             $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
 390             undef,
 391             "To="
 392                 . $databookseller->{contemail}
 393                 . " Title="
 394                 . $letter->{title}
 395                 . " Content="
 396                 . $letter->{content}
 397         ) if C4::Context->preference("LetterLog");
 398     }
 399    # send an "account details" notice to a newly created user
 400     elsif ( $type eq 'members' ) {
 401         my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
 402         my $letter = GetPreparedLetter (
 403             module => 'members',
 404             letter_code => $letter_code,
 405             branchcode => $externalid->{'branchcode'},
 406             tables => {
 407                 'branches'    => $branchdetails,
 408                 'borrowers' => $externalid->{'borrowernumber'},
 409             },
 410             substitute => { 'borrowers.password' => $externalid->{'password'} },
 411             want_librarian => 1,
 412         ) or return;
 413
 414         return { error => "no_email" } unless $externalid->{'emailaddr'};
 415         my %mail = (
 416                 To      =>     $externalid->{'emailaddr'},
 417                 From    =>  $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
 418                 Subject => Encode::encode( "utf8", $letter->{'title'} ),
 419                 Message => Encode::encode( "utf8", $letter->{'content'} ),
 420                 'Content-Type' => 'text/plain; charset="utf8"',
 421         );
 422         sendmail(%mail) or carp $Mail::Sendmail::error;
 423     }
 424 }
 425
 426 =head2 GetPreparedLetter( %params )
 427
 428     %params hash:
 429       module => letter module, mandatory
 430       letter_code => letter code, mandatory
 431       branchcode => for letter selection, if missing default system letter taken
 432       tables => a hashref with table names as keys. Values are either:
 433         - a scalar - primary key value
 434         - an arrayref - primary key values
 435         - a hashref - full record
 436       substitute => custom substitution key/value pairs
 437       repeat => records to be substituted on consecutive lines:
 438         - an arrayref - tries to guess what needs substituting by
 439           taking remaining << >> tokensr; not recommended
 440         - a hashref token => @tables - replaces <token> << >> << >> </token>
 441           subtemplate for each @tables row; table is a hashref as above
 442       want_librarian => boolean,  if set to true triggers librarian details
 443         substitution from the userenv
 444     Return value:
 445       letter fields hashref (title & content useful)
 446
 447 =cut
 448
 449 sub GetPreparedLetter {
 450     my %params = @_;
 451
 452     my $module      = $params{module} or croak "No module";
 453     my $letter_code = $params{letter_code} or croak "No letter_code";
 454     my $branchcode  = $params{branchcode} || '';
 455
 456     my $letter = getletter( $module, $letter_code, $branchcode, $params{message_transport_type} )
 457         or warn( "No $module $letter_code letter"),
 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
 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 _send_message_by_sms {
1028     my $message = shift or return;
1029     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1030
1031     unless ( $member->{smsalertnumber} ) {
1032         _set_message_status( { message_id => $message->{'message_id'},
1033                                status     => 'failed' } );
1034         return;
1035     }
1036
1037     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1038                                        message     => $message->{'content'},
1039                                      } );
1040     _set_message_status( { message_id => $message->{'message_id'},
1041                            status     => ($success ? 'sent' : 'failed') } );
1042     return $success;
1043 }
1044
1045 sub _update_message_to_address {
1046     my ($id, $to)= @_;
1047     my $dbh = C4::Context->dbh();
1048     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1049 }
1050
1051 sub _set_message_status {
1052     my $params = shift or return;
1053
1054     foreach my $required_parameter ( qw( message_id status ) ) {
1055         return unless exists $params->{ $required_parameter };
1056     }
1057
1058     my $dbh = C4::Context->dbh();
1059     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1060     my $sth = $dbh->prepare( $statement );
1061     my $result = $sth->execute( $params->{'status'},
1062                                 $params->{'message_id'} );
1063     return $result;
1064 }
1065
1066
1067 1;
1068 __END__