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