view release on metacpan or  search on metacpan

lib/App/MonM/Message.pm  view on Meta::CPAN

package App::MonM::Message;
use warnings;
use strict;
use utf8;

=encoding utf-8

=head1 NAME

App::MonM::Message - The MonM Message manager

=head1 VERSION

Version 1.00

=head1 SYNOPSIS

    use App::MonM::Message;

    my $message = App::MonM::Message->new(
            recipient => "myaccount",
            to      => 'to@example.com',
            from    => 'from@example.com',
            subject => "Test message",
            body    => "Body of test message",
        );

=head1 DESCRIPTION

This is an extension for the monm messages

=head2 new

    my $message = App::MonM::Message->new(
            recipient => "myaccount",
            to      => 'to@example.com',
            cc      => 'cc@example.com',
            bcc     => 'bcc@example.com',
            from    => 'from@example.com',
            subject => "Test message",
            body    => "Body of test message",
            headers => { # optional
                    "X-My-Header" => "test",
                },
            contenttype => "text/plain", # optional
            charset     => "utf-8", # optional
            encoding    => "8bit", # optional
            attachment  => [{ # See Email::MIME
                filename => "screenshot.png",
                type     => "image/png",
                encoding => "base64",
                disposition => "attachment",
                path     => "/tmp/screenshot.png",
            }],
        );

Create new message

    my $message = App::MonM::Message->new;
    $message->load("test.msg") or die $message->error;

Load message from file

=head2 body

Returns body of message

=head2 email

    my $email_object = $message->email;

Returns L<Email::MIME> object

    $message->email($email_object);

Sets L<Email::MIME> object

=head2 error

    my $error = $message->error;

Returns error string

    $message->error( "error text" );

Sets error string

=head2 from

Returns the "From" header

=head2 genId

    my $message_id = $message->genId('to@example.com',"Test message");

Generate new ID of message

=head2 load

    my $message = App::MonM::Message->new;
    $message->load("test.msg") or die $message->error;

Load message from file

=head2 msgid

lib/App/MonM/Message.pm  view on Meta::CPAN

use CTK::Digest::FNV32a;
use CTK::ConfGenUtil;
use CTK::TFVals qw/ :ALL /;

use App::MonM::Util qw/header_field_normalize slurp node2anode/;
use App::MonM::Const qw/HOSTNAME/;

use constant {
    CONTENT_TYPE    => "text/plain",
    CHARSET         => "utf-8",
    ENCODING        => "8bit", # "quoted-printable", "8bit", "base64"
    USERNAME        => "anonymous",
};

*TO_DEFAULT = sub {
    return sprintf('%s@%s', USERNAME, HOSTNAME());
};

my @CHARS = ('a'..'f', 0..9);
my %UNIQCNT;

sub new {
    my $class = shift;
    my %args = @_;

    my $self = bless {
            email => undef, # Email::SMTP object
            msgid => undef, # X-Message-ID
            recipient => "",
            error => "",
            fnv32a => CTK::Digest::FNV32a->new(),
        }, $class;

    # No any data - returns empty object (without email)
    return $self unless %args;

    # Headers
    my $headers = $args{headers} || {};
    my $to      = $args{to} || TO_DEFAULT();
    my $recipient = $args{recipient} || $to || USERNAME;
    my $subject = $args{subject};
    my %hset = (
            To      => $to =~ /\@/ ? $to : TO_DEFAULT(),
            Subject => $subject,
        );
    foreach my $h (qw/from cc bcc/) {
        my $uh = ucfirst($h);
        $hset{$uh} = $args{$h} if $args{$h} && $args{$h} =~ /\@/;
    }

    if ($headers && is_hash($headers) && keys(%$headers)) {
        while (my ($k,$v) = each %$headers) {
            next unless defined $v;
            $hset{header_field_normalize($k)} = $v;
        }
    }

    # Attributes
    my $contenttype = $args{contenttype} // CONTENT_TYPE;
    my $charset = $args{charset} // CHARSET;
    my $encoding = $args{encoding} // ENCODING;

    # Body content
    my $body = $args{body} // '';

    # Multiparted message
    my @parts;
    my $main_part = Email::MIME->create(
        attributes => {
            content_type => $contenttype,
            charset      => $charset,
            encoding     => $encoding,
            disposition  => "inline", #disposition  => "attachment",
        },
        body_str => $body,
    );
    push @parts, $main_part;

    # Attachments
    my $attachments = node2anode($args{attachment});
    foreach my $inatt (@$attachments) {
        my $filename = lvalue($inatt, "filename") || lvalue($inatt, "file");
        next unless $filename;
        my $path = lvalue($inatt, "path");
        next unless $path && -e $path;
        my $body = slurp($path, 1) or next;
        push @parts, Email::MIME->create(
            attributes => {
                filename     => $filename,
                name         => $filename,
                content_type => lvalue($inatt, "content_type") || lvalue($inatt, "type") // "application/octet-stream",
                encoding     => lvalue($inatt, "encoding") // "base64",
                disposition  => lvalue($inatt, "disposition") // "attachment",
            },
            body => $body,
        );
    }

    # Create message (single or multipart)
    my $email = Email::MIME->create(
        header_str => [%hset],
        parts      => [ @parts ],
    );

    # Add attributes and body for single message
    #$email->content_type_set($contenttype);
    #$email->charset_set($charset);
    #$email->encoding_set($encoding);
    #$email->body_str_set($body);

    # Add X-Message-ID
    $self->{msgid} = $self->genId($to, $recipient, $subject);
    $email->header_str_set("X-Message-ID" => $self->{msgid});

    # Add X-Recipient
    $self->{recipient} = $recipient;
    $email->header_str_set("X-Recipient" => $recipient);

    # Done
    $self->email($email);

    return $self;
}

sub email {
    my $self = shift;
    my $v = shift;
    $self->{email} = $v if defined $v;
    return $self->{email};
}
sub error {
    my $self = shift;
    my $v = shift;
    $self->{error} = $v if defined $v;
    return $self->{error};
}
sub msgid {
    my $self = shift;
    return $self->{msgid};
}
sub genId {
    my $self = shift;
    my @arr = @_;
    unshift @arr, $$;
    my $text = join("|", @arr);
    my $t = time;
    my $short = $t & 0x7FFFFF;
    my $fnv = $self->{fnv32a}->digest($text) & 0xFFFFFFFF;
    my $salt = join '', map {; $CHARS[rand @CHARS] } (0..6);
    my $u = exists $UNIQCNT{$t} ? ++$UNIQCNT{$t} : (%UNIQCNT = ($t => 0))[1];
    # hex(SHORT_TIME) . hex(TIME_UNIQ_CNT) . SALT . hex(FNV32a)
    return sprintf("%x%x%s%x",$short, $u, $salt, $fnv);
}
sub save {
    my $self = shift;
    my $file = shift;
    $self->error("");
    unless ($file) {
        $self->error("No file specified");
        return;
    }
    my $email = $self->email;
    unless ($email) {
        $self->error("No email object found");
        return;
    }