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     if ($want_librarian) {
 544         # parsing librarian name
 545         my $userenv = C4::Context->userenv;
 546         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 547         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 548         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 549     }
 550
 551     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 552
 553     if ($repeat) {
 554         if (ref ($repeat) eq 'ARRAY' ) {
 555             $repeat_no_enclosing_tags = $repeat;
 556         } else {
 557             $repeat_enclosing_tags = $repeat;
 558         }
 559     }
 560
 561     if ($repeat_enclosing_tags) {
 562         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 563             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 564                 my $subcontent = $1;
 565                 my @lines = map {
 566                     my %subletter = ( title => '', content => $subcontent );
 567                     _substitute_tables( \%subletter, $_ );
 568                     $subletter{content};
 569                 } @$tag_tables;
 570                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 571             }
 572         }
 573     }
 574
 575     if ($tables) {
 576         _substitute_tables( $letter, $tables );
 577     }
 578
 579     if ($repeat_no_enclosing_tags) {
 580         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 581             my $line = $&;
 582             my $i = 1;
 583             my @lines = map {
 584                 my $c = $line;
 585                 $c =~ s/<<count>>/$i/go;
 586                 foreach my $field ( keys %{$_} ) {
 587                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 588                 }
 589                 $i++;
 590                 $c;
 591             } @$repeat_no_enclosing_tags;
 592
 593             my $replaceby = join( "\n", @lines );
 594             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 595         }
 596     }
 597
 598     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 599 #   $letter->{content} =~ s/<<[^>]*>>//go;
 600
 601     return $letter;
 602 }
 603
 604 sub _substitute_tables {
 605     my ( $letter, $tables ) = @_;
 606     while ( my ($table, $param) = each %$tables ) {
 607         next unless $param;
 608
 609         my $ref = ref $param;
 610
 611         my $values;
 612         if ($ref && $ref eq 'HASH') {
 613             $values = $param;
 614         }
 615         else {
 616             my @pk;
 617             my $sth = _parseletter_sth($table);
 618             unless ($sth) {
 619                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 620                 return;
 621             }
 622             $sth->execute( $ref ? @$param : $param );
 623
 624             $values = $sth->fetchrow_hashref;
 625         }
 626
 627         _parseletter ( $letter, $table, $values );
 628     }
 629 }
 630
 631 my %handles = ();
 632 sub _parseletter_sth {
 633     my $table = shift;
 634     unless ($table) {
 635         carp "ERROR: _parseletter_sth() called without argument (table)";
 636         return;
 637     }
 638     # check cache first
 639     (defined $handles{$table}) and return $handles{$table};
 640     my $query =
 641     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                 :
 642     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                 :
 643     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                 :
 644     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                 :
 645     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1" :
 646     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"            :
 647     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                 :
 648     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                 :
 649     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                 :
 650     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                 :
 651     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                 :
 652     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                 :
 653     undef ;
 654     unless ($query) {
 655         warn "ERROR: No _parseletter_sth query for table '$table'";
 656         return;     # nothing to get
 657     }
 658     unless ($handles{$table} = C4::Context->dbh->prepare($query)) {
 659         warn "ERROR: Failed to prepare query: '$query'";
 660         return;
 661     }
 662     return $handles{$table};    # now cache is populated for that $table
 663 }
 664
 665 =head2 _parseletter($letter, $table, $values)
 666
 667     parameters :
 668     - $letter : a hash to letter fields (title & content useful)
 669     - $table : the Koha table to parse.
 670     - $values : table record hashref
 671     parse all fields from a table, and replace values in title & content with the appropriate value
 672     (not exported sub, used only internally)
 673
 674 =cut
 675
 676 my %columns = ();
 677 sub _parseletter {
 678     my ( $letter, $table, $values ) = @_;
 679
 680     # TEMPORARY hack until the expirationdate column is added to reserves
 681     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 682         my @waitingdate = split /-/, $values->{'waitingdate'};
 683
 684         $values->{'expirationdate'} = C4::Dates->new(
 685             sprintf(
 686                 '%04d-%02d-%02d',
 687                 Add_Delta_Days( @waitingdate, C4::Context->preference( 'ReservesMaxPickUpDelay' ) )
 688             ),
 689             'iso'
 690         )->output();
 691     }
 692
 693     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 694         my @da = localtime();
 695         my $todaysdate = "$da[2]:$da[1]  " . C4::Dates->today();
 696         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 697     }
 698
 699     # and get all fields from the table
 700 #   my $columns = $columns{$table};
 701 #   unless ($columns) {
 702 #       $columns = $columns{$table} =  C4::Context->dbh->selectcol_arrayref("SHOW COLUMNS FROM $table");
 703 #   }
 704 #   foreach my $field (@$columns) {
 705
 706     while ( my ($field, $val) = each %$values ) {
 707         my $replacetablefield = "<<$table.$field>>";
 708         my $replacefield = "<<$field>>";
 709         $val =~ s/\p{P}(?=$)//g if $val;
 710         my $replacedby   = defined ($val) ? $val : '';
 711         ($letter->{title}  ) and do {
 712             $letter->{title}   =~ s/$replacetablefield/$replacedby/g;
 713             $letter->{title}   =~ s/$replacefield/$replacedby/g;
 714         };
 715         ($letter->{content}) and do {
 716             $letter->{content} =~ s/$replacetablefield/$replacedby/g;
 717             $letter->{content} =~ s/$replacefield/$replacedby/g;
 718         };
 719     }
 720
 721     if ($table eq 'borrowers' && $letter->{content}) {
 722         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 723             my %attr;
 724             foreach (@$attributes) {
 725                 my $code = $_->{code};
 726                 my $val  = $_->{value_description} || $_->{value};
 727                 $val =~ s/\p{P}(?=$)//g if $val;
 728                 next unless $val gt '';
 729                 $attr{$code} ||= [];
 730                 push @{ $attr{$code} }, $val;
 731             }
 732             while ( my ($code, $val_ar) = each %attr ) {
 733                 my $replacefield = "<<borrower-attribute:$code>>";
 734                 my $replacedby   = join ',', @$val_ar;
 735                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 736             }
 737         }
 738     }
 739     return $letter;
 740 }
 741
 742 =head2 EnqueueLetter
 743
 744   my $success = EnqueueLetter( { letter => $letter,
 745         borrowernumber => '12', message_transport_type => 'email' } )
 746
 747 places a letter in the message_queue database table, which will
 748 eventually get processed (sent) by the process_message_queue.pl
 749 cronjob when it calls SendQueuedMessages.
 750
 751 return message_id on success
 752
 753 =cut
 754
 755 sub EnqueueLetter {
 756     my $params = shift or return;
 757
 758     return unless exists $params->{'letter'};
 759     return unless exists $params->{'borrowernumber'};
 760     return unless exists $params->{'message_transport_type'};
 761
 762     my $content = $params->{letter}->{content};
 763     $content =~ s/\s+//g if(defined $content);
 764     if ( not defined $content or $content eq '' ) {
 765         warn "Trying to add an empty message to the message queue" if $debug;
 766         return;
 767     }
 768
 769     # It was found that the some utf8 codes, cause the text to be truncated from that point onward when stored,
 770     # so we normalize utf8 with NFC so that mysql will store 'all' of the content in its TEXT column type
 771     # Note: It is also done in _add_attachments accordingly.
 772     $params->{'letter'}->{'title'} = NFC($params->{'letter'}->{'title'});     # subject
 773     $params->{'letter'}->{'content'} = NFC($params->{'letter'}->{'content'});
 774
 775     # If we have any attachments we should encode then into the body.
 776     if ( $params->{'attachments'} ) {
 777         $params->{'letter'} = _add_attachments(
 778             {   letter      => $params->{'letter'},
 779                 attachments => $params->{'attachments'},
 780                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 781             }
 782         );
 783     }
 784
 785     my $dbh       = C4::Context->dbh();
 786     my $statement = << 'ENDSQL';
 787 INSERT INTO message_queue
 788 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 789 VALUES
 790 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 791 ENDSQL
 792
 793     my $sth    = $dbh->prepare($statement);
 794     my $result = $sth->execute(
 795         $params->{'borrowernumber'},              # borrowernumber
 796         $params->{'letter'}->{'title'},           # subject
 797         $params->{'letter'}->{'content'},         # content
 798         $params->{'letter'}->{'metadata'} || '',  # metadata
 799         $params->{'letter'}->{'code'}     || '',  # letter_code
 800         $params->{'message_transport_type'},      # message_transport_type
 801         'pending',                                # status
 802         $params->{'to_address'},                  # to_address
 803         $params->{'from_address'},                # from_address
 804         $params->{'letter'}->{'content-type'},    # content_type
 805     );
 806     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 807 }
 808
 809 =head2 SendQueuedMessages ([$hashref])
 810
 811   my $sent = SendQueuedMessages( { verbose => 1 } );
 812
 813 sends all of the 'pending' items in the message queue.
 814
 815 returns number of messages sent.
 816
 817 =cut
 818
 819 sub SendQueuedMessages {
 820     my $params = shift;
 821
 822     my $unsent_messages = _get_unsent_messages();
 823     MESSAGE: foreach my $message ( @$unsent_messages ) {
 824         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 825         warn sprintf( 'sending %s message to patron: %s',
 826                       $message->{'message_transport_type'},
 827                       $message->{'borrowernumber'} || 'Admin' )
 828           if $params->{'verbose'} or $debug;
 829         # This is just begging for subclassing
 830         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 831         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 832             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 833         }
 834         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 835             _send_message_by_sms( $message );
 836         }
 837     }
 838     return scalar( @$unsent_messages );
 839 }
 840
 841 =head2 GetRSSMessages
 842
 843   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 844
 845 returns a listref of all queued RSS messages for a particular person.
 846
 847 =cut
 848
 849 sub GetRSSMessages {
 850     my $params = shift;
 851
 852     return unless $params;
 853     return unless ref $params;
 854     return unless $params->{'borrowernumber'};
 855
 856     return _get_unsent_messages( { message_transport_type => 'rss',
 857                                    limit                  => $params->{'limit'},
 858                                    borrowernumber         => $params->{'borrowernumber'}, } );
 859 }
 860
 861 =head2 GetPrintMessages
 862
 863   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 864
 865 Returns a arrayref of all queued print messages (optionally, for a particular
 866 person).
 867
 868 =cut
 869
 870 sub GetPrintMessages {
 871     my $params = shift || {};
 872
 873     return _get_unsent_messages( { message_transport_type => 'print',
 874                                    borrowernumber         => $params->{'borrowernumber'},
 875                                  } );
 876 }
 877
 878 =head2 GetQueuedMessages ([$hashref])
 879
 880   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 881
 882 fetches messages out of the message queue.
 883
 884 returns:
 885 list of hashes, each has represents a message in the message queue.
 886
 887 =cut
 888
 889 sub GetQueuedMessages {
 890     my $params = shift;
 891
 892     my $dbh = C4::Context->dbh();
 893     my $statement = << 'ENDSQL';
 894 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 895 FROM message_queue
 896 ENDSQL
 897
 898     my @query_params;
 899     my @whereclauses;
 900     if ( exists $params->{'borrowernumber'} ) {
 901         push @whereclauses, ' borrowernumber = ? ';
 902         push @query_params, $params->{'borrowernumber'};
 903     }
 904
 905     if ( @whereclauses ) {
 906         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 907     }
 908
 909     if ( defined $params->{'limit'} ) {
 910         $statement .= ' LIMIT ? ';
 911         push @query_params, $params->{'limit'};
 912     }
 913
 914     my $sth = $dbh->prepare( $statement );
 915     my $result = $sth->execute( @query_params );
 916     return $sth->fetchall_arrayref({});
 917 }
 918
 919 =head2 _add_attachements
 920
 921 named parameters:
 922 letter - the standard letter hashref
 923 attachments - listref of attachments. each attachment is a hashref of:
 924   type - the mime type, like 'text/plain'
 925   content - the actual attachment
 926   filename - the name of the attachment.
 927 message - a MIME::Lite object to attach these to.
 928
 929 returns your letter object, with the content updated.
 930
 931 =cut
 932
 933 sub _add_attachments {
 934     my $params = shift;
 935
 936     my $letter = $params->{'letter'};
 937     my $attachments = $params->{'attachments'};
 938     return $letter unless @$attachments;
 939     my $message = $params->{'message'};
 940
 941     # First, we have to put the body in as the first attachment
 942     $message->attach(
 943         Type => $letter->{'content-type'} || 'TEXT',
 944         Data => $letter->{'is_html'}
 945             ? _wrap_html($letter->{'content'}, NFC($letter->{'title'}))
 946             : NFC($letter->{'content'}),
 947     );
 948
 949     foreach my $attachment ( @$attachments ) {
 950
 951         if ($attachment->{'content'} =~ m/text/o) { # NFC normailze any "text" related  content-type attachments
 952             $attachment->{'content'} = NFC($attachment->{'content'});
 953         }
 954         $attachment->{'filename'} = NFC($attachment->{'filename'});
 955
 956         $message->attach(
 957             Type     => $attachment->{'type'},
 958             Data     => $attachment->{'content'},
 959             Filename => $attachment->{'filename'},
 960         );
 961     }
 962     # we're forcing list context here to get the header, not the count back from grep.
 963     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 964     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 965     $letter->{'content'} = $message->body_as_string;
 966
 967     return $letter;
 968
 969 }
 970
 971 sub _get_unsent_messages {
 972     my $params = shift;
 973
 974     my $dbh = C4::Context->dbh();
 975     my $statement = << 'ENDSQL';
 976 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
 977   FROM message_queue mq
 978   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
 979  WHERE status = ?
 980 ENDSQL
 981
 982     my @query_params = ('pending');
 983     if ( ref $params ) {
 984         if ( $params->{'message_transport_type'} ) {
 985             $statement .= ' AND message_transport_type = ? ';
 986             push @query_params, $params->{'message_transport_type'};
 987         }
 988         if ( $params->{'borrowernumber'} ) {
 989             $statement .= ' AND borrowernumber = ? ';
 990             push @query_params, $params->{'borrowernumber'};
 991         }
 992         if ( $params->{'limit'} ) {
 993             $statement .= ' limit ? ';
 994             push @query_params, $params->{'limit'};
 995         }
 996     }
 997
 998     $debug and warn "_get_unsent_messages SQL: $statement";
 999     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1000     my $sth = $dbh->prepare( $statement );
1001     my $result = $sth->execute( @query_params );
1002     return $sth->fetchall_arrayref({});
1003 }
1004
1005 sub _send_message_by_email {
1006     my $message = shift or return;
1007     my ($username, $password, $method) = @_;
1008
1009     my $to_address = $message->{to_address};
1010     unless ($to_address) {
1011         my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1012         unless ($member) {
1013             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1014             _set_message_status( { message_id => $message->{'message_id'},
1015                                    status     => 'failed' } );
1016             return;
1017         }
1018         my $which_address = C4::Context->preference('AutoEmailPrimaryAddress');
1019         # If the system preference is set to 'first valid' (value == OFF), look up email address
1020         if ($which_address eq 'OFF') {
1021             $to_address = GetFirstValidEmailAddress( $message->{'borrowernumber'} );
1022         } else {
1023             $to_address = $member->{$which_address};
1024         }
1025         unless ($to_address) {
1026             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1027             # warning too verbose for this more common case?
1028             _set_message_status( { message_id => $message->{'message_id'},
1029                                    status     => 'failed' } );
1030             return;
1031         }
1032     }
1033
1034     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1035     $message->{subject}= encode('MIME-Header', $utf8);
1036     my $subject = encode('utf8', $message->{'subject'});
1037     my $content = encode('utf8', $message->{'content'});
1038     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1039     my $is_html = $content_type =~ m/html/io;
1040     my %sendmail_params = (
1041         To   => $to_address,
1042         From => $message->{'from_address'} || C4::Context->preference('KohaAdminEmailAddress'),
1043         Subject => $subject,
1044         charset => 'utf8',
1045         Message => $is_html ? _wrap_html($content, $subject) : $content,
1046         'content-type' => $content_type,
1047     );
1048     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1049     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1050        $sendmail_params{ Bcc } = $bcc;
1051     }
1052
1053     _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
1054     if ( sendmail( %sendmail_params ) ) {
1055         _set_message_status( { message_id => $message->{'message_id'},
1056                 status     => 'sent' } );
1057         return 1;
1058     } else {
1059         _set_message_status( { message_id => $message->{'message_id'},
1060                 status     => 'failed' } );
1061         carp $Mail::Sendmail::error;
1062         return;
1063     }
1064 }
1065
1066 sub _wrap_html {
1067     my ($content, $title) = @_;
1068
1069     my $css = C4::Context->preference("NoticeCSS") || '';
1070     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1071     return <<EOS;
1072 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1073     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1074 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1075 <head>
1076 <title>$title</title>
1077 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1078 $css
1079 </head>
1080 <body>
1081 $content
1082 </body>
1083 </html>
1084 EOS
1085 }
1086
1087 sub _send_message_by_sms {
1088     my $message = shift or return;
1089     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1090     return unless $member->{'smsalertnumber'};
1091
1092     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1093                                        message     => $message->{'content'},
1094                                      } );
1095     _set_message_status( { message_id => $message->{'message_id'},
1096                            status     => ($success ? 'sent' : 'failed') } );
1097     return $success;
1098 }
1099
1100 sub _update_message_to_address {
1101     my ($id, $to)= @_;
1102     my $dbh = C4::Context->dbh();
1103     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1104 }
1105
1106 sub _set_message_status {
1107     my $params = shift or return;
1108
1109     foreach my $required_parameter ( qw( message_id status ) ) {
1110         return unless exists $params->{ $required_parameter };
1111     }
1112
1113     my $dbh = C4::Context->dbh();
1114     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1115     my $sth = $dbh->prepare( $statement );
1116     my $result = $sth->execute( $params->{'status'},
1117                                 $params->{'message_id'} );
1118     return $result;
1119 }
1120
1121
1122 1;
1123 __END__