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