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