File Coverage

blib/lib/Mail/DWIM.pm

Criterion	Covered	Total	%
statement	125	211	59.2
branch	32	76	42.1
condition	7	12	58.3
subroutine	24	30	80.0
pod	0	20	0.0
total	188	349	53.8

###########################################
package Mail::DWIM;
###########################################

use strict;
use warnings;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(mail);
our $VERSION = "0.08";
our @HTML_MODULES = qw(HTML::FormatText HTML::TreeBuilder MIME::Lite);
our @ATTACH_MODULES = qw(File::MMagic MIME::Lite);

use YAML qw(LoadFile);
use Log::Log4perl qw(:easy);
use Config;
use Mail::Mailer;
use Sys::Hostname;
use File::Basename;
use POSIX qw(strftime);
use File::Spec;

my $error;

###########################################
sub mail {
###########################################
    my(@params) = @_;

    my $mailer = Mail::DWIM->new(@params);
    $mailer->send();
}

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my($homedir) = glob "~";

    my %defaults;

    my $self = {
        global_cfg_file => "/etc/maildwim",
        user_cfg_file   => "$homedir/.maildwim",
        transport       => "sendmail",
        raise_error     => 1,
        %options,
    };

      # Guess the 'from' address
    if(! exists $self->{from}) {
        my $user   = scalar getpwuid($<);
        my $domain = domain();
        $self->{from} = "$user\@$domain";
    }

      # Guess the 'date'
    if (!exists $self->{date}) {
        $self->{date} = strftime("%a, %e %b %Y %H:%M:%S %Z", localtime(time));
    }

    for my $cfg (qw(global_cfg_file user_cfg_file)) {
        if(-f $self->{$cfg}) {
            my $yml = LoadFile( $self->{$cfg} );
            if(defined $yml and ref $yml ne 'HASH') {
                  # Needs to be a hash, but YAML file can be empty (undef)
                LOGDIE "YAML file $self->{$cfg} format not a hash";
            }
              # merge with existing hash
            %defaults = (%defaults, %$yml) if defined $yml;
        }
    }

    %$self = (%$self, %defaults, %options);

    bless $self, $class;
}

###########################################
sub cmd_line_mail {
###########################################
    my($self) = @_;

    $self->{subject} = 'no subject' unless defined $self->{subject};

    my $mailer;
    $mailer = $self->{program} if defined $self->{program};
    $mailer = bin_find("mail") unless defined $mailer;

    open(PIPE, "|-", $mailer,
                    "-s", $self->{subject}, $self->{to},
        ) or LOGDIE "Opening $mailer failed: $!";

    print PIPE $self->{text};
    return close PIPE;
}

###########################################
sub send {
###########################################
    my($self, $evaled) = @_;

    if(!$self->{raise_error} && ! $evaled) {
        return $self->send_evaled();
    }

    my $msg =
          "Sending from=$self->{from} to=$self->{to} " .
          "subj=" . snip($self->{subject}, 20) . " " .
          "text=" . snip($self->{text}, 20) .
          "";

    my @options = ();

    if(0) {
    } elsif($self->{transport} eq "sendmail") {
        @options = ();
    } elsif($self->{transport} eq "smtp") {
          # Mail::SMTP likes it that way
        $ENV{ MAILADDRESS } = $self->{ from };

        LOGDIE "No smtp_server set" unless defined $self->{smtp_server};
        @options = ("smtp", Server => $self->{smtp_server});
        push @options, (Port => $self->{smtp_port})
          if exists $self->{smtp_port};
        $self->{to} = [split /\s*,\s*/, $self->{to}];

          # some smtp servers want SASL auth
        if( defined $self->{user} ) {
            require Authen::SASL;
            push @options, (Auth => [ $self->{user}, $self->{password} ]);
        }
    } elsif($self->{transport} eq "mail") {
        return $self->cmd_line_mail();
    } else {
        LOGDIE "Unknown transport '$self->{transport}'";
    }

    my $mailer = Mail::Mailer->new(@options);
    my %headers;
    for (qw(from to cc bcc subject date)) {
        $headers{ucfirst($_)} = $self->{$_} if exists $self->{$_};
    }

    my $text = $self->{text};
    if($self->{html_compat}) {
        my $h;
        ($h, $text) = html_msg($text);
        %headers = (%headers, %$h);
    }

    if($self->{attach}) {
        my $h;
        ($h, $text) = attach_msg($text, @{$self->{attach}});
        %headers = (%headers, %$h);
    }

    if($ENV{MAIL_DWIM_TEST}) {
        DEBUG "Appending to test file $ENV{MAIL_DWIM_TEST}";
        my $txt;
        for (keys %headers) {
            $txt .= "$_: $headers{$_}\n" if defined $headers{$_};
        }
        $txt .= "\n";

        test_file_append($txt . $text);
        return 1;
    } else {
        DEBUG $msg;
    }

    $mailer->open(\%headers);
    print $mailer $text;
    $mailer->close();
}

###########################################
sub send_evaled {
###########################################
    my($self) = @_;

    eval {
        return $self->send(1);
    };

    if($@) {
        error($@);
        return undef;
    }
}

###########################################
sub error {
###########################################
    my($text) = @_;

    if(defined $text) {
        $error = $text;
    }

    return $error;
}

