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