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 use Encode;
  26 use Carp;
  27
  28 use C4::Members;
  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 &getletter &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 sub getletter ($$) {
 120     my ( $module, $code ) = @_;
 121     my $dbh = C4::Context->dbh;
 122     my $sth = $dbh->prepare("select * from letter where module=? and code=?");
 123     $sth->execute( $module, $code );
 124     my $line = $sth->fetchrow_hashref;
 125     return $line;
 126 }
 127
 128 =head2 addalert ($borrowernumber, $type, $externalid)
 129
 130     parameters :
 131     - $borrowernumber : the number of the borrower subscribing to the alert
 132     - $type : the type of alert.
 133     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 134
 135     create an alert and return the alertid (primary key)
 136
 137 =cut
 138
 139 sub addalert ($$$) {
 140     my ( $borrowernumber, $type, $externalid ) = @_;
 141     my $dbh = C4::Context->dbh;
 142     my $sth =
 143       $dbh->prepare(
 144         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 145     $sth->execute( $borrowernumber, $type, $externalid );
 146
 147     # get the alert number newly created and return it
 148     my $alertid = $dbh->{'mysql_insertid'};
 149     return $alertid;
 150 }
 151
 152 =head2 delalert ($alertid)
 153
 154     parameters :
 155     - alertid : the alert id
 156     deletes the alert
 157
 158 =cut
 159
 160 sub delalert ($) {
 161     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 162     $debug and warn "delalert: deleting alertid $alertid";
 163     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 164     $sth->execute($alertid);
 165 }
 166
 167 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 168
 169     parameters :
 170     - $borrowernumber : the number of the borrower subscribing to the alert
 171     - $type : the type of alert.
 172     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 173     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.
 174
 175 =cut
 176
 177 sub getalert (;$$$) {
 178     my ( $borrowernumber, $type, $externalid ) = @_;
 179     my $dbh   = C4::Context->dbh;
 180     my $query = "SELECT * FROM alert WHERE";
 181     my @bind;
 182     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 183         $query .= " borrowernumber=? AND ";
 184         push @bind, $borrowernumber;
 185     }
 186     if ($type) {
 187         $query .= " type=? AND ";
 188         push @bind, $type;
 189     }
 190     if ($externalid) {
 191         $query .= " externalid=? AND ";
 192         push @bind, $externalid;
 193     }
 194     $query =~ s/ AND $//;
 195     my $sth = $dbh->prepare($query);
 196     $sth->execute(@bind);
 197     return $sth->fetchall_arrayref({});
 198 }
 199
 200 =head2 findrelatedto($type, $externalid)
 201
 202         parameters :
 203         - $type : the type of alert
 204         - $externalid : the id of the "object" to query
 205
 206         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.
 207         When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 208
 209 =cut
 210
 211 # outmoded POD:
 212 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 213
 214 sub findrelatedto ($$) {
 215     my $type       = shift or return undef;
 216     my $externalid = shift or return undef;
 217     my $q = ($type eq 'issue'   ) ?
 218 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 219             ($type eq 'borrower') ?
 220 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 221     unless ($q) {
 222         warn "findrelatedto(): Illegal type '$type'";
 223         return undef;
 224     }
 225     my $sth = C4::Context->dbh->prepare($q);
 226     $sth->execute($externalid);
 227     my ($result) = $sth->fetchrow;
 228     return $result;
 229 }
 230
 231 =head2 SendAlerts
 232
 233     parameters :
 234     - $type : the type of alert
 235     - $externalid : the id of the "object" to query
 236     - $letter : the letter to send.
 237
 238     send an alert to all borrowers having put an alert on a given subject.
 239
 240 =cut
 241
 242 sub SendAlerts {
 243     my ( $type, $externalid, $letter ) = @_;
 244     my $dbh = C4::Context->dbh;
 245     if ( $type eq 'issue' ) {
 246
 247         #               warn "sending issues...";
 248         my $letter = getletter( 'serial', $letter );
 249
 250         # prepare the letter...
 251         # search the biblionumber
 252         my $sth =
 253           $dbh->prepare(
 254             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 255         $sth->execute($externalid);
 256         my ($biblionumber) = $sth->fetchrow;
 257
 258         # parsing branch info
 259         my $userenv = C4::Context->userenv;
 260         parseletter( $letter, 'branches', $userenv->{branch} );
 261
 262         # parsing librarian name
 263         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g;
 264         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g;
 265         $letter->{content} =~
 266           s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g;
 267
 268         # parsing biblio information
 269         parseletter( $letter, 'biblio',      $biblionumber );
 270         parseletter( $letter, 'biblioitems', $biblionumber );
 271
 272         # find the list of borrowers to alert
 273         my $alerts = getalert( '', 'issue', $externalid );
 274         foreach (@$alerts) {
 275
 276             # and parse borrower ...
 277             my $innerletter = $letter;
 278             my $borinfo = GetMember( 'borrowernumber' => $_->{'borrowernumber'});
 279             parseletter( $innerletter, 'borrowers', $_->{'borrowernumber'} );
 280
 281             # ... then send mail
 282             if ( $borinfo->{email} ) {
 283                 my %mail = (
 284                     To      => $borinfo->{email},
 285                     From    => $borinfo->{email},
 286                     Subject => "" . $innerletter->{title},
 287                     Message => "" . $innerletter->{content},
 288                     'Content-Type' => 'text/plain; charset="utf8"',
 289                     );
 290                 sendmail(%mail) or carp $Mail::Sendmail::error;
 291
 292 # warn "sending to $mail{To} From $mail{From} subj $mail{Subject} Mess $mail{Message}";
 293             }
 294         }
 295     }
 296     elsif ( $type eq 'claimacquisition' ) {
 297
 298         #               warn "sending issues...";
 299         my $letter = getletter( 'claimacquisition', $letter );
 300
 301         # prepare the letter...
 302         # search the biblionumber
 303         my $strsth =
 304 "select aqorders.*,aqbasket.*,biblio.*,biblioitems.* from aqorders LEFT JOIN aqbasket on aqbasket.basketno=aqorders.basketno LEFT JOIN biblio on aqorders.biblionumber=biblio.biblionumber LEFT JOIN biblioitems on aqorders.biblioitemnumber=biblioitems.biblioitemnumber where aqorders.ordernumber IN ("
 305           . join( ",", @$externalid ) . ")";
 306         my $sthorders = $dbh->prepare($strsth);
 307         $sthorders->execute;
 308         my $dataorders = $sthorders->fetchall_arrayref( {} );
 309         parseletter( $letter, 'aqbooksellers',
 310             $dataorders->[0]->{booksellerid} );
 311         my $sthbookseller =
 312           $dbh->prepare("select * from aqbooksellers where id=?");
 313         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 314         my $databookseller = $sthbookseller->fetchrow_hashref;
 315
 316         # parsing branch info
 317         my $userenv = C4::Context->userenv;
 318         parseletter( $letter, 'branches', $userenv->{branch} );
 319
 320         # parsing librarian name
 321         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g;
 322         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g;
 323         $letter->{content} =~
 324           s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g;
 325         foreach my $data (@$dataorders) {
 326             my $line = $1 if ( $letter->{content} =~ m/(<<.*>>)/ );
 327             foreach my $field ( keys %$data ) {
 328                 $line =~ s/(<<[^\.]+.$field>>)/$data->{$field}/;
 329             }
 330             $letter->{content} =~ s/(<<.*>>)/$line\n$1/;
 331         }
 332         $letter->{content} =~ s/<<[^>]*>>//g;
 333         my $innerletter = $letter;
 334
 335         # ... then send mail
 336         if (   $databookseller->{bookselleremail}
 337             || $databookseller->{contemail} )
 338         {
 339             my %mail = (
 340                 To => $databookseller->{bookselleremail}
 341                   . (
 342                     $databookseller->{contemail}
 343                     ? "," . $databookseller->{contemail}
 344                     : ""
 345                   ),
 346                 From           => $userenv->{emailaddress},
 347                 Subject        => "" . $innerletter->{title},
 348                 Message        => "" . $innerletter->{content},
 349                 'Content-Type' => 'text/plain; charset="utf8"',
 350             );
 351             sendmail(%mail) or carp $Mail::Sendmail::error;
 352         }
 353         if ( C4::Context->preference("LetterLog") ) {
 354             logaction(
 355                 "ACQUISITION",
 356                 "Send Acquisition claim letter",
 357                 "",
 358                 "order list : "
 359                   . join( ",", @$externalid )
 360                   . "\n$innerletter->{title}\n$innerletter->{content}"
 361             );
 362         }
 363     }
 364     elsif ( $type eq 'claimissues' ) {
 365
 366         #               warn "sending issues...";
 367         my $letter = getletter( 'claimissues', $letter );
 368
 369         # prepare the letter...
 370         # search the biblionumber
 371         my $strsth =
 372 "select serial.*,subscription.*, biblio.* from serial LEFT JOIN subscription on serial.subscriptionid=subscription.subscriptionid LEFT JOIN biblio on serial.biblionumber=biblio.biblionumber where serial.serialid IN ("
 373           . join( ",", @$externalid ) . ")";
 374         my $sthorders = $dbh->prepare($strsth);
 375         $sthorders->execute;
 376         my $dataorders = $sthorders->fetchall_arrayref( {} );
 377         parseletter( $letter, 'aqbooksellers',
 378             $dataorders->[0]->{aqbooksellerid} );
 379         my $sthbookseller =
 380           $dbh->prepare("select * from aqbooksellers where id=?");
 381         $sthbookseller->execute( $dataorders->[0]->{aqbooksellerid} );
 382         my $databookseller = $sthbookseller->fetchrow_hashref;
 383
 384         # parsing branch info
 385         my $userenv = C4::Context->userenv;
 386         parseletter( $letter, 'branches', $userenv->{branch} );
 387
 388         # parsing librarian name
 389         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/g;
 390         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/g;
 391         $letter->{content} =~
 392           s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/g;
 393         foreach my $data (@$dataorders) {
 394             my $line = $1 if ( $letter->{content} =~ m/(<<.*>>)/ );
 395             foreach my $field ( keys %$data ) {
 396                 $line =~ s/(<<[^\.]+.$field>>)/$data->{$field}/;
 397             }
 398             $letter->{content} =~ s/(<<.*>>)/$line\n$1/;
 399         }
 400         $letter->{content} =~ s/<<[^>]*>>//g;
 401         my $innerletter = $letter;
 402
 403         # ... then send mail
 404         if (   $databookseller->{bookselleremail}
 405             || $databookseller->{contemail} ) {
 406             my $mail_to = $databookseller->{bookselleremail};
 407             if ($databookseller->{contemail}) {
 408                 if (!$mail_to) {
 409                     $mail_to = $databookseller->{contemail};
 410                 } else {
 411                     $mail_to .= q|,|;
 412                     $mail_to .= $databookseller->{contemail};
 413                 }
 414             }
 415             my $mail_subj = $innerletter->{title};
 416             my $mail_msg  = $innerletter->{content};
 417             $mail_msg  ||= q{};
 418             $mail_subj ||= q{};
 419
 420             my %mail = (
 421                 To => $mail_to,
 422                 From    => $userenv->{emailaddress},
 423                 Subject => $mail_subj,
 424                 Message => $mail_msg,
 425                 'Content-Type' => 'text/plain; charset="utf8"',
 426             );
 427             sendmail(%mail) or carp $Mail::Sendmail::error;
 428             logaction(
 429                 "ACQUISITION",
 430                 "CLAIM ISSUE",
 431                 undef,
 432                 "To="
 433                   . $databookseller->{contemail}
 434                   . " Title="
 435                   . $innerletter->{title}
 436                   . " Content="
 437                   . $innerletter->{content}
 438             ) if C4::Context->preference("LetterLog");
 439         }
 440     }
 441    # send an "account details" notice to a newly created user
 442     elsif ( $type eq 'members' ) {
 443         $letter->{content} =~ s/<<borrowers.title>>/$externalid->{'title'}/g;
 444         $letter->{content} =~ s/<<borrowers.firstname>>/$externalid->{'firstname'}/g;
 445         $letter->{content} =~ s/<<borrowers.surname>>/$externalid->{'surname'}/g;
 446         $letter->{content} =~ s/<<borrowers.userid>>/$externalid->{'userid'}/g;
 447         $letter->{content} =~ s/<<borrowers.password>>/$externalid->{'password'}/g;
 448
 449         my %mail = (
 450                 To      =>     $externalid->{'emailaddr'},
 451                 From    =>  C4::Context->preference("KohaAdminEmailAddress"),
 452                 Subject => $letter->{'title'},
 453                 Message => $letter->{'content'},
 454                 'Content-Type' => 'text/plain; charset="utf8"',
 455         );
 456         sendmail(%mail) or carp $Mail::Sendmail::error;
 457     }
 458 }
 459
 460 =head2 parseletter($letter, $table, $pk)
 461
 462     parameters :
 463     - $letter : a hash to letter fields (title & content useful)
 464     - $table : the Koha table to parse.
 465     - $pk : the primary key to query on the $table table
 466     parse all fields from a table, and replace values in title & content with the appropriate value
 467     (not exported sub, used only internally)
 468
 469 =cut
 470
 471 our %handles = ();
 472 our %columns = ();
 473
 474 sub parseletter_sth {
 475     my $table = shift;
 476     unless ($table) {
 477         carp "ERROR: parseletter_sth() called without argument (table)";
 478         return;
 479     }
 480     # check cache first
 481     (defined $handles{$table}) and return $handles{$table};
 482     my $query =
 483     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                      :
 484     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                      :
 485     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                      :
 486     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
 487     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
 488     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                      :
 489     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                      :
 490     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
 491     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                      : undef ;
 492     unless ($query) {
 493         warn "ERROR: No parseletter_sth query for table '$table'";
 494         return;     # nothing to get
 495     }
 496     unless ($handles{$table} = C4::Context->dbh->prepare($query)) {
 497         warn "ERROR: Failed to prepare query: '$query'";
 498         return;
 499     }
 500     return $handles{$table};    # now cache is populated for that $table
 501 }
 502
 503 sub parseletter {
 504     my ( $letter, $table, $pk, $pk2 ) = @_;
 505     unless ($letter) {
 506         carp "ERROR: parseletter() 1st argument 'letter' empty";
 507         return;
 508     }
 509     my $sth = parseletter_sth($table);
 510     unless ($sth) {
 511         warn "parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 512         return;
 513     }
 514     if ( $pk2 ) {
 515         $sth->execute($pk, $pk2);
 516     } else {
 517         $sth->execute($pk);
 518     }
 519
 520     my $values = $sth->fetchrow_hashref;
 521
 522     # TEMPORARY hack until the expirationdate column is added to reserves
 523     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 524         my @waitingdate = split /-/, $values->{'waitingdate'};
 525
 526         $values->{'expirationdate'} = C4::Dates->new(
 527             sprintf(
 528                 '%04d-%02d-%02d',
 529                 Add_Delta_Days( @waitingdate, C4::Context->preference( 'ReservesMaxPickUpDelay' ) )
 530             ),
 531             'iso'
 532         )->output();
 533     }
 534
 535
 536     # and get all fields from the table
 537     my $columns = C4::Context->dbh->prepare("SHOW COLUMNS FROM $table");
 538     $columns->execute;
 539     while ( ( my $field ) = $columns->fetchrow_array ) {
 540         my $replacefield = "<<$table.$field>>";
 541         $values->{$field} =~ s/\p{P}(?=$)//g if $values->{$field};
 542         my $replacedby   = $values->{$field} || '';
 543         ($letter->{title}  ) and $letter->{title}   =~ s/$replacefield/$replacedby/g;
 544         ($letter->{content}) and $letter->{content} =~ s/$replacefield/$replacedby/g;
 545     }
 546     return $letter;
 547 }
 548
 549 =head2 EnqueueLetter
 550
 551   my $success = EnqueueLetter( { letter => $letter,
 552         borrowernumber => '12', message_transport_type => 'email' } )
 553
 554 places a letter in the message_queue database table, which will
 555 eventually get processed (sent) by the process_message_queue.pl
 556 cronjob when it calls SendQueuedMessages.
 557
 558 return true on success
 559
 560 =cut
 561
 562 sub EnqueueLetter ($) {
 563     my $params = shift or return undef;
 564
 565     return unless exists $params->{'letter'};
 566     return unless exists $params->{'borrowernumber'};
 567     return unless exists $params->{'message_transport_type'};
 568
 569     # If we have any attachments we should encode then into the body.
 570     if ( $params->{'attachments'} ) {
 571         $params->{'letter'} = _add_attachments(
 572             {   letter      => $params->{'letter'},
 573                 attachments => $params->{'attachments'},
 574                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 575             }
 576         );
 577     }
 578
 579     my $dbh       = C4::Context->dbh();
 580     my $statement = << 'ENDSQL';
 581 INSERT INTO message_queue
 582 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 583 VALUES
 584 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 585 ENDSQL
 586
 587     my $sth    = $dbh->prepare($statement);
 588     my $result = $sth->execute(
 589         $params->{'borrowernumber'},              # borrowernumber
 590         $params->{'letter'}->{'title'},           # subject
 591         $params->{'letter'}->{'content'},         # content
 592         $params->{'letter'}->{'metadata'} || '',  # metadata
 593         $params->{'letter'}->{'code'}     || '',  # letter_code
 594         $params->{'message_transport_type'},      # message_transport_type
 595         'pending',                                # status
 596         $params->{'to_address'},                  # to_address
 597         $params->{'from_address'},                # from_address
 598         $params->{'letter'}->{'content-type'},    # content_type
 599     );
 600     return $result;
 601 }
 602
 603 =head2 SendQueuedMessages ([$hashref])
 604
 605   my $sent = SendQueuedMessages( { verbose => 1 } );
 606
 607 sends all of the 'pending' items in the message queue.
 608
 609 returns number of messages sent.
 610
 611 =cut
 612
 613 sub SendQueuedMessages (;$) {
 614     my $params = shift;
 615
 616     my $unsent_messages = _get_unsent_messages();
 617     MESSAGE: foreach my $message ( @$unsent_messages ) {
 618         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 619         warn sprintf( 'sending %s message to patron: %s',
 620                       $message->{'message_transport_type'},
 621                       $message->{'borrowernumber'} || 'Admin' )
 622           if $params->{'verbose'} or $debug;
 623         # This is just begging for subclassing
 624         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 625         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 626             _send_message_by_email( $message );
 627         }
 628         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 629             _send_message_by_sms( $message );
 630         }
 631     }
 632     return scalar( @$unsent_messages );
 633 }
 634
 635 =head2 GetRSSMessages
 636
 637   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 638
 639 returns a listref of all queued RSS messages for a particular person.
 640
 641 =cut
 642
 643 sub GetRSSMessages {
 644     my $params = shift;
 645
 646     return unless $params;
 647     return unless ref $params;
 648     return unless $params->{'borrowernumber'};
 649
 650     return _get_unsent_messages( { message_transport_type => 'rss',
 651                                    limit                  => $params->{'limit'},
 652                                    borrowernumber         => $params->{'borrowernumber'}, } );
 653 }
 654
 655 =head2 GetPrintMessages
 656
 657   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 658
 659 Returns a arrayref of all queued print messages (optionally, for a particular
 660 person).
 661
 662 =cut
 663
 664 sub GetPrintMessages {
 665     my $params = shift || {};
 666
 667     return _get_unsent_messages( { message_transport_type => 'print',
 668                                    borrowernumber         => $params->{'borrowernumber'}, } );
 669 }
 670
 671 =head2 GetQueuedMessages ([$hashref])
 672
 673   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 674
 675 fetches messages out of the message queue.
 676
 677 returns:
 678 list of hashes, each has represents a message in the message queue.
 679
 680 =cut
 681
 682 sub GetQueuedMessages {
 683     my $params = shift;
 684
 685     my $dbh = C4::Context->dbh();
 686     my $statement = << 'ENDSQL';
 687 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 688 FROM message_queue
 689 ENDSQL
 690
 691     my @query_params;
 692     my @whereclauses;
 693     if ( exists $params->{'borrowernumber'} ) {
 694         push @whereclauses, ' borrowernumber = ? ';
 695         push @query_params, $params->{'borrowernumber'};
 696     }
 697
 698     if ( @whereclauses ) {
 699         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 700     }
 701
 702     if ( defined $params->{'limit'} ) {
 703         $statement .= ' LIMIT ? ';
 704         push @query_params, $params->{'limit'};
 705     }
 706
 707     my $sth = $dbh->prepare( $statement );
 708     my $result = $sth->execute( @query_params );
 709     return $sth->fetchall_arrayref({});
 710 }
 711
 712 =head2 _add_attachements
 713
 714 named parameters:
 715 letter - the standard letter hashref
 716 attachments - listref of attachments. each attachment is a hashref of:
 717   type - the mime type, like 'text/plain'
 718   content - the actual attachment
 719   filename - the name of the attachment.
 720 message - a MIME::Lite object to attach these to.
 721
 722 returns your letter object, with the content updated.
 723
 724 =cut
 725
 726 sub _add_attachments {
 727     my $params = shift;
 728
 729     return unless 'HASH' eq ref $params;
 730     foreach my $required_parameter (qw( letter attachments message )) {
 731         return unless exists $params->{$required_parameter};
 732     }
 733     return $params->{'letter'} unless @{ $params->{'attachments'} };
 734
 735     # First, we have to put the body in as the first attachment
 736     $params->{'message'}->attach(
 737         Type => 'TEXT',
 738         Data => $params->{'letter'}->{'content'},
 739     );
 740
 741     foreach my $attachment ( @{ $params->{'attachments'} } ) {
 742         $params->{'message'}->attach(
 743             Type     => $attachment->{'type'},
 744             Data     => $attachment->{'content'},
 745             Filename => $attachment->{'filename'},
 746         );
 747     }
 748     # we're forcing list context here to get the header, not the count back from grep.
 749     ( $params->{'letter'}->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 750     $params->{'letter'}->{'content-type'} =~ s/^Content-Type:\s+//;
 751     $params->{'letter'}->{'content'} = $params->{'message'}->body_as_string;
 752
 753     return $params->{'letter'};
 754
 755 }
 756
 757 sub _get_unsent_messages (;$) {
 758     my $params = shift;
 759
 760     my $dbh = C4::Context->dbh();
 761     my $statement = << 'ENDSQL';
 762 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, from_address, to_address, content_type
 763   FROM message_queue
 764  WHERE status = ?
 765 ENDSQL
 766
 767     my @query_params = ('pending');
 768     if ( ref $params ) {
 769         if ( $params->{'message_transport_type'} ) {
 770             $statement .= ' AND message_transport_type = ? ';
 771             push @query_params, $params->{'message_transport_type'};
 772         }
 773         if ( $params->{'borrowernumber'} ) {
 774             $statement .= ' AND borrowernumber = ? ';
 775             push @query_params, $params->{'borrowernumber'};
 776         }
 777         if ( $params->{'limit'} ) {
 778             $statement .= ' limit ? ';
 779             push @query_params, $params->{'limit'};
 780         }
 781     }
 782     $debug and warn "_get_unsent_messages SQL: $statement";
 783     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 784     my $sth = $dbh->prepare( $statement );
 785     my $result = $sth->execute( @query_params );
 786     return $sth->fetchall_arrayref({});
 787 }
 788
 789 sub _send_message_by_email ($;$$$) {
 790     my $message = shift or return;
 791
 792     my $to_address = $message->{to_address};
 793     unless ($to_address) {
 794         my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 795         unless ($member) {
 796             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 797             _set_message_status( { message_id => $message->{'message_id'},
 798                                    status     => 'failed' } );
 799             return;
 800         }
 801         my $which_address = C4::Context->preference('AutoEmailPrimaryAddress');
 802         # If the system preference is set to 'first valid' (value == OFF), look up email address
 803         if ($which_address eq 'OFF') {
 804             $to_address = GetFirstValidEmailAddress( $message->{'borrowernumber'} );
 805         } else {
 806             $to_address = $member->{$which_address};
 807         }
 808         unless ($to_address) {
 809             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 810             # warning too verbose for this more common case?
 811             _set_message_status( { message_id => $message->{'message_id'},
 812                                    status     => 'failed' } );
 813             return;
 814         }
 815     }
 816
 817         my $content = encode('utf8', $message->{'content'});
 818     my %sendmail_params = (
 819         To   => $to_address,
 820         From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'),
 821         Subject => $message->{'subject'},
 822         charset => 'utf8',
 823         Message => $content,
 824         'content-type' => $message->{'content_type'} || 'text/plain; charset="UTF-8"',
 825     );
 826     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
 827        $sendmail_params{ Bcc } = $bcc;
 828     }
 829
 830
 831     if ( sendmail( %sendmail_params ) ) {
 832         _set_message_status( { message_id => $message->{'message_id'},
 833                 status     => 'sent' } );
 834         return 1;
 835     } else {
 836         _set_message_status( { message_id => $message->{'message_id'},
 837                 status     => 'failed' } );
 838         carp $Mail::Sendmail::error;
 839         return;
 840     }
 841 }
 842
 843 sub _send_message_by_sms ($) {
 844     my $message = shift or return undef;
 845     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 846     return unless $member->{'smsalertnumber'};
 847
 848     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
 849                                        message     => $message->{'content'},
 850                                      } );
 851     _set_message_status( { message_id => $message->{'message_id'},
 852                            status     => ($success ? 'sent' : 'failed') } );
 853     return $success;
 854 }
 855
 856 sub _set_message_status ($) {
 857     my $params = shift or return undef;
 858
 859     foreach my $required_parameter ( qw( message_id status ) ) {
 860         return undef unless exists $params->{ $required_parameter };
 861     }
 862
 863     my $dbh = C4::Context->dbh();
 864     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
 865     my $sth = $dbh->prepare( $statement );
 866     my $result = $sth->execute( $params->{'status'},
 867                                 $params->{'message_id'} );
 868     return $result;
 869 }
 870
 871
 872 1;
 873 __END__