###########################################
sub test_file_append {
###########################################
    my($msg) = @_;

    open FILE, ">>$ENV{MAIL_DWIM_TEST}" or
        LOGDIE "Cannot open $ENV{MAIL_DWIM_TEST} ($!)";
    print FILE $msg, "\n\n";
    close FILE;
}

###########################################
sub html_requirements {
###########################################

    for (@HTML_MODULES) {
        eval "require $_";
        if($@) {
            return undef;
        }
    }

    1;
}

###########################################
sub attach_requirements {
###########################################

    for (@ATTACH_MODULES) {
        eval "require $_";
        if($@) {
            return undef;
        }
    }

    1;
}

###########################################
sub html_msg {
###########################################
    my($htmltext) = @_;

    if(! html_requirements()) {
        LOGDIE "Please install ",
               join(" ", @HTML_MODULES), " from CPAN";
    }

    my $tree = HTML::TreeBuilder->new();
    $tree->parse($htmltext);
    $tree->eof();
    my $formatter = HTML::FormatText->new();
    my $plaintext = $formatter->format($tree);

    my $msg = MIME::Lite->new(
      Type    => 'multipart/alternative',
    );

    $msg->attach(
      Type => 'text/plain',
      Data => $plaintext
    );

    $msg->attach(
        Type => 'text/html',
        Data => $htmltext,
    );

    my %headers;

    for (qw(Content-Transfer-Encoding Content-Type
            MIME-version)) {
        $headers{$_} = $msg->attr($_);
    }

      # evil hack to compensate for MIME::Lite's shortcomings
    if( $headers{ "Content-Type" } !~ /boundary/ ) {
        $headers{ "Content-Type" } =
            $headers{ "Content-Type" } .
            qq{; boundary="} .
            $msg->{ SubAttrs }->{ "content-type" }->{ boundary } .
            qq{"};
    }

    return \%headers, $msg->body_as_string;
}

###########################################
sub attach_msg {
###########################################
    my($text, @files) = @_;

    if(! attach_requirements()) {
        LOGDIE "Please install ",
               join(" ", @ATTACH_MODULES), " from CPAN";
    }

    my $msg = MIME::Lite->new(
        Type => "multipart/mixed"
    );

    $msg->attach(Type     => "TEXT",
                 Data     => $text,
                );

    for my $file (@files) {
        my $mm = File::MMagic->new();
        my $type = $mm->checktype_filename($file);
        LOGDIE "Cannot determine mime type of $file" unless defined $type;

        $msg->attach(Type        => $type,
                     Path        => $file,
                     Filename    => basename($file),
                     Disposition => "attachment",
        );
    }

    my $headers = mime_lite_headers($msg);

    return $headers, $msg->body_as_string;
}

###########################################
sub mime_lite_headers {
###########################################
    my($mlite) = @_;

    my %wanted = map { lc($_) => $_ }
                     qw(Content-Transfer-Encoding Content-Type
                        MIME-version);
    my %headers = ();

    for my $field (@{$mlite->fields}) {
        if(exists $wanted{$field->[0]}) {
            my($name, $value) = split /:\s*/,
                                $mlite->fields_as_string([$field]), 2;
            $headers{$name} = $value;
        }
    }

    return(\%headers);
}

###########################################
sub header_ucfirst {
###########################################
    my($name) = @_;

    $name =~ s/^(\w)/uc($1)/g;
    $name =~ s/-(\w)/uc($1)/g;

    return $name;
}

###########################################
sub snip {
###########################################
    my($data, $maxlen) = @_;

    if(length $data <= $maxlen) {
        return lenformat($data);
    }

    $maxlen = 12 if $maxlen < 12;
    my $sniplen = int(($maxlen - 8) / 2);

    my $start   = substr($data,  0, $sniplen);
    my $end     = substr($data, -$sniplen);
    my $snipped = length($data) - 2*$sniplen;

    return lenformat("$start\[...]$end", length $data);
}

###########################################
sub lenformat {
###########################################
    my($data, $orglen) = @_;

    return "(" . ($orglen || length($data)) . ")[" .
        printable($data) . "]";
}

###########################################
sub printable {
###########################################
    my($data) = @_;

    $data =~ s/[^ \w.;!?@#$%^&*()+\\|~`'-,><[\]{}="]/./g;
    return $data;
}

###########################################
sub blurt {
###########################################
    my($data, $file) = @_;

    open FILE, ">$file" or die "Cannot open $file";
    print FILE $data;
    close FILE;
}

###########################################
sub slurp {
###########################################
    my($file) = @_;

    local($/);
    $/ = undef;

    open FILE, "<$file" or die "Cannot open $file";
    my $data = ;
    close FILE;
    return $data;
}

###########################################
sub domain {
###########################################

    my $domain = $Config{mydomain};

    if(defined $domain and length($domain)) {
        $domain =~ s/^\.//;
        return $domain;
    }

    eval { require Sys::Hostname; };
    if(! $@) {
        $domain = hostname();
        return $domain;
    }

    $domain = "localhost";

    return $domain;
}

######################################
sub bin_find {
######################################
    my($exe) = @_;

    for my $path (split /:/, $ENV{PATH}) {
        my $full = File::Spec->catfile($path, $exe);

        return $full if -x $full;
    }

    return undef;
}

1;

__END__