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