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