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