/[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 67 - (show annotations)
Fri Jul 8 17:00:20 2005 UTC (18 years, 7 months ago) by dpavlin
File size: 24029 byte(s)
more fixes for SOAP, still not working

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 new list to C</etc/aliases> (or equivavlent) file
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 croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});
719
720 my $aliases = $arg->{'aliases'} || croak "need aliases";
721
722 unless (-e $aliases) {
723 warn "aliases file $aliases doesn't exist, creating empty\n";
724 open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
725 close($fh);
726 chmod 0777, $aliases || warn "can't change permission to 0777";
727 }
728
729 my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
730
731 my $target = '';
732
733 if (my $archive = $arg->{'archive'}) {
734 $target .= "$archive, ";
735
736 if (! -e $archive) {
737 warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
738
739 open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
740 close($fh);
741 chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
742 }
743 }
744
745 # resolve my path to absolute one
746 my $self_path = abs_path($0);
747 $self_path =~ s#/[^/]+$##;
748 $self_path =~ s#/t/*$#/#;
749
750 $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;
751
752 unless ($a->append($arg->{'email'}, $target)) {
753 croak "can't add alias ".$a->error_check;
754 }
755
756 return 1;
757 }
758
759 =head2 _add_list
760
761 Create new list
762
763 my $list_obj = $nos->_add_list(
764 list => 'My list',
765 from => 'Outgoing from comment',
766 email => 'my-list@example.com',
767 aliases => '/etc/mail/mylist',
768 );
769
770 Returns C<Class::DBI> object for created list.
771
772 C<email> address can be with domain or without it if your
773 MTA appends it. There is no checking for validity of your
774 list e-mail. Flexibility comes with resposibility, so please
775 feed correct (and configured) return addresses.
776
777 =cut
778
779 sub _add_list {
780 my $self = shift;
781
782 my $arg = {@_};
783
784 my $name = lc($arg->{'list'}) || confess "can't add list without name";
785 my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
786 my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
787
788 my $from_addr = $arg->{'from'};
789
790 my $lists = $self->{'loader'}->find_class('lists');
791
792 $self->_add_aliases(
793 list => $name,
794 email => $email,
795 aliases => $aliases,
796 ) || croak "can't add alias $email for list $name";
797
798 my $l = $lists->find_or_create({
799 name => $name,
800 email => $email,
801 });
802
803 croak "can't add list $name\n" unless ($l);
804
805 if ($from_addr && $l->from_addr ne $from_addr) {
806 $l->from_addr($from_addr);
807 $l->update;
808 }
809
810 $l->dbi_commit;
811
812 return $l;
813
814 }
815
816
817
818 =head2 _get_list
819
820 Get list C<Class::DBI> object.
821
822 my $list_obj = $nos->check_list('My list');
823
824 Returns false on failure.
825
826 =cut
827
828 sub _get_list {
829 my $self = shift;
830
831 my $name = shift || return;
832
833 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
834
835 return $lists->search({ name => lc($name) })->first;
836 }
837
838 ###
839 ### SOAP
840 ###
841
842 package Nos::SOAP;
843
844 use Carp;
845
846 =head1 SOAP methods
847
848 This methods are thin wrappers to provide SOAP calls. They are grouped in
849 C<Nos::SOAP> package which is in same F<Nos.pm> module file.
850
851 Usually, you want to use named variables in your SOAP calls if at all
852 possible.
853
854 However, if you have broken SOAP library (like PHP SOAP class from PEAR)
855 you will want to use positional arguments (in same order as documented for
856 methods below).
857
858 =cut
859
860 my $nos;
861
862
863 =head2 new
864
865 Create new SOAP object
866
867 my $soap = new Nos::SOAP(
868 dsn => 'dbi:Pg:dbname=notices',
869 user => 'dpavlin',
870 passwd => '',
871 debug => 1,
872 verbose => 1,
873 hash_len => 8,
874 aliases => '/etc/aliases',
875 );
876
877 =cut
878
879 sub new {
880 my $class = shift;
881 my $self = {@_};
882
883 croak "need aliases parametar" unless ($self->{'aliases'});
884
885 bless($self, $class);
886
887 $nos = new Nos( @_ ) || die "can't create Nos object";
888
889 $self ? return $self : return undef;
890 }
891
892
893 =head2 NewList
894
895 $message_id = NewList(
896 list => 'My list',
897 from => 'Name of my list',
898 email => 'my-list@example.com'
899 );
900
901 =cut
902
903 sub NewList {
904 my $self = shift;
905
906 croak "self is not Nos::SOAP object" unless (ref($self) eq 'Nos::SOAP');
907
908 my $aliases = $self->{'aliases'} || croak "need 'aliases' argument to new constructor";
909
910 if ($_[0] !~ m/^HASH/) {
911 return $nos->new_list(
912 list => $_[0], from => $_[1], email => $_[2],
913 aliases => $aliases,
914 );
915 } else {
916 return $nos->new_list( %{ shift @_ }, aliases => $aliases );
917 }
918 }
919
920
921 =head2 DeleteList
922
923 $ok = DeleteList(
924 list => 'My list',
925 );
926
927 =cut
928
929 sub DeleteList {
930 my $self = shift;
931
932 if ($_[0] !~ m/^HASH/) {
933 return $nos->delete_list(
934 list => $_[0],
935 );
936 } else {
937 return $nos->delete_list( %{ shift @_ } );
938 }
939 }
940
941 =head2 AddMemberToList
942
943 $member_id = AddMemberToList(
944 list => 'My list',
945 email => 'e-mail@example.com',
946 name => 'Full Name',
947 ext_id => 42,
948 );
949
950 =cut
951
952 sub AddMemberToList {
953 my $self = shift;
954
955 if ($_[0] !~ m/^HASH/) {
956 return $nos->add_member_to_list(
957 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
958 );
959 } else {
960 return $nos->add_member_to_list( %{ shift @_ } );
961 }
962 }
963
964
965 =head2 ListMembers
966
967 my @members = ListMembers(
968 list => 'My list',
969 );
970
971 Returns array of hashes with user informations, see C<list_members>.
972
973 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
974 seems that SOAP::Lite client thinks that it has array with one element which
975 is array of hashes with data.
976
977 =cut
978
979 sub ListMembers {
980 my $self = shift;
981
982 my $list_name;
983
984 if ($_[0] !~ m/^HASH/) {
985 $list_name = shift;
986 } else {
987 $list_name = $_[0]->{'list'};
988 }
989
990 return [ $nos->list_members( list => $list_name ) ];
991 }
992
993
994 =head2 DeleteMemberFromList
995
996 $member_id = DeleteMemberFromList(
997 list => 'My list',
998 email => 'e-mail@example.com',
999 );
1000
1001 =cut
1002
1003 sub DeleteMemberFromList {
1004 my $self = shift;
1005
1006 if ($_[0] !~ m/^HASH/) {
1007 return $nos->delete_member_from_list(
1008 list => $_[0], email => $_[1],
1009 );
1010 } else {
1011 return $nos->delete_member_from_list( %{ shift @_ } );
1012 }
1013 }
1014
1015
1016 =head2 AddMessageToList
1017
1018 $message_id = AddMessageToList(
1019 list => 'My list',
1020 message => 'From: My list...'
1021 );
1022
1023 =cut
1024
1025 sub AddMessageToList {
1026 my $self = shift;
1027
1028 if ($_[0] !~ m/^HASH/) {
1029 return $nos->add_message_to_list(
1030 list => $_[0], message => $_[1],
1031 );
1032 } else {
1033 return $nos->add_message_to_list( %{ shift @_ } );
1034 }
1035 }
1036
1037
1038 ###
1039
1040 =head1 EXPORT
1041
1042 Nothing.
1043
1044 =head1 SEE ALSO
1045
1046 mailman, ezmlm, sympa, L<Mail::Salsa>
1047
1048
1049 =head1 AUTHOR
1050
1051 Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1052
1053
1054 =head1 COPYRIGHT AND LICENSE
1055
1056 Copyright (C) 2005 by Dobrica Pavlinusic
1057
1058 This library is free software; you can redistribute it and/or modify
1059 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1060 at your option, any later version of Perl 5 you may have available.
1061
1062
1063 =cut
1064
1065 1;

  ViewVC Help
Powered by ViewVC 1.1.26