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     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;
 231     my $externalid = shift or return;
 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;
 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 message_id on success
 668
 669 =cut
 670
 671 sub EnqueueLetter {
 672     my $params = shift or return;
 673
 674     return unless exists $params->{'letter'};
 675     return unless exists $params->{'borrowernumber'};
 676     return unless exists $params->{'message_transport_type'};
 677
 678     my $content = $params->{letter}->{content};
 679     $content =~ s/\s+//g if(defined $content);
 680     if ( not defined $content or $content eq '' ) {
 681         warn "Trying to add an empty message to the message queue" if $debug;
 682         return;
 683     }
 684
 685     # If we have any attachments we should encode then into the body.
 686     if ( $params->{'attachments'} ) {
 687         $params->{'letter'} = _add_attachments(
 688             {   letter      => $params->{'letter'},
 689                 attachments => $params->{'attachments'},
 690                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 691             }
 692         );
 693     }
 694
 695     my $dbh       = C4::Context->dbh();
 696     my $statement = << 'ENDSQL';
 697 INSERT INTO message_queue
 698 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 699 VALUES
 700 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 701 ENDSQL
 702
 703     my $sth    = $dbh->prepare($statement);
 704     my $result = $sth->execute(
 705         $params->{'borrowernumber'},              # borrowernumber
 706         $params->{'letter'}->{'title'},           # subject
 707         $params->{'letter'}->{'content'},         # content
 708         $params->{'letter'}->{'metadata'} || '',  # metadata
 709         $params->{'letter'}->{'code'}     || '',  # letter_code
 710         $params->{'message_transport_type'},      # message_transport_type
 711         'pending',                                # status
 712         $params->{'to_address'},                  # to_address
 713         $params->{'from_address'},                # from_address
 714         $params->{'letter'}->{'content-type'},    # content_type
 715     );
 716     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 717 }
 718
 719 =head2 SendQueuedMessages ([$hashref])
 720
 721   my $sent = SendQueuedMessages( { verbose => 1 } );
 722
 723 sends all of the 'pending' items in the message queue.
 724
 725 returns number of messages sent.
 726
 727 =cut
 728
 729 sub SendQueuedMessages {
 730     my $params = shift;
 731
 732     my $unsent_messages = _get_unsent_messages();
 733     MESSAGE: foreach my $message ( @$unsent_messages ) {
 734         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 735         warn sprintf( 'sending %s message to patron: %s',
 736                       $message->{'message_transport_type'},
 737                       $message->{'borrowernumber'} || 'Admin' )
 738           if $params->{'verbose'} or $debug;
 739         # This is just begging for subclassing
 740         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 741         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 742             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 743         }
 744         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 745             _send_message_by_sms( $message );
 746         }
 747     }
 748     return scalar( @$unsent_messages );
 749 }
 750
 751 =head2 GetRSSMessages
 752
 753   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 754
 755 returns a listref of all queued RSS messages for a particular person.
 756
 757 =cut
 758
 759 sub GetRSSMessages {
 760     my $params = shift;
 761
 762     return unless $params;
 763     return unless ref $params;
 764     return unless $params->{'borrowernumber'};
 765
 766     return _get_unsent_messages( { message_transport_type => 'rss',
 767                                    limit                  => $params->{'limit'},
 768                                    borrowernumber         => $params->{'borrowernumber'}, } );
 769 }
 770
 771 =head2 GetPrintMessages
 772
 773   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 774
 775 Returns a arrayref of all queued print messages (optionally, for a particular
 776 person).
 777
 778 =cut
 779
 780 sub GetPrintMessages {
 781     my $params = shift || {};
 782
 783     return _get_unsent_messages( { message_transport_type => 'print',
 784                                    borrowernumber         => $params->{'borrowernumber'},
 785                                  } );
 786 }
 787
 788 =head2 GetQueuedMessages ([$hashref])
 789
 790   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 791
 792 fetches messages out of the message queue.
 793
 794 returns:
 795 list of hashes, each has represents a message in the message queue.
 796
 797 =cut
 798
 799 sub GetQueuedMessages {
 800     my $params = shift;
 801
 802     my $dbh = C4::Context->dbh();
 803     my $statement = << 'ENDSQL';
 804 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 805 FROM message_queue
 806 ENDSQL
 807
 808     my @query_params;
 809     my @whereclauses;
 810     if ( exists $params->{'borrowernumber'} ) {
 811         push @whereclauses, ' borrowernumber = ? ';
 812         push @query_params, $params->{'borrowernumber'};
 813     }
 814
 815     if ( @whereclauses ) {
 816         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 817     }
 818
 819     if ( defined $params->{'limit'} ) {
 820         $statement .= ' LIMIT ? ';
 821         push @query_params, $params->{'limit'};
 822     }
 823
 824     my $sth = $dbh->prepare( $statement );
 825     my $result = $sth->execute( @query_params );
 826     return $sth->fetchall_arrayref({});
 827 }
 828
 829 =head2 _add_attachements
 830
 831 named parameters:
 832 letter - the standard letter hashref
 833 attachments - listref of attachments. each attachment is a hashref of:
 834   type - the mime type, like 'text/plain'
 835   content - the actual attachment
 836   filename - the name of the attachment.
 837 message - a MIME::Lite object to attach these to.
 838
 839 returns your letter object, with the content updated.
 840
 841 =cut
 842
 843 sub _add_attachments {
 844     my $params = shift;
 845
 846     my $letter = $params->{'letter'};
 847     my $attachments = $params->{'attachments'};
 848     return $letter unless @$attachments;
 849     my $message = $params->{'message'};
 850
 851     # First, we have to put the body in as the first attachment
 852     $message->attach(
 853         Type => $letter->{'content-type'} || 'TEXT',
 854         Data => $letter->{'is_html'}
 855             ? _wrap_html($letter->{'content'}, $letter->{'title'})
 856             : $letter->{'content'},
 857     );
 858
 859     foreach my $attachment ( @$attachments ) {
 860         $message->attach(
 861             Type     => $attachment->{'type'},
 862             Data     => $attachment->{'content'},
 863             Filename => $attachment->{'filename'},
 864         );
 865     }
 866     # we're forcing list context here to get the header, not the count back from grep.
 867     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 868     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 869     $letter->{'content'} = $message->body_as_string;
 870
 871     return $letter;
 872
 873 }
 874
 875 sub _get_unsent_messages {
 876     my $params = shift;
 877
 878     my $dbh = C4::Context->dbh();
 879     my $statement = << 'ENDSQL';
 880 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
 881   FROM message_queue mq
 882   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
 883  WHERE status = ?
 884 ENDSQL
 885
 886     my @query_params = ('pending');
 887     if ( ref $params ) {
 888         if ( $params->{'message_transport_type'} ) {
 889             $statement .= ' AND message_transport_type = ? ';
 890             push @query_params, $params->{'message_transport_type'};
 891         }
 892         if ( $params->{'borrowernumber'} ) {
 893             $statement .= ' AND borrowernumber = ? ';
 894             push @query_params, $params->{'borrowernumber'};
 895         }
 896         if ( $params->{'limit'} ) {
 897             $statement .= ' limit ? ';
 898             push @query_params, $params->{'limit'};
 899         }
 900     }
 901
 902     $debug and warn "_get_unsent_messages SQL: $statement";
 903     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 904     my $sth = $dbh->prepare( $statement );
 905     my $result = $sth->execute( @query_params );
 906     return $sth->fetchall_arrayref({});
 907 }
 908
 909 sub _send_message_by_email {
 910     my $message = shift or return;
 911     my ($username, $password, $method) = @_;
 912
 913     my $to_address = $message->{to_address};
 914     unless ($to_address) {
 915         my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 916         unless ($member) {
 917             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 918             _set_message_status( { message_id => $message->{'message_id'},
 919                                    status     => 'failed' } );
 920             return;
 921         }
 922         my $which_address = C4::Context->preference('AutoEmailPrimaryAddress');
 923         # If the system preference is set to 'first valid' (value == OFF), look up email address
 924         if ($which_address eq 'OFF') {
 925             $to_address = GetFirstValidEmailAddress( $message->{'borrowernumber'} );
 926         } else {
 927             $to_address = $member->{$which_address};
 928         }
 929         unless ($to_address) {
 930             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 931             # warning too verbose for this more common case?
 932             _set_message_status( { message_id => $message->{'message_id'},
 933                                    status     => 'failed' } );
 934             return;
 935         }
 936     }
 937
 938     my $utf8   = decode('MIME-Header', $message->{'subject'} );
 939     $message->{subject}= encode('MIME-Header', $utf8);
 940     my $subject = encode('utf8', $message->{'subject'});
 941     my $content = encode('utf8', $message->{'content'});
 942     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
 943     my $is_html = $content_type =~ m/html/io;
 944     my %sendmail_params = (
 945         To   => $to_address,
 946         From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'),
 947         Subject => $subject,
 948         charset => 'utf8',
 949         Message => $is_html ? _wrap_html($content, $subject) : $content,
 950         'content-type' => $content_type,
 951     );
 952     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
 953     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
 954        $sendmail_params{ Bcc } = $bcc;
 955     }
 956
 957     _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
 958     if ( sendmail( %sendmail_params ) ) {
 959         _set_message_status( { message_id => $message->{'message_id'},
 960                 status     => 'sent' } );
 961         return 1;
 962     } else {
 963         _set_message_status( { message_id => $message->{'message_id'},
 964                 status     => 'failed' } );
 965         carp $Mail::Sendmail::error;
 966         return;
 967     }
 968 }
 969
 970 sub _wrap_html {
 971     my ($content, $title) = @_;
 972
 973     my $css = C4::Context->preference("NoticeCSS") || '';
 974     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
 975     return <<EOS;
 976 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 977     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 978 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
 979 <head>
 980 <title>$title</title>
 981 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 982 $css
 983 </head>
 984 <body>
 985 $content
 986 </body>
 987 </html>
 988 EOS
 989 }
 990
 991 sub _send_message_by_sms {
 992     my $message = shift or return;
 993     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 994     return unless $member->{'smsalertnumber'};
 995
 996     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
 997                                        message     => $message->{'content'},
 998                                      } );
 999     _set_message_status( { message_id => $message->{'message_id'},
1000                            status     => ($success ? 'sent' : 'failed') } );
1001     return $success;
1002 }
1003
1004 sub _update_message_to_address {
1005     my ($id, $to)= @_;
1006     my $dbh = C4::Context->dbh();
1007     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1008 }
1009
1010 sub _set_message_status {
1011     my $params = shift or return;
1012
1013     foreach my $required_parameter ( qw( message_id status ) ) {
1014         return unless exists $params->{ $required_parameter };
1015     }
1016
1017     my $dbh = C4::Context->dbh();
1018     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1019     my $sth = $dbh->prepare( $statement );
1020     my $result = $sth->execute( $params->{'status'},
1021                                 $params->{'message_id'} );
1022     return $result;
1023 }
1024
1025
1026 1;
1027 __END__