/[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 68 - (show annotations)
Mon Aug 1 08:59:36 2005 UTC (18 years, 8 months ago) by dpavlin
File size: 24109 byte(s)
_add_aliases now updates alias if it allready exists, added debug flag to SAOP tests

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

  ViewVC Help
Powered by ViewVC 1.1.26