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