Koha/Email.pm

   1 package Koha::Email;
   2
   3 # Copyright 2014 Catalyst
   4 #           2020 Theke Solutions
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 use Modern::Perl;
  22
  23 use Email::Address;
  24 use Email::MessageID;
  25 use List::Util qw( pairs );
  26
  27 use Koha::Exceptions;
  28
  29 use C4::Context;
  30
  31 use base qw( Email::Stuffer );
  32
  33 =head1 NAME
  34
  35 Koha::Email - A wrapper around Email::Stuffer
  36
  37 =head1 API
  38
  39 =head2 Class methods
  40
  41 =head3 create
  42
  43     my $email = Koha::Email->create(
  44         {
  45           [ text_body   => $text_message,
  46             html_body   => $html_message,
  47             body_params => $body_params ]
  48             from        => $from,
  49             to          => $to,
  50             cc          => $cc,
  51             bcc         => $bcc,
  52             reply_to    => $reply_to,
  53             sender      => $sender,
  54             subject     => $subject,
  55         }
  56     );
  57
  58 This method creates a new Email::Stuffer object taking Koha specific configurations
  59 into account.
  60
  61 The encoding defaults to utf-8. It can be set as part of the body_params hashref. See
  62 I<Email::Stuffer> and I<Email::MIME> for more details on the available options.
  63
  64 Parameters:
  65  - I<from> defaults to the value of the I<KohaAdminEmailAddress> system preference
  66  - The I<SendAllEmailsTo> system preference overloads the I<to>, I<cc> and I<bcc> parameters
  67  - I<reply_to> defaults to the value of the I<ReplytoDefault> system preference
  68  - I<sender> defaults to the value of the I<ReturnpathDefault> system preference
  69
  70 Both I<text_body> and I<html_body> can be set later. I<body_params> will be passed if present
  71 to the constructor.
  72
  73 =cut
  74
  75 sub create {
  76     my ( $self, $params ) = @_;
  77
  78     my $args = {};
  79     $args->{from} = $params->{from} || C4::Context->preference('KohaAdminEmailAddress');
  80     Koha::Exceptions::BadParameter->throw("Invalid 'from' parameter: ".$args->{from})
  81         unless Koha::Email->is_valid($args->{from}); # from is mandatory
  82
  83     $args->{subject} = $params->{subject} // '';
  84
  85     if ( C4::Context->preference('SendAllEmailsTo') ) {
  86         $args->{to} = C4::Context->preference('SendAllEmailsTo');
  87     }
  88     else {
  89         $args->{to} = $params->{to};
  90     }
  91
  92     Koha::Exceptions::BadParameter->throw("Invalid 'to' parameter: ".$args->{to})
  93         unless Koha::Email->is_valid($args->{to}); # to is mandatory
  94
  95     my $addresses = {};
  96     $addresses->{reply_to} = $params->{reply_to};
  97     $addresses->{reply_to} ||= C4::Context->preference('ReplytoDefault')
  98         if C4::Context->preference('ReplytoDefault');
  99
 100     $addresses->{sender} = $params->{sender};
 101     $addresses->{sender} ||= C4::Context->preference('ReturnpathDefault')
 102         if C4::Context->preference('ReturnpathDefault');
 103
 104     unless ( C4::Context->preference('SendAllEmailsTo') ) {
 105         $addresses->{cc} = $params->{cc}
 106             if exists $params->{cc};
 107         $addresses->{bcc} = $params->{bcc}
 108             if exists $params->{bcc};
 109     }
 110
 111     foreach my $address ( keys %{$addresses} ) {
 112         Koha::Exceptions::BadParameter->throw(
 113             "Invalid '$address' parameter: " . $addresses->{$address} )
 114           if $addresses->{$address}
 115             and !Koha::Email->is_valid($addresses->{$address});
 116     }
 117
 118     $args->{cc} = $addresses->{cc}
 119         if $addresses->{cc};
 120     $args->{bcc} = $addresses->{bcc}
 121         if $addresses->{bcc};
 122
 123     my $email = $self->SUPER::new( $args );
 124
 125     $email->header( 'Reply-To', $addresses->{reply_to} )
 126         if $addresses->{reply_to};
 127
 128     $email->header( 'Sender'       => $addresses->{sender} ) if $addresses->{sender};
 129     $email->header( 'Content-Type' => $params->{contenttype} ) if $params->{contenttype};
 130     $email->header( 'X-Mailer'     => "Koha" );
 131     $email->header( 'Message-ID'   => Email::MessageID->new->in_brackets );
 132
 133     if ( $params->{text_body} ) {
 134         $email->text_body( $params->{text_body}, %{ $params->{body_params} } );
 135     }
 136     elsif ( $params->{html_body} ) {
 137         $email->html_body( $params->{html_body}, %{ $params->{body_params} } );
 138     }
 139
 140     return $email;
 141 }
 142
 143 =head3 send_or_die
 144
 145     $email->send_or_die({ transport => $transport [, $args] });
 146
 147 Overloaded Email::Stuffer I<send_or_die> method, that takes care of Bcc handling.
 148 Bcc is removed from the message headers, and included in the recipients list to be
 149 passed to I<send_or_die>.
 150
 151 =cut
 152
 153 sub send_or_die {
 154     my ( $self, $args ) = @_;
 155
 156     unless ( $args->{to} ) {    # don't do it if passed an explicit 'to' param
 157
 158         my @recipients;
 159
 160         my @headers = $self->email->header_str_pairs;
 161         foreach my $pair ( pairs @headers ) {
 162             my ( $header, $value ) = @$pair;
 163             push @recipients, split (', ', $value)
 164                 if grep { $_ eq $header } ('To', 'Cc', 'Bcc');
 165         }
 166
 167         # Remove the Bcc header
 168         $self->email->header_str_set('Bcc');
 169
 170         # Tweak $args
 171         $args->{to} = \@recipients;
 172     }
 173
 174     $self->SUPER::send_or_die($args);
 175 }
 176
 177 =head3 is_valid
 178
 179     my $is_valid = Koha::Email->is_valid($email_address);
 180
 181 Return true is the email address passed in parameter is valid following RFC 2822.
 182
 183 =cut
 184
 185 sub is_valid {
 186     my ( $class, $email ) = @_;
 187     return ($email =~ m{$Email::Address::mailbox}) ? 1 : 0;
 188 }
 189
 190 1;