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