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 => "" . $letter->{title},
 298                 Message => "" . $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           . 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;
 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        => "" . $letter->{title},
 362             Message        => "" . $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         my %mail = (
 395                 To      =>     $externalid->{'emailaddr'},
 396                 From    =>  $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
 397                 Subject => $letter->{'title'},
 398                 Message => $letter->{'content'},
 399                 'Content-Type' => 'text/plain; charset="utf8"',
 400         );
 401         sendmail(%mail) or carp $Mail::Sendmail::error;
 402     }
 403 }
 404
 405 =head2 GetPreparedLetter( %params )
 406
 407     %params hash:
 408       module => letter module, mandatory
 409       letter_code => letter code, mandatory
 410       branchcode => for letter selection, if missing default system letter taken
 411       tables => a hashref with table names as keys. Values are either:
 412         - a scalar - primary key value
 413         - an arrayref - primary key values
 414         - a hashref - full record
 415       substitute => custom substitution key/value pairs
 416       repeat => records to be substituted on consecutive lines:
 417         - an arrayref - tries to guess what needs substituting by
 418           taking remaining << >> tokensr; not recommended
 419         - a hashref token => @tables - replaces <token> << >> << >> </token>
 420           subtemplate for each @tables row; table is a hashref as above
 421       want_librarian => boolean,  if set to true triggers librarian details
 422         substitution from the userenv
 423     Return value:
 424       letter fields hashref (title & content useful)
 425
 426 =cut
 427
 428 sub GetPreparedLetter {
 429     my %params = @_;
 430
 431     my $module      = $params{module} or croak "No module";
 432     my $letter_code = $params{letter_code} or croak "No letter_code";
 433     my $branchcode  = $params{branchcode} || '';
 434
 435     my $letter = getletter( $module, $letter_code, $branchcode )
 436         or warn( "No $module $letter_code letter"),
 437             return;
 438
 439     my $tables = $params{tables};
 440     my $substitute = $params{substitute};
 441     my $repeat = $params{repeat};
 442     $tables || $substitute || $repeat
 443       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
 444          return;
 445     my $want_librarian = $params{want_librarian};
 446
 447     if ($substitute) {
 448         while ( my ($token, $val) = each %$substitute ) {
 449             $letter->{title} =~ s/<<$token>>/$val/g;
 450             $letter->{content} =~ s/<<$token>>/$val/g;
 451        }
 452     }
 453
 454     if ($want_librarian) {
 455         # parsing librarian name
 456         my $userenv = C4::Context->userenv;
 457         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 458         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 459         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 460     }
 461
 462     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 463
 464     if ($repeat) {
 465         if (ref ($repeat) eq 'ARRAY' ) {
 466             $repeat_no_enclosing_tags = $repeat;
 467         } else {
 468             $repeat_enclosing_tags = $repeat;
 469         }
 470     }
 471
 472     if ($repeat_enclosing_tags) {
 473         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 474             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 475                 my $subcontent = $1;
 476                 my @lines = map {
 477                     my %subletter = ( title => '', content => $subcontent );
 478                     _substitute_tables( \%subletter, $_ );
 479                     $subletter{content};
 480                 } @$tag_tables;
 481                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 482             }
 483         }
 484     }
 485
 486     if ($tables) {
 487         _substitute_tables( $letter, $tables );
 488     }
 489
 490     if ($repeat_no_enclosing_tags) {
 491         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 492             my $line = $&;
 493             my $i = 1;
 494             my @lines = map {
 495                 my $c = $line;
 496                 $c =~ s/<<count>>/$i/go;
 497                 foreach my $field ( keys %{$_} ) {
 498                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 499                 }
 500                 $i++;
 501                 $c;
 502             } @$repeat_no_enclosing_tags;
 503
 504             my $replaceby = join( "\n", @lines );
 505             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 506         }
 507     }
 508
 509     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 510 #   $letter->{content} =~ s/<<[^>]*>>//go;
 511
 512     return $letter;
 513 }
 514
 515 sub _substitute_tables {
 516     my ( $letter, $tables ) = @_;
 517     while ( my ($table, $param) = each %$tables ) {
 518         next unless $param;
 519
 520         my $ref = ref $param;
 521
 522         my $values;
 523         if ($ref && $ref eq 'HASH') {
 524             $values = $param;
 525         }
 526         else {
 527             my @pk;
 528             my $sth = _parseletter_sth($table);
 529             unless ($sth) {
 530                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 531                 return;
 532             }
 533             $sth->execute( $ref ? @$param : $param );
 534
 535             $values = $sth->fetchrow_hashref;
 536         }
 537
 538         _parseletter ( $letter, $table, $values );
 539     }
 540 }
 541
 542 my %handles = ();
 543 sub _parseletter_sth {
 544     my $table = shift;
 545     unless ($table) {
 546         carp "ERROR: _parseletter_sth() called without argument (table)";
 547         return;
 548     }
 549     # check cache first
 550     (defined $handles{$table}) and return $handles{$table};
 551     my $query =
 552     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                      :
 553     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                      :
 554     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                      :
 555     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                      :
 556     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
 557     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                      :
 558     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                      :
 559     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                      :
 560     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                      :
 561     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                      :
 562     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                      :
 563     undef ;
 564     unless ($query) {
 565         warn "ERROR: No _parseletter_sth query for table '$table'";
 566         return;     # nothing to get
 567     }
 568     unless ($handles{$table} = C4::Context->dbh->prepare($query)) {
 569         warn "ERROR: Failed to prepare query: '$query'";
 570         return;
 571     }
 572     return $handles{$table};    # now cache is populated for that $table
 573 }
 574
 575 =head2 _parseletter($letter, $table, $values)
 576
 577     parameters :
 578     - $letter : a hash to letter fields (title & content useful)
 579     - $table : the Koha table to parse.
 580     - $values : table record hashref
 581     parse all fields from a table, and replace values in title & content with the appropriate value
 582     (not exported sub, used only internally)
 583
 584 =cut
 585
 586 my %columns = ();
 587 sub _parseletter {
 588     my ( $letter, $table, $values ) = @_;
 589
 590     # TEMPORARY hack until the expirationdate column is added to reserves
 591     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 592         my @waitingdate = split /-/, $values->{'waitingdate'};
 593
 594         $values->{'expirationdate'} = C4::Dates->new(
 595             sprintf(
 596                 '%04d-%02d-%02d',
 597                 Add_Delta_Days( @waitingdate, C4::Context->preference( 'ReservesMaxPickUpDelay' ) )
 598             ),
 599             'iso'
 600         )->output();
 601     }
 602
 603     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 604         my @da = localtime();
 605         my $todaysdate = "$da[2]:$da[1]  " . C4::Dates->today();
 606         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 607     }
 608
 609     # and get all fields from the table
 610 #   my $columns = $columns{$table};
 611 #   unless ($columns) {
 612 #       $columns = $columns{$table} =  C4::Context->dbh->selectcol_arrayref("SHOW COLUMNS FROM $table");
 613 #   }
 614 #   foreach my $field (@$columns) {
 615
 616     while ( my ($field, $val) = each %$values ) {
 617         my $replacetablefield = "<<$table.$field>>";
 618         my $replacefield = "<<$field>>";
 619         $val =~ s/\p{P}(?=$)//g if $val;
 620         my $replacedby   = defined ($val) ? $val : '';
 621         ($letter->{title}  ) and do {
 622             $letter->{title}   =~ s/$replacetablefield/$replacedby/g;
 623             $letter->{title}   =~ s/$replacefield/$replacedby/g;
 624         };
 625         ($letter->{content}) and do {
 626             $letter->{content} =~ s/$replacetablefield/$replacedby/g;
 627             $letter->{content} =~ s/$replacefield/$replacedby/g;
 628         };
 629     }
 630
 631     if ($table eq 'borrowers' && $letter->{content}) {
 632         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 633             my %attr;
 634             foreach (@$attributes) {
 635                 my $code = $_->{code};
 636                 my $val  = $_->{value_description} || $_->{value};
 637                 $val =~ s/\p{P}(?=$)//g if $val;
 638                 next unless $val gt '';
 639                 $attr{$code} ||= [];
 640                 push @{ $attr{$code} }, $val;
 641             }
 642             while ( my ($code, $val_ar) = each %attr ) {
 643                 my $replacefield = "<<borrower-attribute:$code>>";
 644                 my $replacedby   = join ',', @$val_ar;
 645                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 646             }
 647         }
 648     }
 649     return $letter;
 650 }
 651
 652 =head2 EnqueueLetter
 653
 654   my $success = EnqueueLetter( { letter => $letter,
 655         borrowernumber => '12', message_transport_type => 'email' } )
 656
 657 places a letter in the message_queue database table, which will
 658 eventually get processed (sent) by the process_message_queue.pl
 659 cronjob when it calls SendQueuedMessages.
 660
 661 return true on success
 662
 663 =cut
 664
 665 sub EnqueueLetter ($) {
 666     my $params = shift or return undef;
 667
 668     return unless exists $params->{'letter'};
 669     return unless exists $params->{'borrowernumber'};
 670     return unless exists $params->{'message_transport_type'};
 671
 672     # If we have any attachments we should encode then into the body.
 673     if ( $params->{'attachments'} ) {
 674         $params->{'letter'} = _add_attachments(
 675             {   letter      => $params->{'letter'},
 676                 attachments => $params->{'attachments'},
 677                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 678             }
 679         );
 680     }
 681
 682     my $dbh       = C4::Context->dbh();
 683     my $statement = << 'ENDSQL';
 684 INSERT INTO message_queue
 685 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 686 VALUES
 687 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 688 ENDSQL
 689
 690     my $sth    = $dbh->prepare($statement);
 691     my $result = $sth->execute(
 692         $params->{'borrowernumber'},              # borrowernumber
 693         $params->{'letter'}->{'title'},           # subject
 694         $params->{'letter'}->{'content'},         # content
 695         $params->{'letter'}->{'metadata'} || '',  # metadata
 696         $params->{'letter'}->{'code'}     || '',  # letter_code
 697         $params->{'message_transport_type'},      # message_transport_type
 698         'pending',                                # status
 699         $params->{'to_address'},                  # to_address
 700         $params->{'from_address'},                # from_address
 701         $params->{'letter'}->{'content-type'},    # content_type
 702     );
 703     return $result;
 704 }
 705
 706 =head2 SendQueuedMessages ([$hashref])
 707
 708   my $sent = SendQueuedMessages( { verbose => 1 } );
 709
 710 sends all of the 'pending' items in the message queue.
 711
 712 returns number of messages sent.
 713
 714 =cut
 715
 716 sub SendQueuedMessages (;$) {
 717     my $params = shift;
 718
 719     my $unsent_messages = _get_unsent_messages();
 720     MESSAGE: foreach my $message ( @$unsent_messages ) {
 721         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 722         warn sprintf( 'sending %s message to patron: %s',
 723                       $message->{'message_transport_type'},
 724                       $message->{'borrowernumber'} || 'Admin' )
 725           if $params->{'verbose'} or $debug;
 726         # This is just begging for subclassing
 727         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 728         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 729             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 730         }
 731         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 732             _send_message_by_sms( $message );
 733         }
 734     }
 735     return scalar( @$unsent_messages );
 736 }
 737
 738 =head2 GetRSSMessages
 739
 740   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 741
 742 returns a listref of all queued RSS messages for a particular person.
 743
 744 =cut
 745
 746 sub GetRSSMessages {
 747     my $params = shift;
 748
 749     return unless $params;
 750     return unless ref $params;
 751     return unless $params->{'borrowernumber'};
 752
 753     return _get_unsent_messages( { message_transport_type => 'rss',
 754                                    limit                  => $params->{'limit'},
 755                                    borrowernumber         => $params->{'borrowernumber'}, } );
 756 }
 757
 758 =head2 GetPrintMessages
 759
 760   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 761
 762 Returns a arrayref of all queued print messages (optionally, for a particular
 763 person).
 764
 765 =cut
 766
 767 sub GetPrintMessages {
 768     my $params = shift || {};
 769
 770     return _get_unsent_messages( { message_transport_type => 'print',
 771                                    borrowernumber         => $params->{'borrowernumber'}, } );
 772 }
 773
 774 =head2 GetQueuedMessages ([$hashref])
 775
 776   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 777
 778 fetches messages out of the message queue.
 779
 780 returns:
 781 list of hashes, each has represents a message in the message queue.
 782
 783 =cut
 784
 785 sub GetQueuedMessages {
 786     my $params = shift;
 787
 788     my $dbh = C4::Context->dbh();
 789     my $statement = << 'ENDSQL';
 790 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 791 FROM message_queue
 792 ENDSQL
 793
 794     my @query_params;
 795     my @whereclauses;
 796     if ( exists $params->{'borrowernumber'} ) {
 797         push @whereclauses, ' borrowernumber = ? ';
 798         push @query_params, $params->{'borrowernumber'};
 799     }
 800
 801     if ( @whereclauses ) {
 802         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 803     }
 804
 805     if ( defined $params->{'limit'} ) {
 806         $statement .= ' LIMIT ? ';
 807         push @query_params, $params->{'limit'};
 808     }
 809
 810     my $sth = $dbh->prepare( $statement );
 811     my $result = $sth->execute( @query_params );
 812     return $sth->fetchall_arrayref({});
 813 }
 814
 815 =head2 _add_attachements
 816
 817 named parameters:
 818 letter - the standard letter hashref
 819 attachments - listref of attachments. each attachment is a hashref of:
 820   type - the mime type, like 'text/plain'
 821   content - the actual attachment
 822   filename - the name of the attachment.
 823 message - a MIME::Lite object to attach these to.
 824
 825 returns your letter object, with the content updated.
 826
 827 =cut
 828
 829 sub _add_attachments {
 830     my $params = shift;
 831
 832     my $letter = $params->{'letter'};
 833     my $attachments = $params->{'attachments'};
 834     return $letter unless @$attachments;
 835     my $message = $params->{'message'};
 836
 837     # First, we have to put the body in as the first attachment
 838     $message->attach(
 839         Type => $letter->{'content-type'} || 'TEXT',
 840         Data => $letter->{'is_html'}
 841             ? _wrap_html($letter->{'content'}, $letter->{'title'})
 842             : $letter->{'content'},
 843     );
 844
 845     foreach my $attachment ( @$attachments ) {
 846         $message->attach(
 847             Type     => $attachment->{'type'},
 848             Data     => $attachment->{'content'},
 849             Filename => $attachment->{'filename'},
 850         );
 851     }
 852     # we're forcing list context here to get the header, not the count back from grep.
 853     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 854     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 855     $letter->{'content'} = $message->body_as_string;
 856
 857     return $letter;
 858
 859 }
 860
 861 sub _get_unsent_messages (;$) {
 862     my $params = shift;
 863
 864     my $dbh = C4::Context->dbh();
 865     my $statement = << 'ENDSQL';
 866 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, from_address, to_address, content_type
 867   FROM message_queue
 868  WHERE status = ?
 869 ENDSQL
 870
 871     my @query_params = ('pending');
 872     if ( ref $params ) {
 873         if ( $params->{'message_transport_type'} ) {
 874             $statement .= ' AND message_transport_type = ? ';
 875             push @query_params, $params->{'message_transport_type'};
 876         }
 877         if ( $params->{'borrowernumber'} ) {
 878             $statement .= ' AND borrowernumber = ? ';
 879             push @query_params, $params->{'borrowernumber'};
 880         }
 881         if ( $params->{'limit'} ) {
 882             $statement .= ' limit ? ';
 883             push @query_params, $params->{'limit'};
 884         }
 885     }
 886     $debug and warn "_get_unsent_messages SQL: $statement";
 887     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 888     my $sth = $dbh->prepare( $statement );
 889     my $result = $sth->execute( @query_params );
 890     return $sth->fetchall_arrayref({});
 891 }
 892
 893 sub _send_message_by_email ($;$$$) {
 894     my $message = shift or return;
 895     my ($username, $password, $method) = @_;
 896
 897     my $to_address = $message->{to_address};
 898     unless ($to_address) {
 899         my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 900         unless ($member) {
 901             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 902             _set_message_status( { message_id => $message->{'message_id'},
 903                                    status     => 'failed' } );
 904             return;
 905         }
 906         my $which_address = C4::Context->preference('AutoEmailPrimaryAddress');
 907         # If the system preference is set to 'first valid' (value == OFF), look up email address
 908         if ($which_address eq 'OFF') {
 909             $to_address = GetFirstValidEmailAddress( $message->{'borrowernumber'} );
 910         } else {
 911             $to_address = $member->{$which_address};
 912         }
 913         unless ($to_address) {
 914             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 915             # warning too verbose for this more common case?
 916             _set_message_status( { message_id => $message->{'message_id'},
 917                                    status     => 'failed' } );
 918             return;
 919         }
 920     }
 921
 922     my $utf8   = decode('MIME-Header', $message->{'subject'} );
 923     $message->{subject}= encode('MIME-Header', $utf8);
 924     my $subject = encode('utf8', $message->{'subject'});
 925     my $content = encode('utf8', $message->{'content'});
 926     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
 927     my $is_html = $content_type =~ m/html/io;
 928     my %sendmail_params = (
 929         To   => $to_address,
 930         From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'),
 931         Subject => $subject,
 932         charset => 'utf8',
 933         Message => $is_html ? _wrap_html($content, $subject) : $content,
 934         'content-type' => $content_type,
 935     );
 936     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
 937     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
 938        $sendmail_params{ Bcc } = $bcc;
 939     }
 940
 941     _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
 942     if ( sendmail( %sendmail_params ) ) {
 943         _set_message_status( { message_id => $message->{'message_id'},
 944                 status     => 'sent' } );
 945         return 1;
 946     } else {
 947         _set_message_status( { message_id => $message->{'message_id'},
 948                 status     => 'failed' } );
 949         carp $Mail::Sendmail::error;
 950         return;
 951     }
 952 }
 953
 954 sub _wrap_html {
 955     my ($content, $title) = @_;
 956
 957     my $css = C4::Context->preference("NoticeCSS") || '';
 958     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
 959     return <<EOS;
 960 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 961     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 962 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
 963 <head>
 964 <title>$title</title>
 965 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 966 $css
 967 </head>
 968 <body>
 969 $content
 970 </body>
 971 </html>
 972 EOS
 973 }
 974
 975 sub _send_message_by_sms ($) {
 976     my $message = shift or return undef;
 977     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 978     return unless $member->{'smsalertnumber'};
 979
 980     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
 981                                        message     => $message->{'content'},
 982                                      } );
 983     _set_message_status( { message_id => $message->{'message_id'},
 984                            status     => ($success ? 'sent' : 'failed') } );
 985     return $success;
 986 }
 987
 988 sub _update_message_to_address {
 989     my ($id, $to)= @_;
 990     my $dbh = C4::Context->dbh();
 991     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
 992 }
 993
 994 sub _set_message_status ($) {
 995     my $params = shift or return undef;
 996
 997     foreach my $required_parameter ( qw( message_id status ) ) {
 998         return undef unless exists $params->{ $required_parameter };
 999     }
1000
1001     my $dbh = C4::Context->dbh();
1002     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1003     my $sth = $dbh->prepare( $statement );
1004     my $result = $sth->execute( $params->{'status'},
1005                                 $params->{'message_id'} );
1006     return $result;
1007 }
1008
1009
1010 1;
1011 __END__