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

  ViewVC Help
Powered by ViewVC 1.1.26