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 a list of hashes
 855
 856 =cut
 857
 858 sub GetMessageTransportTypes {
 859     my $dbh = C4::Context->dbh();
 860     my $sth = $dbh->prepare("
 861         SELECT message_transport_type
 862         FROM message_transport_types
 863         ORDER BY message_transport_type
 864     ");
 865     $sth->execute;
 866     my @mtts = map{
 867         $_->[0]
 868     } @{ $sth->fetchall_arrayref() };
 869     return \@mtts;
 870 }
 871
 872 =head2 _add_attachements
 873
 874 named parameters:
 875 letter - the standard letter hashref
 876 attachments - listref of attachments. each attachment is a hashref of:
 877   type - the mime type, like 'text/plain'
 878   content - the actual attachment
 879   filename - the name of the attachment.
 880 message - a MIME::Lite object to attach these to.
 881
 882 returns your letter object, with the content updated.
 883
 884 =cut
 885
 886 sub _add_attachments {
 887     my $params = shift;
 888
 889     my $letter = $params->{'letter'};
 890     my $attachments = $params->{'attachments'};
 891     return $letter unless @$attachments;
 892     my $message = $params->{'message'};
 893
 894     # First, we have to put the body in as the first attachment
 895     $message->attach(
 896         Type => $letter->{'content-type'} || 'TEXT',
 897         Data => $letter->{'is_html'}
 898             ? _wrap_html($letter->{'content'}, $letter->{'title'})
 899             : $letter->{'content'},
 900     );
 901
 902     foreach my $attachment ( @$attachments ) {
 903         $message->attach(
 904             Type     => $attachment->{'type'},
 905             Data     => $attachment->{'content'},
 906             Filename => $attachment->{'filename'},
 907         );
 908     }
 909     # we're forcing list context here to get the header, not the count back from grep.
 910     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 911     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 912     $letter->{'content'} = $message->body_as_string;
 913
 914     return $letter;
 915
 916 }
 917
 918 sub _get_unsent_messages {
 919     my $params = shift;
 920
 921     my $dbh = C4::Context->dbh();
 922     my $statement = << 'ENDSQL';
 923 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
 924   FROM message_queue mq
 925   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
 926  WHERE status = ?
 927 ENDSQL
 928
 929     my @query_params = ('pending');
 930     if ( ref $params ) {
 931         if ( $params->{'message_transport_type'} ) {
 932             $statement .= ' AND message_transport_type = ? ';
 933             push @query_params, $params->{'message_transport_type'};
 934         }
 935         if ( $params->{'borrowernumber'} ) {
 936             $statement .= ' AND borrowernumber = ? ';
 937             push @query_params, $params->{'borrowernumber'};
 938         }
 939         if ( $params->{'limit'} ) {
 940             $statement .= ' limit ? ';
 941             push @query_params, $params->{'limit'};
 942         }
 943     }
 944
 945     $debug and warn "_get_unsent_messages SQL: $statement";
 946     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 947     my $sth = $dbh->prepare( $statement );
 948     my $result = $sth->execute( @query_params );
 949     return $sth->fetchall_arrayref({});
 950 }
 951
 952 sub _send_message_by_email {
 953     my $message = shift or return;
 954     my ($username, $password, $method) = @_;
 955
 956     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 957     my $to_address = $message->{'to_address'};
 958     unless ($to_address) {
 959         unless ($member) {
 960             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 961             _set_message_status( { message_id => $message->{'message_id'},
 962                                    status     => 'failed' } );
 963             return;
 964         }
 965         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
 966         unless ($to_address) {
 967             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 968             # warning too verbose for this more common case?
 969             _set_message_status( { message_id => $message->{'message_id'},
 970                                    status     => 'failed' } );
 971             return;
 972         }
 973     }
 974
 975     my $utf8   = decode('MIME-Header', $message->{'subject'} );
 976     $message->{subject}= encode('MIME-Header', $utf8);
 977     my $subject = encode('utf8', $message->{'subject'});
 978     my $content = encode('utf8', $message->{'content'});
 979     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
 980     my $is_html = $content_type =~ m/html/io;
 981
 982     my $branch_email = ( $member ) ? GetBranchDetail( $member->{'branchcode'} )->{'branchemail'} : undef;
 983
 984     my %sendmail_params = (
 985         To   => $to_address,
 986         From => $message->{'from_address'} || $branch_email || C4::Context->preference('KohaAdminEmailAddress'),
 987         Subject => $subject,
 988         charset => 'utf8',
 989         Message => $is_html ? _wrap_html($content, $subject) : $content,
 990         'content-type' => $content_type,
 991     );
 992     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
 993     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
 994        $sendmail_params{ Bcc } = $bcc;
 995     }
 996
 997     _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
 998     if ( sendmail( %sendmail_params ) ) {
 999         _set_message_status( { message_id => $message->{'message_id'},
1000                 status     => 'sent' } );
1001         return 1;
1002     } else {
1003         _set_message_status( { message_id => $message->{'message_id'},
1004                 status     => 'failed' } );
1005         carp $Mail::Sendmail::error;
1006         return;
1007     }
1008 }
1009
1010 sub _wrap_html {
1011     my ($content, $title) = @_;
1012
1013     my $css = C4::Context->preference("NoticeCSS") || '';
1014     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1015     return <<EOS;
1016 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1017     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1018 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1019 <head>
1020 <title>$title</title>
1021 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1022 $css
1023 </head>
1024 <body>
1025 $content
1026 </body>
1027 </html>
1028 EOS
1029 }
1030
1031 sub _send_message_by_sms {
1032     my $message = shift or return;
1033     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1034
1035     unless ( $member->{smsalertnumber} ) {
1036         _set_message_status( { message_id => $message->{'message_id'},
1037                                status     => 'failed' } );
1038         return;
1039     }
1040
1041     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1042                                        message     => $message->{'content'},
1043                                      } );
1044     _set_message_status( { message_id => $message->{'message_id'},
1045                            status     => ($success ? 'sent' : 'failed') } );
1046     return $success;
1047 }
1048
1049 sub _update_message_to_address {
1050     my ($id, $to)= @_;
1051     my $dbh = C4::Context->dbh();
1052     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1053 }
1054
1055 sub _set_message_status {
1056     my $params = shift or return;
1057
1058     foreach my $required_parameter ( qw( message_id status ) ) {
1059         return unless exists $params->{ $required_parameter };
1060     }
1061
1062     my $dbh = C4::Context->dbh();
1063     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1064     my $sth = $dbh->prepare( $statement );
1065     my $result = $sth->execute( $params->{'status'},
1066                                 $params->{'message_id'} );
1067     return $result;
1068 }
1069
1070
1071 1;
1072 __END__