/[notice-sender]/trunk/Nos.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 70 - (show annotations)
Tue Aug 2 19:41:28 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 25173 byte(s)
added _remove_alias and use it when deleting list

1 package Nos;
2
3 use 5.008;
4 use strict;
5 use warnings;
6
7 require Exporter;
8
9 our @ISA = qw(Exporter);
10
11 our %EXPORT_TAGS = ( 'all' => [ qw(
12 ) ] );
13
14 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
15
16 our @EXPORT = qw(
17 );
18
19 our $VERSION = '0.6';
20
21 use Class::DBI::Loader;
22 use Email::Valid;
23 use Email::Send;
24 use Carp;
25 use Email::Auth::AddressHash;
26 use Email::Simple;
27 use Email::Address;
28 use Mail::DeliveryStatus::BounceParser;
29 use Class::DBI::AbstractSearch;
30 use Mail::Alias;
31 use Cwd qw(abs_path);
32
33
34 =head1 NAME
35
36 Nos - Notice Sender core module
37
38 =head1 SYNOPSIS
39
40 use Nos;
41 my $nos = new Nos();
42
43 =head1 DESCRIPTION
44
45 Notice sender is mail handler. It is not MTA, since it doesn't know how to
46 receive e-mails or send them directly to other hosts. It is not mail list
47 manager because it requires programming to add list members and send
48 messages. You can think of it as mechanisam for off-loading your e-mail
49 sending to remote server using SOAP service.
50
51 It's concept is based around B<lists>. Each list can have zero or more
52 B<members>. Each list can have zero or more B<messages>.
53
54 Here comes a twist: each outgoing message will have unique e-mail generated,
55 so Notice Sender will be able to link received replies (or bounces) with
56 outgoing messages.
57
58 It doesn't do much more than that. It B<can't> create MIME encoded e-mail,
59 send attachments, handle 8-bit characters in headers (which have to be
60 encoded) or anything else.
61
62 It will just queue your e-mail message to particular list (sending it to
63 possibly remote Notice Sender SOAP server just once), send it out at
64 reasonable rate (so that it doesn't flood your e-mail infrastructure) and
65 track replies.
66
67 It is best used to send smaller number of messages to more-or-less fixed
68 list of recipients while allowing individual responses to be examined.
69 Tipical use include replacing php e-mail sending code with SOAP call to
70 Notice Sender. It does support additional C<ext_id> field for each member
71 which can be used to track some unique identifier from remote system for
72 particular user.
73
74 It comes with command-line utility C<sender.pl> which can be used to perform
75 all available operation from scripts (see C<perldoc sender.pl>).
76 This command is also useful for debugging while writing client SOAP
77 application.
78
79 =head1 METHODS
80
81 =head2 new
82
83 Create new instance specifing database, user, password and options.
84
85 my $nos = new Nos(
86 dsn => 'dbi:Pg:dbname=notices',
87 user => 'dpavlin',
88 passwd => '',
89 debug => 1,
90 verbose => 1,
91 hash_len => 8,
92 );
93
94 Parametar C<hash_len> defines length of hash which will be added to each
95 outgoing e-mail message to ensure that replies can be linked with sent e-mails.
96
97 =cut
98
99 sub new {
100 my $class = shift;
101 my $self = {@_};
102 bless($self, $class);
103
104 croak "need at least dsn" unless ($self->{'dsn'});
105
106 $self->{'loader'} = Class::DBI::Loader->new(
107 debug => $self->{'debug'},
108 dsn => $self->{'dsn'},
109 user => $self->{'user'},
110 password => $self->{'passwd'},
111 namespace => "Nos",
112 additional_classes => qw/Class::DBI::AbstractSearch/,
113 # additional_base_classes => qw/My::Stuff/,
114 relationships => 1,
115 ) || croak "can't init Class::DBI::Loader";
116
117 $self->{'hash_len'} ||= 8;
118
119 $self ? return $self : return undef;
120 }
121
122
123 =head2 new_list
124
125 Create new list. Required arguments are name of C<list>, C<email> address
126 and path to C<aliases> file.
127
128 $nos->new_list(
129 list => 'My list',
130 from => 'Outgoing from comment',
131 email => 'my-list@example.com',
132 aliases => '/etc/mail/mylist',
133 archive => '/path/to/mbox/archive',
134 );
135
136 Returns ID of newly created list.
137
138 Calls internally C<_add_list>, see details there.
139
140 =cut
141
142 sub new_list {
143 my $self = shift;
144
145 my $arg = {@_};
146
147 confess "need list name" unless ($arg->{'list'});
148 confess "need list email" unless ($arg->{'email'});
149
150 $arg->{'list'} = lc($arg->{'list'});
151 $arg->{'email'} = lc($arg->{'email'});
152
153 my $l = $self->_get_list($arg->{'list'}) ||
154 $self->_add_list( @_ ) ||
155 return undef;
156
157 return $l->id;
158 }
159
160
161 =head2 delete_list
162
163 Delete list from database.
164
165 my $ok = delete_list(
166 list => 'My list'
167 aliases => '/etc/mail/mylist',
168 );
169
170 Returns false if list doesn't exist.
171
172 =cut
173
174 sub delete_list {
175 my $self = shift;
176
177 my $args = {@_};
178
179 croak "need list to delete" unless ($args->{'list'});
180
181 $args->{'list'} = lc($args->{'list'});
182
183 my $aliases = $args->{'aliases'} || croak "need path to aliases file";
184
185 my $lists = $self->{'loader'}->find_class('lists');
186
187 my $this_list = $lists->search( name => $args->{'list'} )->first || return;
188
189 $self->_remove_alias( email => $this_list->email, aliases => $aliases);
190
191 $this_list->delete || croak "can't delete list\n";
192
193 return $lists->dbi_commit || croak "can't commit";
194 }
195
196
197 =head2 add_member_to_list
198
199 Add new member to list
200
201 $nos->add_member_to_list(
202 list => "My list",
203 email => "john.doe@example.com",
204 name => "John A. Doe",
205 ext_id => 42,
206 );
207
208 C<name> and C<ext_id> parametars are optional.
209
210 Return member ID if user is added.
211
212 =cut
213
214 sub add_member_to_list {
215 my $self = shift;
216
217 my $arg = {@_};
218
219 my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
220 my $name = $arg->{'name'} || '';
221 my $list_name = lc($arg->{'list'}) || croak "need list name";
222 my $ext_id = $arg->{'ext_id'};
223
224 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
225
226 if (! Email::Valid->address($email)) {
227 carp "SKIPPING $name <$email>\n";
228 return 0;
229 }
230
231 carp "# $name <$email>\n" if ($self->{'verbose'});
232
233 my $users = $self->{'loader'}->find_class('users');
234 my $user_list = $self->{'loader'}->find_class('user_list');
235
236 my $this_user = $users->find_or_create({
237 email => $email,
238 }) || croak "can't find or create member\n";
239
240 if ($name && $this_user->name ne $name) {
241 $this_user->name($name || '');
242 $this_user->update;
243 }
244
245 if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
246 $this_user->ext_id($ext_id);
247 $this_user->update;
248 }
249
250 my $user_on_list = $user_list->find_or_create({
251 user_id => $this_user->id,
252 list_id => $list->id,
253 }) || croak "can't add user to list";
254
255 $list->dbi_commit;
256 $this_user->dbi_commit;
257 $user_on_list->dbi_commit;
258
259 return $this_user->id;
260 }
261
262 =head2 list_members
263
264 List all members of some list.
265
266 my @members = list_members(
267 list => 'My list',
268 );
269
270 Returns array of hashes with user informations like this:
271
272 $member = {
273 name => 'Dobrica Pavlinusic',
274 email => 'dpavlin@rot13.org
275 }
276
277 If list is not found, returns false. If there is C<ext_id> in user data,
278 it will also be returned.
279
280 =cut
281
282 sub list_members {
283 my $self = shift;
284
285 my $args = {@_};
286
287 my $list_name = lc($args->{'list'}) || confess "need list name";
288
289 my $lists = $self->{'loader'}->find_class('lists');
290 my $user_list = $self->{'loader'}->find_class('user_list');
291
292 my $this_list = $lists->search( name => $list_name )->first || return;
293
294 my @results;
295
296 foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
297 my $row = {
298 name => $user_on_list->user_id->name,
299 email => $user_on_list->user_id->email,
300 };
301
302 my $ext_id = $user_on_list->user_id->ext_id;
303 $row->{'ext_id'} = $ext_id if (defined($ext_id));
304
305 push @results, $row;
306 }
307
308 return @results;
309
310 }
311
312
313 =head2 delete_member
314
315 Delete member from database.
316
317 my $ok = delete_member(
318 name => 'Dobrica Pavlinusic'
319 );
320
321 my $ok = delete_member(
322 email => 'dpavlin@rot13.org'
323 );
324
325 Returns false if user doesn't exist.
326
327 This function will delete member from all lists (by cascading delete), so it
328 shouldn't be used lightly.
329
330 =cut
331
332 sub delete_member {
333 my $self = shift;
334
335 my $args = {@_};
336
337 croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
338
339 $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
340
341 my $key = 'name';
342 $key = 'email' if ($args->{'email'});
343
344 my $users = $self->{'loader'}->find_class('users');
345
346 my $this_user = $users->search( $key => $args->{$key} )->first || return;
347
348 $this_user->delete || croak "can't delete user\n";
349
350 return $users->dbi_commit || croak "can't commit";
351 }
352
353 =head2 delete_member_from_list
354
355 Delete member from particular list.
356
357 my $ok = delete_member_from_list(
358 list => 'My list',
359 email => 'dpavlin@rot13.org',
360 );
361
362 Returns false if user doesn't exist on that particular list.
363
364 It will die if list or user doesn't exist. You have been warned (you might
365 want to eval this functon to prevent it from croaking).
366
367 =cut
368
369 sub delete_member_from_list {
370 my $self = shift;
371
372 my $args = {@_};
373
374 croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
375
376 $args->{'list'} = lc($args->{'list'});
377 $args->{'email'} = lc($args->{'email'});
378
379 my $user = $self->{'loader'}->find_class('users');
380 my $list = $self->{'loader'}->find_class('lists');
381 my $user_list = $self->{'loader'}->find_class('user_list');
382
383 my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
384 my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
385
386 my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_user->id )->first || return;
387
388 $this_user_list->delete || croak "can't delete user from list\n";
389
390 return $user_list->dbi_commit || croak "can't commit";
391 }
392
393 =head2 add_message_to_list
394
395 Adds message to one list's queue for later sending.
396
397 $nos->add_message_to_list(
398 list => 'My list',
399 message => 'Subject: welcome to list
400
401 This is example message
402 ',
403 );
404
405 On success returns ID of newly created (or existing) message.
406
407 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
408 will be automatically generated, but if you want to use own headers, just
409 include them in messages.
410
411 =cut
412
413 sub add_message_to_list {
414 my $self = shift;
415
416 my $args = {@_};
417
418 my $list_name = lc($args->{'list'}) || confess "need list name";
419 my $message_text = $args->{'message'} || croak "need message";
420
421 my $m = Email::Simple->new($message_text) || croak "can't parse message";
422
423 unless( $m->header('Subject') ) {
424 warn "message doesn't have Subject header\n";
425 return;
426 }
427
428 my $lists = $self->{'loader'}->find_class('lists');
429
430 my $this_list = $lists->search(
431 name => $list_name,
432 )->first || croak "can't find list $list_name";
433
434 my $messages = $self->{'loader'}->find_class('messages');
435
436 my $this_message = $messages->find_or_create({
437 message => $message_text
438 }) || croak "can't insert message";
439
440 $this_message->dbi_commit() || croak "can't add message";
441
442 my $queue = $self->{'loader'}->find_class('queue');
443
444 $queue->find_or_create({
445 message_id => $this_message->id,
446 list_id => $this_list->id,
447 }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
448
449 $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
450
451 return $this_message->id;
452 }
453
454
455 =head2 send_queued_messages
456
457 Send queued messages or just ones for selected list
458
459 $nos->send_queued_messages(
460 list => 'My list',
461 driver => 'smtp',
462 sleep => 3,
463 );
464
465 Second option is driver which will be used for e-mail delivery. If not
466 specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
467
468 Other valid drivers are:
469
470 =over 10
471
472 =item smtp
473
474 Send e-mail using SMTP server at 127.0.0.1
475
476 =back
477
478 Default sleep wait between two messages is 3 seconds.
479
480 =cut
481
482 sub send_queued_messages {
483 my $self = shift;
484
485 my $arg = {@_};
486
487 my $list_name = lc($arg->{'list'}) || '';
488 my $driver = $arg->{'driver'} || '';
489 my $sleep = $arg->{'sleep'};
490 $sleep ||= 3 unless defined($sleep);
491
492 my $email_send_driver = 'Email::Send::IO';
493 my @email_send_options;
494
495 if (lc($driver) eq 'smtp') {
496 $email_send_driver = 'Email::Send::SMTP';
497 @email_send_options = ['127.0.0.1'];
498 } else {
499 warn "dumping all messages to STDERR\n";
500 }
501
502 my $lists = $self->{'loader'}->find_class('lists');
503 my $queue = $self->{'loader'}->find_class('queue');
504 my $user_list = $self->{'loader'}->find_class('user_list');
505 my $sent = $self->{'loader'}->find_class('sent');
506
507 my $my_q;
508 if ($list_name ne '') {
509 my $l_id = $lists->search_like( name => $list_name )->first ||
510 croak "can't find list $list_name";
511 $my_q = $queue->search_like( list_id => $l_id ) ||
512 croak "can't find list $list_name";
513 } else {
514 $my_q = $queue->retrieve_all;
515 }
516
517 while (my $m = $my_q->next) {
518 next if ($m->all_sent);
519
520 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
521 my $msg = $m->message_id->message;
522
523 foreach my $u ($user_list->search(list_id => $m->list_id)) {
524
525 my $to_email = $u->user_id->email;
526
527 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
528
529 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
530 print "SKIP $to_email message allready sent\n";
531 } else {
532 print "=> $to_email ";
533
534 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
535 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
536
537 my $hash = $auth->generate_hash( $to_email );
538
539 my $from_addr;
540 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
541
542 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
543 $from_addr .= '<' . $from_email_only . '>';
544 my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
545
546 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
547
548 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
549 $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
550 $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
551 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
552 $m_obj->header_set('To', $to) || croak "can't set To: header";
553
554 $m_obj->header_set('X-Nos-Version', $VERSION);
555 $m_obj->header_set('X-Nos-Hash', $hash);
556
557 # really send e-mail
558 my $sent_status;
559
560 if (@email_send_options) {
561 $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
562 } else {
563 $sent_status = send $email_send_driver => $m_obj->as_string;
564 }
565
566 croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
567 my @bad = @{ $sent_status->prop('bad') };
568 croak "failed sending to ",join(",",@bad) if (@bad);
569
570 if ($sent_status) {
571
572 $sent->create({
573 message_id => $m->message_id,
574 user_id => $u->user_id,
575 hash => $hash,
576 });
577 $sent->dbi_commit;
578
579 print " - $sent_status\n";
580
581 } else {
582 warn "ERROR: $sent_status\n";
583 }
584
585 if ($sleep) {
586 warn "sleeping $sleep seconds\n";
587 sleep($sleep);
588 }
589 }
590 }
591 $m->all_sent(1);
592 $m->update;
593 $m->dbi_commit;
594 }
595
596 }
597
598 =head2 inbox_message
599
600 Receive single message for list's inbox.
601
602 my $ok = $nos->inbox_message(
603 list => 'My list',
604 message => $message,
605 );
606
607 This method is used by C<sender.pl> when receiving e-mail messages.
608
609 =cut
610
611 sub inbox_message {
612 my $self = shift;
613
614 my $arg = {@_};
615
616 return unless ($arg->{'message'});
617 croak "need list name" unless ($arg->{'list'});
618
619 $arg->{'list'} = lc($arg->{'list'});
620
621 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
622
623 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
624
625 my $to = $m->header('To') || die "can't find To: address in incomming message\n";
626
627 my $return_path = $m->header('Return-Path') || '';
628
629 my @addrs = Email::Address->parse( $to );
630
631 die "can't parse To: $to address\n" unless (@addrs);
632
633 my $hl = $self->{'hash_len'} || confess "no hash_len?";
634
635 my $hash;
636
637 foreach my $a (@addrs) {
638 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
639 $hash = $1;
640 last;
641 }
642 }
643
644 #warn "can't find hash in e-mail $to\n" unless ($hash);
645
646 my $sent = $self->{'loader'}->find_class('sent');
647
648 # will use null if no matching message_id is found
649 my $sent_msg;
650 $sent_msg = $sent->search( hash => $hash )->first if ($hash);
651
652 my ($message_id, $user_id) = (undef, undef); # init with NULL
653
654 if ($sent_msg) {
655 $message_id = $sent_msg->message_id || carp "no message_id";
656 $user_id = $sent_msg->user_id || carp "no user_id";
657 } else {
658 #warn "can't find sender with hash $hash\n";
659 my $users = $self->{'loader'}->find_class('users');
660 my $from = $m->header('From');
661 $from = $1 if ($from =~ m/<(.*)>/);
662 my $this_user = $users->search( email => lc($from) )->first;
663 $user_id = $this_user->id if ($this_user);
664 }
665
666
667 my $is_bounce = 0;
668
669 if ($return_path eq '<>' || $return_path eq '') {
670 no warnings;
671 my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
672 $arg->{'message'}, { report_non_bounces=>1 },
673 ) };
674 #warn "can't check if this message is bounce!" if ($@);
675
676 $is_bounce++ if ($bounce && $bounce->is_bounce);
677 }
678
679 my $received = $self->{'loader'}->find_class('received');
680
681 my $this_received = $received->find_or_create({
682 user_id => $user_id,
683 list_id => $this_list->id,
684 message_id => $message_id,
685 message => $arg->{'message'},
686 bounced => $is_bounce,
687 }) || croak "can't insert received message";
688
689 $this_received->dbi_commit;
690
691 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
692 }
693
694
695 =head1 INTERNAL METHODS
696
697 Beware of dragons! You shouldn't need to call those methods directly.
698
699
700 =head2 _add_aliases
701
702 Add or update alias in C</etc/aliases> (or equivavlent) file for selected list
703
704 my $ok = $nos->add_aliases(
705 list => 'My list',
706 email => 'my-list@example.com',
707 aliases => '/etc/mail/mylist',
708 archive => '/path/to/mbox/archive',
709
710 );
711
712 C<archive> parametar is optional.
713
714 Return false on failure.
715
716 =cut
717
718 sub _add_aliases {
719 my $self = shift;
720
721 my $arg = {@_};
722
723 foreach my $o (qw/list email aliases/) {
724 croak "need $o option" unless ($arg->{$o});
725 }
726
727 my $aliases = $arg->{'aliases'};
728 my $email = $arg->{'email'};
729 my $list = $arg->{'list'};
730
731 unless (-e $aliases) {
732 warn "aliases file $aliases doesn't exist, creating empty\n";
733 open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
734 close($fh);
735 chmod 0777, $aliases || warn "can't change permission to 0777";
736 }
737
738 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
739
740 my $target = '';
741
742 if (my $archive = $arg->{'archive'}) {
743 $target .= "$archive, ";
744
745 if (! -e $archive) {
746 warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
747
748 open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
749 close($fh);
750 chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
751 }
752 }
753
754 # resolve my path to absolute one
755 my $self_path = abs_path($0);
756 $self_path =~ s#/[^/]+$##;
757 $self_path =~ s#/t/*$#/#;
758
759 $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
760
761 if ($a->exists($email)) {
762 $a->update($email, $target) or croak "can't update alias ".$a->error_check;
763 } else {
764 $a->append($email, $target) or croak "can't add alias ".$a->error_check;
765 }
766
767 #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
768
769 return 1;
770 }
771
772 =head2 _add_list
773
774 Create new list
775
776 my $list_obj = $nos->_add_list(
777 list => 'My list',
778 from => 'Outgoing from comment',
779 email => 'my-list@example.com',
780 aliases => '/etc/mail/mylist',
781 );
782
783 Returns C<Class::DBI> object for created list.
784
785 C<email> address can be with domain or without it if your
786 MTA appends it. There is no checking for validity of your
787 list e-mail. Flexibility comes with resposibility, so please
788 feed correct (and configured) return addresses.
789
790 =cut
791
792 sub _add_list {
793 my $self = shift;
794
795 my $arg = {@_};
796
797 my $name = lc($arg->{'list'}) || confess "can't add list without name";
798 my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
799 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
800
801 my $from_addr = $arg->{'from'};
802
803 my $lists = $self->{'loader'}->find_class('lists');
804
805 $self->_add_aliases(
806 list => $name,
807 email => $email,
808 aliases => $aliases,
809 ) || warn "can't add alias $email for list $name";
810
811 my $l = $lists->find_or_create({
812 name => $name,
813 email => $email,
814 });
815
816 croak "can't add list $name\n" unless ($l);
817
818 if ($from_addr && $l->from_addr ne $from_addr) {
819 $l->from_addr($from_addr);
820 $l->update;
821 }
822
823 $l->dbi_commit;
824
825 return $l;
826
827 }
828
829
830
831 =head2 _get_list
832
833 Get list C<Class::DBI> object.
834
835 my $list_obj = $nos->check_list('My list');
836
837 Returns false on failure.
838
839 =cut
840
841 sub _get_list {
842 my $self = shift;
843
844 my $name = shift || return;
845
846 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
847
848 return $lists->search({ name => lc($name) })->first;
849 }
850
851
852 =head2 _remove_alias
853
854 Remove list alias
855
856 my $ok = $nos->_remove_alias(
857 email => 'mylist@example.com',
858 aliases => '/etc/mail/mylist',
859 );
860
861 Returns true if list is removed or false if list doesn't exist. Dies in case of error.
862
863 =cut
864
865 sub _remove_alias {
866 my $self = shift;
867
868 my $arg = {@_};
869
870 my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
871 my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
872
873 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
874
875 if ($a->exists($email)) {
876 $a->delete($email) || croak "can't remove alias $email";
877 } else {
878 return 0;
879 }
880
881 return 1;
882
883 }
884
885 ###
886 ### SOAP
887 ###
888
889 package Nos::SOAP;
890
891 use Carp;
892
893 =head1 SOAP methods
894
895 This methods are thin wrappers to provide SOAP calls. They are grouped in
896 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
897
898 Usually, you want to use named variables in your SOAP calls if at all
899 possible.
900
901 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
902 you will want to use positional arguments (in same order as documented for
903 methods below).
904
905 =cut
906
907 my $nos;
908
909
910 =head2 new
911
912 Create new SOAP object
913
914 my $soap = new Nos::SOAP(
915 dsn => 'dbi:Pg:dbname=notices',
916 user => 'dpavlin',
917 passwd => '',
918 debug => 1,
919 verbose => 1,
920 hash_len => 8,
921 aliases => '/etc/aliases',
922 );
923
924 =cut
925
926 sub new {
927 my $class = shift;
928 my $self = {@_};
929
930 croak "need aliases parametar" unless ($self->{'aliases'});
931
932 bless($self, $class);
933
934 $nos = new Nos( @_ ) || die "can't create Nos object";
935
936 $self ? return $self : return undef;
937 }
938
939
940 =head2 NewList
941
942 $message_id = NewList(
943 list => 'My list',
944 from => 'Name of my list',
945 email => 'my-list@example.com'
946 );
947
948 =cut
949
950 sub NewList {
951 my $self = shift;
952
953 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
954
955 if ($_[0] !~ m/^HASH/) {
956 return $nos->new_list(
957 list => $_[0], from => $_[1], email => $_[2],
958 aliases => $aliases,
959 );
960 } else {
961 return $nos->new_list( %{ shift @_ }, aliases => $aliases );
962 }
963 }
964
965
966 =head2 DeleteList
967
968 $ok = DeleteList(
969 list => 'My list',
970 );
971
972 =cut
973
974 sub DeleteList {
975 my $self = shift;
976
977 my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
978
979 if ($_[0] !~ m/^HASH/) {
980 return $nos->delete_list(
981 list => $_[0],
982 aliases => $aliases,
983 );
984 } else {
985 return $nos->delete_list( %{ shift @_ }, aliases => $aliases );
986 }
987 }
988
989 =head2 AddMemberToList
990
991 $member_id = AddMemberToList(
992 list => 'My list',
993 email => 'e-mail@example.com',
994 name => 'Full Name',
995 ext_id => 42,
996 );
997
998 =cut
999
1000 sub AddMemberToList {
1001 my $self = shift;
1002
1003 if ($_[0] !~ m/^HASH/) {
1004 return $nos->add_member_to_list(
1005 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
1006 );
1007 } else {
1008 return $nos->add_member_to_list( %{ shift @_ } );
1009 }
1010 }
1011
1012
1013 =head2 ListMembers
1014
1015 my @members = ListMembers(
1016 list => 'My list',
1017 );
1018
1019 Returns array of hashes with user informations, see C<list_members>.
1020
1021 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1022 seems that SOAP::Lite client thinks that it has array with one element which
1023 is array of hashes with data.
1024
1025 =cut
1026
1027 sub ListMembers {
1028 my $self = shift;
1029
1030 my $list_name;
1031
1032 if ($_[0] !~ m/^HASH/) {
1033 $list_name = shift;
1034 } else {
1035 $list_name = $_[0]->{'list'};
1036 }
1037
1038 return [ $nos->list_members( list => $list_name ) ];
1039 }
1040
1041
1042 =head2 DeleteMemberFromList
1043
1044 $member_id = DeleteMemberFromList(
1045 list => 'My list',
1046 email => 'e-mail@example.com',
1047 );
1048
1049 =cut
1050
1051 sub DeleteMemberFromList {
1052 my $self = shift;
1053
1054 if ($_[0] !~ m/^HASH/) {
1055 return $nos->delete_member_from_list(
1056 list => $_[0], email => $_[1],
1057 );
1058 } else {
1059 return $nos->delete_member_from_list( %{ shift @_ } );
1060 }
1061 }
1062
1063
1064 =head2 AddMessageToList
1065
1066 $message_id = AddMessageToList(
1067 list => 'My list',
1068 message => 'From: My list...'
1069 );
1070
1071 =cut
1072
1073 sub AddMessageToList {
1074 my $self = shift;
1075
1076 if ($_[0] !~ m/^HASH/) {
1077 return $nos->add_message_to_list(
1078 list => $_[0], message => $_[1],
1079 );
1080 } else {
1081 return $nos->add_message_to_list( %{ shift @_ } );
1082 }
1083 }
1084
1085
1086 ###
1087
1088 =head1 EXPORT
1089
1090 Nothing.
1091
1092 =head1 SEE ALSO
1093
1094 mailman, ezmlm, sympa, L<Mail::Salsa>
1095
1096
1097 =head1 AUTHOR
1098
1099 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1100
1101
1102 =head1 COPYRIGHT AND LICENSE
1103
1104 Copyright (C) 2005 by Dobrica Pavlinusic
1105
1106 This library is free software; you can redistribute it and/or modify
1107 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1108 at your option, any later version of Perl 5 you may have available.
1109
1110
1111 =cut
1112
1113 1;

  ViewVC Help
Powered by ViewVC 1.1.26