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

Diff of /trunk/Nos.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 22 by dpavlin, Sun May 15 21:52:56 2005 UTC revision 68 by dpavlin, Mon Aug 1 08:59:36 2005 UTC
# Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all' Line 16  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'
16  our @EXPORT = qw(  our @EXPORT = qw(
17  );  );
18    
19  our $VERSION = '0.1';  our $VERSION = '0.6';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
23  use Email::Send;  use Email::Send;
24  use Carp;  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  =head1 NAME
35    
# Line 34  Nos - Notice Sender core module Line 42  Nos - Notice Sender core module
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
44    
45  Core module for notice sender's functionality.  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  =head1 METHODS
80    
# Line 48  Create new instance specifing database, Line 88  Create new instance specifing database,
88          passwd => '',          passwd => '',
89          debug => 1,          debug => 1,
90          verbose => 1,          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  =cut
98    
99  sub new {  sub new {
# Line 65  sub new { Line 109  sub new {
109                  user            => $self->{'user'},                  user            => $self->{'user'},
110                  password        => $self->{'passwd'},                  password        => $self->{'passwd'},
111                  namespace       => "Nos",                  namespace       => "Nos",
112  #               additional_classes      => qw/Class::DBI::AbstractSearch/,                  additional_classes      => qw/Class::DBI::AbstractSearch/,
113  #               additional_base_classes => qw/My::Stuff/,  #               additional_base_classes => qw/My::Stuff/,
114                  relationships   => 1,                  relationships   => 1,
115          ) || croak "can't init Class::DBI::Loader";          ) || croak "can't init Class::DBI::Loader";
116    
117            $self->{'hash_len'} ||= 8;
118    
119          $self ? return $self : return undef;          $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  =head2 send_queued_messages
451    
452  Send queued messages or just ones for selected list  Send queued messages or just ones for selected list
453    
454   $noc->send_queued_messages("my list");   $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  =cut
476    
477  sub send_queued_messages {  sub send_queued_messages {
478          my $self = shift;          my $self = shift;
479    
480          my $list_name = shift;          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');          my $lists = $self->{'loader'}->find_class('lists');
498          my $queue = $self->{'loader'}->find_class('queue');          my $queue = $self->{'loader'}->find_class('queue');
# Line 109  sub send_queued_messages { Line 517  sub send_queued_messages {
517    
518                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  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 )) {                          if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
525                                  print "SKIP ",$u->user_id->email," message allready sent\n";                                  print "SKIP $to_email message allready sent\n";
526                          } else {                          } else {
527                                  print "\t",$u->user_id->email,"\n";                                  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                                  my $hdr = "From: " . $u->list_id->name . " <" . $u->list_id->email . ">\n" .                                  $m_obj->header_set('X-Nos-Version', $VERSION);
550                                          "To: " . $u->user_id->full_name . " <". $u->user_id->email. ">\n";                                  $m_obj->header_set('X-Nos-Hash', $hash);
551    
552                                  # FIXME do real sending :-)                                  # really send e-mail
553                                  send IO => "$hdr\n$msg";                                  my $sent_status;
554    
555                                  $sent->create({                                  if (@email_send_options) {
556                                          message_id => $m->message_id,                                          $sent_status = send $email_send_driver => $m_obj->as_string, @email_send_options;
557                                          user_id => $u->user_id,                                  } else {
558                                  });                                          $sent_status = send $email_send_driver => $m_obj->as_string;
559                                  $sent->dbi_commit;                                  }
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);                  $m->all_sent(1);
# Line 134  sub send_queued_messages { Line 590  sub send_queued_messages {
590    
591  }  }
592    
593  =head2 EXPORT  =head2 inbox_message
594    
595    Receive single message for list's inbox.
596    
597  None by default.   my $ok = $nos->inbox_message(
598            list => 'My list',
599            message => $message,
600     );
601    
602    This method is used by C<sender.pl> when receiving e-mail messages.
603    
604    =cut
605    
606    sub inbox_message {
607            my $self = shift;
608    
609            my $arg = {@_};
610    
611            return unless ($arg->{'message'});
612            croak "need list name" unless ($arg->{'list'});
613    
614            $arg->{'list'} = lc($arg->{'list'});
615    
616            my $this_list = $self->_get_list($arg->{'list'}) || croak "can't find list ".$arg->{'list'}."\n";
617    
618            my $m = Email::Simple->new($arg->{'message'}) || croak "can't parse message";
619    
620            my $to = $m->header('To') || die "can't find To: address in incomming message\n";
621    
622            my $return_path = $m->header('Return-Path') || '';
623    
624            my @addrs = Email::Address->parse( $to );
625    
626            die "can't parse To: $to address\n" unless (@addrs);
627    
628            my $hl = $self->{'hash_len'} || confess "no hash_len?";
629    
630            my $hash;
631    
632            foreach my $a (@addrs) {
633                    if ($a->address =~ m/\+([a-f0-9]{$hl})@/i) {
634                            $hash = $1;
635                            last;
636                    }
637            }
638    
639            #warn "can't find hash in e-mail $to\n" unless ($hash);
640    
641            my $sent = $self->{'loader'}->find_class('sent');
642    
643            # will use null if no matching message_id is found
644            my $sent_msg;
645            $sent_msg = $sent->search( hash => $hash )->first if ($hash);
646    
647            my ($message_id, $user_id) = (undef, undef);    # init with NULL
648    
649            if ($sent_msg) {
650                    $message_id = $sent_msg->message_id || carp "no message_id";
651                    $user_id = $sent_msg->user_id || carp "no user_id";
652            } else {
653                    #warn "can't find sender with hash $hash\n";
654                    my $users = $self->{'loader'}->find_class('users');
655                    my $from = $m->header('From');
656                    $from = $1 if ($from =~ m/<(.*)>/);
657                    my $this_user = $users->search( email => lc($from) )->first;
658                    $user_id = $this_user->id if ($this_user);
659            }
660    
661    
662            my $is_bounce = 0;
663    
664            if ($return_path eq '<>' || $return_path eq '') {
665                    no warnings;
666                    my $bounce = eval { Mail::DeliveryStatus::BounceParser->new(
667                            $arg->{'message'}, { report_non_bounces=>1 },
668                    ) };
669                    #warn "can't check if this message is bounce!" if ($@);
670            
671                    $is_bounce++ if ($bounce && $bounce->is_bounce);
672            }
673    
674            my $received = $self->{'loader'}->find_class('received');
675    
676            my $this_received = $received->find_or_create({
677                    user_id => $user_id,
678                    list_id => $this_list->id,
679                    message_id => $message_id,
680                    message => $arg->{'message'},
681                    bounced => $is_bounce,
682            }) || croak "can't insert received message";
683    
684            $this_received->dbi_commit;
685    
686    #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
687    }
688    
689    
690    =head1 INTERNAL METHODS
691    
692    Beware of dragons! You shouldn't need to call those methods directly.
693    
694    
695    =head2 _add_aliases
696    
697    Add or update alias in C</etc/aliases> (or equivavlent) file for selected list
698    
699     my $ok = $nos->add_aliases(
700            list => 'My list',
701            email => 'my-list@example.com',
702            aliases => '/etc/mail/mylist',
703            archive => '/path/to/mbox/archive',
704    
705     );
706    
707    C<archive> parametar is optional.
708    
709    Return false on failure.
710    
711    =cut
712    
713    sub _add_aliases {
714            my $self = shift;
715    
716            my $arg = {@_};
717    
718            foreach my $o (qw/list email aliases/) {
719                    croak "need $o option" unless ($arg->{$o});
720            }
721    
722            my $aliases = $arg->{'aliases'};
723            my $email = $arg->{'email'};
724            my $list = $arg->{'list'};
725    
726            unless (-e $aliases) {
727                    warn "aliases file $aliases doesn't exist, creating empty\n";
728                    open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
729                    close($fh);
730                    chmod 0777, $aliases || warn "can't change permission to 0777";
731            }
732    
733            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
734    
735            my $target = '';
736    
737            if (my $archive = $arg->{'archive'}) {
738                    $target .= "$archive, ";
739    
740                    if (! -e $archive) {
741                            warn "please make sure that file $archive is writable for your e-mail user (defaulting to bad 777 permission for now)";
742    
743                            open(my $fh, '>', $archive) || croak "can't create archive file $archive: $!";
744                            close($fh);
745                            chmod 0777, $archive || croak "can't chmod archive file $archive to 0777: $!";
746                    }
747            }
748    
749            # resolve my path to absolute one
750            my $self_path = abs_path($0);
751            $self_path =~ s#/[^/]+$##;
752            $self_path =~ s#/t/*$#/#;
753    
754            $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
755    
756            if ($a->exists($email)) {
757                    $a->update($email, $target) or croak "can't update alias ".$a->error_check;
758            } else {
759                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
760            }
761    
762            return 1;
763    }
764    
765    =head2 _add_list
766    
767    Create new list
768    
769     my $list_obj = $nos->_add_list(
770            list => 'My list',
771            from => 'Outgoing from comment',
772            email => 'my-list@example.com',
773            aliases => '/etc/mail/mylist',
774     );
775    
776    Returns C<Class::DBI> object for created list.
777    
778    C<email> address can be with domain or without it if your
779    MTA appends it. There is no checking for validity of your
780    list e-mail. Flexibility comes with resposibility, so please
781    feed correct (and configured) return addresses.
782    
783    =cut
784    
785    sub _add_list {
786            my $self = shift;
787    
788            my $arg = {@_};
789    
790            my $name = lc($arg->{'list'}) || confess "can't add list without name";
791            my $email = lc($arg->{'email'}) || confess "can't add list without e-mail";
792            my $aliases = lc($arg->{'aliases'}) || confess "can't add list without path to aliases file";
793    
794            my $from_addr = $arg->{'from'};
795    
796            my $lists = $self->{'loader'}->find_class('lists');
797    
798            $self->_add_aliases(
799                    list => $name,
800                    email => $email,
801                    aliases => $aliases,
802            ) || warn "can't add alias $email for list $name";
803    
804            my $l = $lists->find_or_create({
805                    name => $name,
806                    email => $email,
807            });
808    
809            croak "can't add list $name\n" unless ($l);
810    
811            if ($from_addr && $l->from_addr ne $from_addr) {
812                    $l->from_addr($from_addr);
813                    $l->update;
814            }
815    
816            $l->dbi_commit;
817    
818            return $l;
819    
820    }
821    
822    
823    
824    =head2 _get_list
825    
826    Get list C<Class::DBI> object.
827    
828     my $list_obj = $nos->check_list('My list');
829    
830    Returns false on failure.
831    
832    =cut
833    
834    sub _get_list {
835            my $self = shift;
836    
837            my $name = shift || return;
838    
839            my $lists = $self->{'loader'}->find_class('lists') || confess "can't find lists class";
840    
841            return $lists->search({ name => lc($name) })->first;
842    }
843    
844    ###
845    ### SOAP
846    ###
847    
848    package Nos::SOAP;
849    
850    use Carp;
851    
852    =head1 SOAP methods
853    
854    This methods are thin wrappers to provide SOAP calls. They are grouped in
855    C<Nos::SOAP> package which is in same F<Nos.pm> module file.
856    
857    Usually, you want to use named variables in your SOAP calls if at all
858    possible.
859    
860    However, if you have broken SOAP library (like PHP SOAP class from PEAR)
861    you will want to use positional arguments (in same order as documented for
862    methods below).
863    
864    =cut
865    
866    my $nos;
867    
868    
869    =head2 new
870    
871    Create new SOAP object
872    
873     my $soap = new Nos::SOAP(
874            dsn => 'dbi:Pg:dbname=notices',
875            user => 'dpavlin',
876            passwd => '',
877            debug => 1,
878            verbose => 1,
879            hash_len => 8,
880            aliases => '/etc/aliases',
881     );
882    
883    =cut
884    
885    sub new {
886            my $class = shift;
887            my $self = {@_};
888    
889            croak "need aliases parametar" unless ($self->{'aliases'});
890    
891            bless($self, $class);
892    
893            $nos = new Nos( @_ ) || die "can't create Nos object";
894    
895            $self ? return $self : return undef;
896    }
897    
898    
899    =head2 NewList
900    
901     $message_id = NewList(
902            list => 'My list',
903            from => 'Name of my list',
904            email => 'my-list@example.com'
905     );
906    
907    =cut
908    
909    sub NewList {
910            my $self = shift;
911    
912            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
913    
914            if ($_[0] !~ m/^HASH/) {
915                    return $nos->new_list(
916                            list => $_[0], from => $_[1], email => $_[2],
917                            aliases => $aliases,
918                    );
919            } else {
920                    return $nos->new_list( %{ shift @_ }, aliases => $aliases );
921            }
922    }
923    
924    
925    =head2 DeleteList
926    
927     $ok = DeleteList(
928            list => 'My list',
929     );
930    
931    =cut
932    
933    sub DeleteList {
934            my $self = shift;
935    
936            if ($_[0] !~ m/^HASH/) {
937                    return $nos->delete_list(
938                            list => $_[0],
939                    );
940            } else {
941                    return $nos->delete_list( %{ shift @_ } );
942            }
943    }
944    
945    =head2 AddMemberToList
946    
947     $member_id = AddMemberToList(
948            list => 'My list',
949            email => 'e-mail@example.com',
950            name => 'Full Name',
951            ext_id => 42,
952     );
953    
954    =cut
955    
956    sub AddMemberToList {
957            my $self = shift;
958    
959            if ($_[0] !~ m/^HASH/) {
960                    return $nos->add_member_to_list(
961                            list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],
962                    );
963            } else {
964                    return $nos->add_member_to_list( %{ shift @_ } );
965            }
966    }
967    
968    
969    =head2 ListMembers
970    
971     my @members = ListMembers(
972            list => 'My list',
973     );
974    
975    Returns array of hashes with user informations, see C<list_members>.
976    
977    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
978    seems that SOAP::Lite client thinks that it has array with one element which
979    is array of hashes with data.
980    
981    =cut
982    
983    sub ListMembers {
984            my $self = shift;
985    
986            my $list_name;
987    
988            if ($_[0] !~ m/^HASH/) {
989                    $list_name = shift;
990            } else {
991                    $list_name = $_[0]->{'list'};
992            }
993    
994            return [ $nos->list_members( list => $list_name ) ];
995    }
996    
997    
998    =head2 DeleteMemberFromList
999    
1000     $member_id = DeleteMemberFromList(
1001            list => 'My list',
1002            email => 'e-mail@example.com',
1003     );
1004    
1005    =cut
1006    
1007    sub DeleteMemberFromList {
1008            my $self = shift;
1009    
1010            if ($_[0] !~ m/^HASH/) {
1011                    return $nos->delete_member_from_list(
1012                            list => $_[0], email => $_[1],
1013                    );
1014            } else {
1015                    return $nos->delete_member_from_list( %{ shift @_ } );
1016            }
1017    }
1018    
1019    
1020    =head2 AddMessageToList
1021    
1022     $message_id = AddMessageToList(
1023            list => 'My list',
1024            message => 'From: My list...'
1025     );
1026    
1027    =cut
1028    
1029    sub AddMessageToList {
1030            my $self = shift;
1031    
1032            if ($_[0] !~ m/^HASH/) {
1033                    return $nos->add_message_to_list(
1034                            list => $_[0], message => $_[1],
1035                    );
1036            } else {
1037                    return $nos->add_message_to_list( %{ shift @_ } );
1038            }
1039    }
1040    
1041    
1042    ###
1043    
1044    =head1 EXPORT
1045    
1046    Nothing.
1047    
1048  =head1 SEE ALSO  =head1 SEE ALSO
1049    
1050  mailman, ezmlm, sympa, L<Mail::Salsa>  mailman, ezmlm, sympa, L<Mail::Salsa>
1051    
1052    
1053  =head1 AUTHOR  =head1 AUTHOR
1054    
1055  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>  Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
1056    
1057    
1058  =head1 COPYRIGHT AND LICENSE  =head1 COPYRIGHT AND LICENSE
1059    
1060  Copyright (C) 2005 by Dobrica Pavlinusic  Copyright (C) 2005 by Dobrica Pavlinusic
# Line 156  at your option, any later version of Per Line 1065  at your option, any later version of Per
1065    
1066    
1067  =cut  =cut
1068    
1069    1;
Legend:
Removed from v.22  
changed lines
  Added in v.68
  ViewVC Help
Powered by ViewVC 1.1.26