C4/Letters.pm

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