/[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

Annotation of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 63 - (hide annotations)
Wed Jun 22 16:42:06 2005 UTC (18 years, 8 months ago) by dpavlin
File size: 21202 byte(s)
added delete_list and DeleteList SOAP call. No brainer. Tests now clean up
after them.

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

  ViewVC Help
Powered by ViewVC 1.1.26