16 |
our @EXPORT = qw( |
our @EXPORT = qw( |
17 |
); |
); |
18 |
|
|
19 |
our $VERSION = '0.8'; |
our $VERSION = '0.9_00'; |
20 |
|
|
|
use Class::DBI::Loader; |
|
21 |
use Email::Valid; |
use Email::Valid; |
22 |
use Email::Send; |
use Email::Send; |
23 |
use Carp; |
use Carp; |
25 |
use Email::Simple; |
use Email::Simple; |
26 |
use Email::Address; |
use Email::Address; |
27 |
use Mail::DeliveryStatus::BounceParser; |
use Mail::DeliveryStatus::BounceParser; |
|
use Class::DBI::AbstractSearch; |
|
|
use SQL::Abstract; |
|
28 |
use Mail::Alias; |
use Mail::Alias; |
29 |
use Cwd qw(abs_path); |
use Cwd qw(abs_path); |
30 |
|
|
31 |
|
use Jifty::DBI::Handle; |
32 |
|
use lib 'lib'; |
33 |
|
use Nos::Lists; |
34 |
|
|
35 |
|
|
36 |
=head1 NAME |
=head1 NAME |
37 |
|
|
91 |
debug => 1, |
debug => 1, |
92 |
verbose => 1, |
verbose => 1, |
93 |
hash_len => 8, |
hash_len => 8, |
94 |
|
full_hostname_in_aliases => 0, |
95 |
); |
); |
96 |
|
|
97 |
Parametar C<hash_len> defines length of hash which will be added to each |
Parametar C<hash_len> defines length of hash which will be added to each |
98 |
outgoing e-mail message to ensure that replies can be linked with sent e-mails. |
outgoing e-mail message to ensure that replies can be linked with sent e-mails. |
99 |
|
|
100 |
|
C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix |
101 |
|
postalias) to include full hostname in aliases file. |
102 |
|
|
103 |
|
|
104 |
=cut |
=cut |
105 |
|
|
106 |
sub new { |
sub new { |
107 |
my $class = shift; |
my $class = shift; |
108 |
my $self = {@_}; |
my $self = {@_}; |
109 |
bless($self, $class); |
bless($self, $class); |
110 |
|
|
111 |
croak "need at least dsn" unless ($self->{'dsn'}); |
croak "need at least dsn" unless ($self->{dsn}); |
112 |
|
|
113 |
|
my (undef,$driver,$dbname) = split(/:/, $self->{dsn}); |
114 |
|
$dbname =~ s!^dbname=!!; |
115 |
|
|
116 |
|
$self->{h} = Jifty::DBI::Handle->new(); |
117 |
|
$self->{h}->connect( |
118 |
|
driver => $driver, |
119 |
|
database => $dbname, |
120 |
|
host => 'localhost', |
121 |
|
user => $self->{user}, |
122 |
|
password => $self->{passwd}, |
123 |
|
); |
124 |
|
|
125 |
$self->{'loader'} = Class::DBI::Loader->new( |
$self->{'loader'} = Class::DBI::Loader->new( |
126 |
debug => $self->{'debug'}, |
debug => $self->{'debug'}, |
127 |
dsn => $self->{'dsn'}, |
dsn => $self->{'dsn'}, |
128 |
user => $self->{'user'}, |
user => $self->{'user'}, |
129 |
password => $self->{'passwd'}, |
password => $self->{'passwd'}, |
130 |
namespace => "Nos", |
namespace => "Nos", |
439 |
|
|
440 |
my $m = Email::Simple->new($message_text) || croak "can't parse message"; |
my $m = Email::Simple->new($message_text) || croak "can't parse message"; |
441 |
|
|
442 |
unless( $m->header('Subject') ) { |
warn "message doesn't have Subject header\n" unless( $m->header('Subject') ); |
|
warn "message doesn't have Subject header\n"; |
|
|
return; |
|
|
} |
|
443 |
|
|
444 |
my $lists = $self->{'loader'}->find_class('lists'); |
my $lists = $self->{'loader'}->find_class('lists'); |
445 |
|
|
571 |
my $m_obj = Email::Simple->new($msg) || croak "can't parse message"; |
my $m_obj = Email::Simple->new($msg) || croak "can't parse message"; |
572 |
|
|
573 |
$m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header"; |
$m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header"; |
574 |
$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header"; |
#$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header"; |
575 |
$m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header"; |
$m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header"; |
576 |
$m_obj->header_set('From', $from_addr) || croak "can't set From: header"; |
$m_obj->header_set('From', $from_addr) || croak "can't set From: header"; |
577 |
$m_obj->header_set('To', $to) || croak "can't set To: header"; |
$m_obj->header_set('To', $to) || croak "can't set To: header"; |
884 |
$target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#; |
$target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#; |
885 |
|
|
886 |
# remove hostname from email to make Postfix's postalias happy |
# remove hostname from email to make Postfix's postalias happy |
887 |
$email =~ s/@.+//; |
$email =~ s/@.+// if (not $self->{full_hostname_in_aliases}); |
888 |
|
|
889 |
if ($a->exists($email)) { |
if ($a->exists($email)) { |
890 |
$a->update($email, $target) or croak "can't update alias ".$a->error_check; |
$a->update($email, $target) or croak "can't update alias ".$a->error_check; |
892 |
$a->append($email, $target) or croak "can't add alias ".$a->error_check; |
$a->append($email, $target) or croak "can't add alias ".$a->error_check; |
893 |
} |
} |
894 |
|
|
895 |
#$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check; |
# $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check; |
896 |
|
|
897 |
return 1; |
return 1; |
898 |
} |
} |
917 |
|
|
918 |
=cut |
=cut |
919 |
|
|
920 |
|
sub find_or_create { |
921 |
|
my $self = shift; |
922 |
|
my $obj = shift; |
923 |
|
my %args = {@_}; |
924 |
|
|
925 |
|
my ( $id, $msg ) = $obj->load_by_cols(%args); |
926 |
|
unless ( $obj->{values}->{id} ) { |
927 |
|
warn "find_or_CREATE(",dump( \%args ), ")"; |
928 |
|
return $obj->create(%args); |
929 |
|
} |
930 |
|
|
931 |
|
warn "FIND_or_create(",dump( \%args ), ") = $id"; |
932 |
|
return $id; |
933 |
|
} |
934 |
|
|
935 |
|
|
936 |
sub _add_list { |
sub _add_list { |
937 |
my $self = shift; |
my $self = shift; |
938 |
|
|
944 |
|
|
945 |
my $from_addr = $arg->{'from'}; |
my $from_addr = $arg->{'from'}; |
946 |
|
|
947 |
my $lists = $self->{'loader'}->find_class('lists'); |
my $lists = Nos::Lists->new( handle => $self->{h} ); |
948 |
|
|
949 |
$self->_add_aliases( |
$self->_add_aliases( |
950 |
list => $name, |
list => $name, |
952 |
aliases => $aliases, |
aliases => $aliases, |
953 |
) || warn "can't add alias $email for list $name"; |
) || warn "can't add alias $email for list $name"; |
954 |
|
|
955 |
my $l = $lists->find_or_create({ |
my $l = $self->find_or_create($lists, { |
956 |
name => $name, |
name => $name, |
957 |
email => $email, |
email => $email, |
958 |
}); |
}); |
1072 |
=cut |
=cut |
1073 |
|
|
1074 |
sub new { |
sub new { |
1075 |
my $class = shift; |
my $class = shift; |
1076 |
my $self = {@_}; |
my $self = {@_}; |
1077 |
|
|
1078 |
croak "need aliases parametar" unless ($self->{'aliases'}); |
croak "need aliases parametar" unless ($self->{'aliases'}); |
1079 |
|
|
1250 |
|
|
1251 |
if ($_[0] !~ m/^HASH/) { |
if ($_[0] !~ m/^HASH/) { |
1252 |
die "need at least list or email" unless (scalar @_ < 2); |
die "need at least list or email" unless (scalar @_ < 2); |
1253 |
return $nos->received_messages( |
return \@{ $nos->received_messages( |
1254 |
list => $_[0], email => $_[1], |
list => $_[0], email => $_[1], |
1255 |
from_date => $_[2], to_date => $_[3], |
from_date => $_[2], to_date => $_[3], |
1256 |
message => $_[4] |
message => $_[4] |
1257 |
); |
) }; |
1258 |
} else { |
} else { |
1259 |
my $arg = shift; |
my $arg = shift; |
1260 |
die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'}); |
die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'}); |
1261 |
return $nos->received_messages( %{ $arg } ); |
return \@{ $nos->received_messages( %{ $arg } ) }; |
1262 |
} |
} |
1263 |
} |
} |
1264 |
|
|
1270 |
seems that SOAP::Lite client thinks that it has array with one element which |
seems that SOAP::Lite client thinks that it has array with one element which |
1271 |
is array of hashes with data. |
is array of hashes with data. |
1272 |
|
|
1273 |
|
=head1 PRIVATE METHODS |
1274 |
|
|
1275 |
|
Documented here because tests use them |
1276 |
|
|
1277 |
|
=head2 _nos_object |
1278 |
|
|
1279 |
|
my $nos = $nos->_nos_object; |
1280 |
|
|
1281 |
|
=cut |
1282 |
|
|
1283 |
|
sub _nos_object { |
1284 |
|
return $nos; |
1285 |
|
} |
1286 |
|
|
1287 |
=head1 EXPORT |
=head1 EXPORT |
1288 |
|
|
1289 |
Nothing. |
Nothing. |