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