/[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 60 - (hide annotations)
Tue Jun 21 21:24:10 2005 UTC (18 years, 8 months ago) by dpavlin
File size: 19883 byte(s)
improved documentation

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 23 =head2 add_member_to_list
158    
159     Add new member to list
160    
161     $nos->add_member_to_list(
162     list => "My list",
163     email => "john.doe@example.com",
164     name => "John A. Doe",
165 dpavlin 56 ext_id => 42,
166 dpavlin 23 );
167    
168 dpavlin 56 C<name> and C<ext_id> parametars are optional.
169 dpavlin 23
170 dpavlin 27 Return member ID if user is added.
171 dpavlin 23
172     =cut
173    
174     sub add_member_to_list {
175     my $self = shift;
176    
177     my $arg = {@_};
178    
179 dpavlin 52 my $email = lc($arg->{'email'}) || croak "can't add user without e-mail";
180 dpavlin 23 my $name = $arg->{'name'} || '';
181 dpavlin 52 my $list_name = lc($arg->{'list'}) || croak "need list name";
182 dpavlin 56 my $ext_id = $arg->{'ext_id'};
183 dpavlin 23
184 dpavlin 30 my $list = $self->_get_list($list_name) || croak "list $list_name doesn't exist";
185    
186 dpavlin 23 if (! Email::Valid->address($email)) {
187 dpavlin 33 carp "SKIPPING $name <$email>\n";
188 dpavlin 23 return 0;
189     }
190    
191 dpavlin 29 carp "# $name <$email>\n" if ($self->{'verbose'});
192 dpavlin 23
193     my $users = $self->{'loader'}->find_class('users');
194     my $user_list = $self->{'loader'}->find_class('user_list');
195    
196     my $this_user = $users->find_or_create({
197     email => $email,
198     }) || croak "can't find or create member\n";
199    
200 dpavlin 45 if ($name && $this_user->name ne $name) {
201     $this_user->name($name || '');
202 dpavlin 33 $this_user->update;
203     }
204    
205 dpavlin 56 if (defined($ext_id) && ($this_user->ext_id || '') ne $ext_id) {
206     $this_user->ext_id($ext_id);
207     $this_user->update;
208     }
209    
210 dpavlin 23 my $user_on_list = $user_list->find_or_create({
211     user_id => $this_user->id,
212     list_id => $list->id,
213     }) || croak "can't add user to list";
214    
215     $list->dbi_commit;
216     $this_user->dbi_commit;
217     $user_on_list->dbi_commit;
218    
219 dpavlin 27 return $this_user->id;
220 dpavlin 23 }
221    
222 dpavlin 43 =head2 list_members
223    
224 dpavlin 45 List all members of some list.
225    
226 dpavlin 43 my @members = list_members(
227     list => 'My list',
228     );
229    
230     Returns array of hashes with user informations like this:
231    
232     $member = {
233 dpavlin 45 name => 'Dobrica Pavlinusic',
234 dpavlin 43 email => 'dpavlin@rot13.org
235     }
236    
237 dpavlin 56 If list is not found, returns false. If there is C<ext_id> in user data,
238 dpavlin 60 it will also be returned.
239 dpavlin 45
240 dpavlin 43 =cut
241    
242     sub list_members {
243     my $self = shift;
244    
245     my $args = {@_};
246    
247 dpavlin 52 my $list_name = lc($args->{'list'}) || confess "need list name";
248 dpavlin 43
249     my $lists = $self->{'loader'}->find_class('lists');
250     my $user_list = $self->{'loader'}->find_class('user_list');
251    
252 dpavlin 45 my $this_list = $lists->search( name => $list_name )->first || return;
253 dpavlin 43
254     my @results;
255    
256     foreach my $user_on_list ($user_list->search(list_id => $this_list->id)) {
257     my $row = {
258 dpavlin 45 name => $user_on_list->user_id->name,
259 dpavlin 43 email => $user_on_list->user_id->email,
260     };
261    
262 dpavlin 56 my $ext_id = $user_on_list->user_id->ext_id;
263     $row->{'ext_id'} = $ext_id if (defined($ext_id));
264    
265 dpavlin 43 push @results, $row;
266     }
267    
268     return @results;
269    
270     }
271    
272    
273 dpavlin 45 =head2 delete_member
274    
275     Delete member from database.
276    
277     my $ok = delete_member(
278     name => 'Dobrica Pavlinusic'
279     );
280    
281     my $ok = delete_member(
282     email => 'dpavlin@rot13.org'
283     );
284    
285     Returns false if user doesn't exist.
286    
287 dpavlin 60 This function will delete member from all lists (by cascading delete), so it
288     shouldn't be used lightly.
289    
290 dpavlin 45 =cut
291    
292     sub delete_member {
293     my $self = shift;
294    
295     my $args = {@_};
296    
297     croak "need name or email of user to delete" unless ($args->{'name'} || $args->{'email'});
298    
299 dpavlin 52 $args->{'email'} = lc($args->{'email'}) if ($args->{'email'});
300    
301 dpavlin 45 my $key = 'name';
302     $key = 'email' if ($args->{'email'});
303    
304     my $users = $self->{'loader'}->find_class('users');
305    
306     my $this_user = $users->search( $key => $args->{$key} )->first || return;
307    
308     $this_user->delete || croak "can't delete user\n";
309    
310     return $users->dbi_commit || croak "can't commit";
311     }
312    
313 dpavlin 59 =head2 delete_member_from_list
314    
315     Delete member from particular list.
316    
317     my $ok = delete_member_from_list(
318     list => 'My list',
319     email => 'dpavlin@rot13.org',
320     );
321    
322     Returns false if user doesn't exist on that particular list.
323    
324     It will die if list or user doesn't exist. You have been warned (you might
325     want to eval this functon to prevent it from croaking).
326    
327     =cut
328    
329     sub delete_member_from_list {
330     my $self = shift;
331    
332     my $args = {@_};
333    
334     croak "need list name and email of user to delete" unless ($args->{'list'} && $args->{'email'});
335    
336     $args->{'list'} = lc($args->{'list'});
337     $args->{'email'} = lc($args->{'email'});
338    
339     my $user = $self->{'loader'}->find_class('users');
340     my $list = $self->{'loader'}->find_class('lists');
341     my $user_list = $self->{'loader'}->find_class('user_list');
342    
343     my $this_user = $user->search( email => $args->{'email'} )->first || croak "can't find user: ".$args->{'email'};
344     my $this_list = $list->search( name => $args->{'list'} )->first || croak "can't find list: ".$args->{'list'};
345    
346     my $this_user_list = $user_list->search_where( list_id => $this_list->id, user_id => $this_list->id )->first || return;
347    
348     $this_user_list->delete || croak "can't delete user from list\n";
349    
350     return $user_list->dbi_commit || croak "can't commit";
351     }
352    
353 dpavlin 29 =head2 add_message_to_list
354 dpavlin 24
355     Adds message to one list's queue for later sending.
356    
357 dpavlin 29 $nos->add_message_to_list(
358 dpavlin 24 list => 'My list',
359 dpavlin 36 message => 'Subject: welcome to list
360 dpavlin 38
361 dpavlin 24 This is example message
362     ',
363     );
364    
365     On success returns ID of newly created (or existing) message.
366    
367 dpavlin 36 Only required header in e-mail is C<Subject:>. C<From:> and C<To:> headers
368     will be automatically generated, but if you want to use own headers, just
369     include them in messages.
370    
371 dpavlin 24 =cut
372    
373 dpavlin 29 sub add_message_to_list {
374 dpavlin 24 my $self = shift;
375    
376     my $args = {@_};
377    
378 dpavlin 52 my $list_name = lc($args->{'list'}) || confess "need list name";
379 dpavlin 24 my $message_text = $args->{'message'} || croak "need message";
380    
381 dpavlin 29 my $m = Email::Simple->new($message_text) || croak "can't parse message";
382    
383 dpavlin 32 unless( $m->header('Subject') ) {
384     warn "message doesn't have Subject header\n";
385     return;
386     }
387 dpavlin 29
388 dpavlin 24 my $lists = $self->{'loader'}->find_class('lists');
389    
390     my $this_list = $lists->search(
391     name => $list_name,
392     )->first || croak "can't find list $list_name";
393    
394     my $messages = $self->{'loader'}->find_class('messages');
395    
396     my $this_message = $messages->find_or_create({
397     message => $message_text
398     }) || croak "can't insert message";
399    
400     $this_message->dbi_commit() || croak "can't add message";
401    
402     my $queue = $self->{'loader'}->find_class('queue');
403    
404     $queue->find_or_create({
405     message_id => $this_message->id,
406     list_id => $this_list->id,
407     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
408    
409     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
410    
411     return $this_message->id;
412     }
413    
414    
415 dpavlin 22 =head2 send_queued_messages
416 dpavlin 20
417 dpavlin 22 Send queued messages or just ones for selected list
418 dpavlin 20
419 dpavlin 49 $nos->send_queued_messages(
420     list => 'My list',
421     driver => 'smtp',
422     sleep => 3,
423     );
424 dpavlin 20
425 dpavlin 47 Second option is driver which will be used for e-mail delivery. If not
426     specified, C<IO> driver will be used which will dump e-mail to C<STDERR>.
427    
428     Other valid drivers are:
429    
430     =over 10
431    
432     =item smtp
433    
434     Send e-mail using SMTP server at 127.0.0.1
435    
436     =back
437    
438 dpavlin 49 Default sleep wait between two messages is 3 seconds.
439    
440 dpavlin 21 =cut
441 dpavlin 20
442 dpavlin 22 sub send_queued_messages {
443 dpavlin 21 my $self = shift;
444 dpavlin 20
445 dpavlin 49 my $arg = {@_};
446 dpavlin 20
447 dpavlin 52 my $list_name = lc($arg->{'list'}) || '';
448 dpavlin 49 my $driver = $arg->{'driver'} || '';
449     my $sleep = $arg->{'sleep'};
450     $sleep ||= 3 unless defined($sleep);
451 dpavlin 47
452 dpavlin 49 my $email_send_driver = 'Email::Send::IO';
453     my @email_send_options;
454    
455 dpavlin 47 if (lc($driver) eq 'smtp') {
456     $email_send_driver = 'Email::Send::SMTP';
457     @email_send_options = ['127.0.0.1'];
458 dpavlin 52 } else {
459     warn "dumping all messages to STDERR\n";
460 dpavlin 47 }
461    
462 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
463     my $queue = $self->{'loader'}->find_class('queue');
464     my $user_list = $self->{'loader'}->find_class('user_list');
465     my $sent = $self->{'loader'}->find_class('sent');
466 dpavlin 20
467 dpavlin 22 my $my_q;
468     if ($list_name ne '') {
469     my $l_id = $lists->search_like( name => $list_name )->first ||
470     croak "can't find list $list_name";
471     $my_q = $queue->search_like( list_id => $l_id ) ||
472     croak "can't find list $list_name";
473     } else {
474     $my_q = $queue->retrieve_all;
475     }
476 dpavlin 20
477 dpavlin 22 while (my $m = $my_q->next) {
478     next if ($m->all_sent);
479 dpavlin 20
480 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
481     my $msg = $m->message_id->message;
482 dpavlin 20
483 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
484 dpavlin 20
485 dpavlin 29 my $to_email = $u->user_id->email;
486    
487 dpavlin 32 my ($from,$domain) = split(/@/, $u->list_id->email, 2);
488    
489 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
490 dpavlin 29 print "SKIP $to_email message allready sent\n";
491 dpavlin 22 } else {
492 dpavlin 32 print "=> $to_email\n";
493 dpavlin 20
494 dpavlin 32 my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
495 dpavlin 36 my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
496 dpavlin 32
497 dpavlin 29 my $hash = $auth->generate_hash( $to_email );
498 dpavlin 20
499 dpavlin 47 my $from_addr;
500 dpavlin 49 my $from_email_only = $from . "+" . $hash . ( $domain ? '@' . $domain : '');
501 dpavlin 48
502 dpavlin 47 $from_addr .= '"' . $u->list_id->from_addr . '" ' if ($u->list_id->from_addr);
503     $from_addr .= '<' . $from_email_only . '>';
504     my $to = '"' . $u->user_id->name . '" <' . $to_email . '>';
505 dpavlin 29
506 dpavlin 32 my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
507 dpavlin 29
508 dpavlin 49 $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
509     $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
510     $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
511 dpavlin 47 $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
512 dpavlin 32 $m_obj->header_set('To', $to) || croak "can't set To: header";
513 dpavlin 29
514 dpavlin 38 $m_obj->header_set('X-Nos-Version', $VERSION);
515     $m_obj->header_set('X-Nos-Hash', $hash);
516    
517 dpavlin 47 # really send e-mail
518     if (@email_send_options) {
519     send $email_send_driver => $m_obj->as_string, @email_send_options;
520     } else {
521     send $email_send_driver => $m_obj->as_string;
522     }
523 dpavlin 22
524     $sent->create({
525     message_id => $m->message_id,
526     user_id => $u->user_id,
527 dpavlin 36 hash => $hash,
528 dpavlin 22 });
529     $sent->dbi_commit;
530 dpavlin 49
531     if ($sleep) {
532     warn "sleeping $sleep seconds\n";
533     sleep($sleep);
534     }
535 dpavlin 22 }
536     }
537     $m->all_sent(1);
538     $m->update;
539     $m->dbi_commit;
540     }
541    
542 dpavlin 20 }
543    
544 dpavlin 29 =head2 inbox_message
545    
546     Receive single message for list's inbox.
547    
548 dpavlin 36 my $ok = $nos->inbox_message(
549     list => 'My list',
550     message => $message,
551     );
552 dpavlin 29
553 dpavlin 60 This method is used by C<sender.pl> when receiving e-mail messages.
554    
555 dpavlin 29 =cut
556    
557     sub inbox_message {
558     my $self = shift;
559    
560 dpavlin 36 my $arg = {@_};
561 dpavlin 29
562 dpavlin 36 return unless ($arg->{'message'});
563     croak "need list name" unless ($arg->{'list'});
564 dpavlin 29
565 dpavlin 52 $arg->{'list'} = lc($arg->{'list'});
566    
567 dpavlin 37 my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
568    
569 dpavlin 36 my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
570    
571     my $to = $m->header('To') || die "can't find To: address in incomming message\n";
572    
573 dpavlin 48 my $return_path = $m->header('Return-Path') || '';
574    
575 dpavlin 36 my @addrs = Email::Address->parse( $to );
576    
577     die "can't parse To: $to address\n" unless (@addrs);
578    
579     my $hl = $self->{'hash_len'} || confess "no hash_len?";
580    
581     my $hash;
582    
583     foreach my $a (@addrs) {
584 dpavlin 52 if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
585 dpavlin 36 $hash = $1;
586     last;
587     }
588     }
589    
590 dpavlin 50 #warn "can't find hash in e-mail $to\n" unless ($hash);
591 dpavlin 36
592     my $sent = $self->{'loader'}->find_class('sent');
593    
594     # will use null if no matching message_id is found
595 dpavlin 50 my $sent_msg;
596     $sent_msg = $sent->search( hash => $hash )->first if ($hash);
597 dpavlin 36
598 dpavlin 37 my ($message_id, $user_id) = (undef, undef); # init with NULL
599 dpavlin 36
600 dpavlin 37 if ($sent_msg) {
601     $message_id = $sent_msg->message_id || carp "no message_id";
602     $user_id = $sent_msg->user_id || carp "no user_id";
603 dpavlin 47 } else {
604 dpavlin 50 #warn "can't find sender with hash $hash\n";
605     my $users = $self->{'loader'}->find_class('users');
606     my $from = $m->header('From');
607     $from = $1 if ($from =~ m/<(.*)>/);
608 dpavlin 52 my $this_user = $users->search( email => lc($from) )->first;
609 dpavlin 50 $user_id = $this_user->id if ($this_user);
610 dpavlin 37 }
611    
612    
613     my $is_bounce = 0;
614    
615 dpavlin 49 if ($return_path eq '<>' || $return_path eq '') {
616 dpavlin 47 no warnings;
617     my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
618     $arg->{'message'}, { report_non_bounces=>1 },
619     ) };
620 dpavlin 50 #warn "can't check if this message is bounce!" if ($@);
621 dpavlin 47
622     $is_bounce++ if ($bounce && $bounce->is_bounce);
623     }
624 dpavlin 37
625     my $received = $self->{'loader'}->find_class('received');
626    
627     my $this_received = $received->find_or_create({
628     user_id => $user_id,
629     list_id => $this_list->id,
630     message_id => $message_id,
631     message => $arg->{'message'},
632     bounced => $is_bounce,
633     }) || croak "can't insert received message";
634    
635     $this_received->dbi_commit;
636    
637 dpavlin 49 # print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
638 dpavlin 29 }
639    
640    
641 dpavlin 30 =head1 INTERNAL METHODS
642    
643     Beware of dragons! You shouldn't need to call those methods directly.
644    
645     =head2 _add_list
646    
647     Create new list
648    
649     my $list_obj = $nos->_add_list(
650     list => 'My list',
651 dpavlin 47 from => 'Outgoing from comment',
652 dpavlin 30 email => 'my-list@example.com',
653     );
654    
655     Returns C<Class::DBI> object for created list.
656    
657 dpavlin 38 C<email> address can be with domain or without it if your
658     MTA appends it. There is no checking for validity of your
659     list e-mail. Flexibility comes with resposibility, so please
660     feed correct (and configured) return addresses.
661    
662 dpavlin 30 =cut
663    
664     sub _add_list {
665     my $self = shift;
666    
667     my $arg = {@_};
668    
669 dpavlin 52 my $name = lc($arg->{'list'}) || confess "can't add list without name";
670     my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
671 dpavlin 47 my $from_addr = $arg->{'from'};
672 dpavlin 30
673     my $lists = $self->{'loader'}->find_class('lists');
674    
675     my $l = $lists->find_or_create({
676     name => $name,
677     email => $email,
678     });
679 dpavlin 47
680 dpavlin 30 croak "can't add list $name\n" unless ($l);
681    
682 dpavlin 47 if ($from_addr && $l->from_addr ne $from_addr) {
683     $l->from_addr($from_addr);
684     $l->update;
685     }
686    
687 dpavlin 30 $l->dbi_commit;
688    
689     return $l;
690    
691     }
692    
693    
694     =head2 _get_list
695    
696     Get list C<Class::DBI> object.
697    
698     my $list_obj = $nos->check_list('My list');
699    
700     Returns false on failure.
701    
702     =cut
703    
704     sub _get_list {
705     my $self = shift;
706    
707     my $name = shift || return;
708    
709 dpavlin 31 my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
710 dpavlin 30
711 dpavlin 52 return $lists->search({ name => lc($name) })->first;
712 dpavlin 30 }
713    
714 dpavlin 39 ###
715     ### SOAP
716     ###
717 dpavlin 30
718 dpavlin 39 package Nos::SOAP;
719    
720 dpavlin 43 use Carp;
721    
722 dpavlin 39 =head1 SOAP methods
723    
724     This methods are thin wrappers to provide SOAP calls. They are grouped in
725     C<Nos::SOAP> package which is in same F<Nos.pm> module file.
726    
727     Usually, you want to use named variables in your SOAP calls if at all
728     possible.
729    
730     However, if you have broken SOAP library (like PHP SOAP class from PEAR)
731     you will want to use positional arguments (in same order as documented for
732     methods below).
733    
734     =cut
735    
736     my $nos;
737    
738     sub new {
739     my $class = shift;
740     my $self = {@_};
741     bless($self, $class);
742    
743     $nos = new Nos( @_ ) || die "can't create Nos object";
744    
745     $self ? return $self : return undef;
746     }
747    
748    
749     =head2 NewList
750    
751     $message_id = NewList(
752     list => 'My list',
753 dpavlin 56 from => 'Name of my list',
754 dpavlin 39 email => 'my-list@example.com'
755     );
756    
757     =cut
758    
759     sub NewList {
760     my $self = shift;
761    
762     if ($_[0] !~ m/^HASH/) {
763     return $nos->new_list(
764 dpavlin 56 list => $_[0], from => $_[1], email => $_[2],
765 dpavlin 39 );
766     } else {
767     return $nos->new_list( %{ shift @_ } );
768     }
769     }
770    
771 dpavlin 43
772 dpavlin 39 =head2 AddMemberToList
773    
774     $member_id = AddMemberToList(
775 dpavlin 43 list => 'My list',
776     email => 'e-mail@example.com',
777 dpavlin 58 name => 'Full Name',
778     ext_id => 42,
779 dpavlin 39 );
780    
781     =cut
782    
783     sub AddMemberToList {
784     my $self = shift;
785    
786     if ($_[0] !~ m/^HASH/) {
787     return $nos->add_member_to_list(
788 dpavlin 58 list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
789 dpavlin 39 );
790     } else {
791     return $nos->add_member_to_list( %{ shift @_ } );
792     }
793     }
794    
795 dpavlin 43
796     =head2 ListMembers
797    
798     my @members = ListMembers(
799     list => 'My list',
800     );
801    
802     Returns array of hashes with user informations, see C<list_members>.
803    
804     =cut
805    
806     sub ListMembers {
807     my $self = shift;
808    
809     my $list_name;
810    
811     if ($_[0] !~ m/^HASH/) {
812     $list_name = shift;
813     } else {
814     $list_name = $_[0]->{'list'};
815     }
816    
817     return $nos->list_members( list => $list_name );
818     }
819    
820 dpavlin 39 =head2 AddMessageToList
821    
822     $message_id = AddMessageToList(
823     list => 'My list',
824     message => 'From: My list...'
825     );
826    
827     =cut
828    
829     sub AddMessageToList {
830     my $self = shift;
831    
832     if ($_[0] !~ m/^HASH/) {
833     return $nos->add_message_to_list(
834     list => $_[0], message => $_[1],
835     );
836     } else {
837     return $nos->add_message_to_list( %{ shift @_ } );
838     }
839     }
840    
841    
842     ###
843    
844 dpavlin 25 =head1 EXPORT
845 dpavlin 20
846 dpavlin 27 Nothing.
847 dpavlin 20
848     =head1 SEE ALSO
849    
850     mailman, ezmlm, sympa, L<Mail::Salsa>
851    
852 dpavlin 25
853 dpavlin 20 =head1 AUTHOR
854    
855     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
856    
857 dpavlin 25
858 dpavlin 20 =head1 COPYRIGHT AND LICENSE
859    
860     Copyright (C) 2005 by Dobrica Pavlinusic
861    
862     This library is free software; you can redistribute it and/or modify
863     it under the same terms as Perl itself, either Perl version 5.8.4 or,
864     at your option, any later version of Perl 5 you may have available.
865    
866    
867     =cut
868 dpavlin 39
869     1;

  ViewVC Help
Powered by ViewVC 1.1.26