/[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 68 by dpavlin, Mon Aug 1 08:59:36 2005 UTC revision 93 by dpavlin, Tue Dec 19 15:04:05 2006 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.6';  our $VERSION = '0.9';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 27  use Email::Simple; Line 27  use Email::Simple;
27  use Email::Address;  use Email::Address;
28  use Mail::DeliveryStatus::BounceParser;  use Mail::DeliveryStatus::BounceParser;
29  use Class::DBI::AbstractSearch;  use Class::DBI::AbstractSearch;
30    use SQL::Abstract;
31  use Mail::Alias;  use Mail::Alias;
32  use Cwd qw(abs_path);  use Cwd qw(abs_path);
33    
# Line 62  encoded) or anything else. Line 63  encoded) or anything else.
63  It will just queue your e-mail message to particular list (sending it to  It will just queue your e-mail message to particular list (sending it to
64  possibly remote Notice Sender SOAP server just once), send it out at  possibly remote Notice Sender SOAP server just once), send it out at
65  reasonable rate (so that it doesn't flood your e-mail infrastructure) and  reasonable rate (so that it doesn't flood your e-mail infrastructure) and
66  track replies.  keep track replies.
67    
68  It is best used to send smaller number of messages to more-or-less fixed  It is best used to send small number of messages to more-or-less fixed
69  list of recipients while allowing individual responses to be examined.  list of recipients while allowing individual responses to be examined.
70  Tipical use include replacing php e-mail sending code with SOAP call to  Tipical use include replacing php e-mail sending code with SOAP call to
71  Notice Sender. It does support additional C<ext_id> field for each member  Notice Sender. It does support additional C<ext_id> field for each member
# Line 72  which can be used to track some unique i Line 73  which can be used to track some unique i
73  particular user.  particular user.
74    
75  It comes with command-line utility C<sender.pl> which can be used to perform  It comes with command-line utility C<sender.pl> which can be used to perform
76  all available operation from scripts (see C<perldoc sender.pl>).  all available operation from scripts (see C<sender.pl --man>).
77  This command is also useful for debugging while writing client SOAP  This command is also useful for debugging while writing client SOAP
78  application.  application.
79    
# Line 89  Create new instance specifing database, Line 90  Create new instance specifing database,
90          debug => 1,          debug => 1,
91          verbose => 1,          verbose => 1,
92          hash_len => 8,          hash_len => 8,
93            full_hostname_in_aliases => 0,
94   );   );
95    
96  Parametar C<hash_len> defines length of hash which will be added to each  Parametar C<hash_len> defines length of hash which will be added to each
97  outgoing e-mail message to ensure that replies can be linked with sent e-mails.  outgoing e-mail message to ensure that replies can be linked with sent e-mails.
98    
99    C<full_hostname_in_aliases> will turn on old behaviour (not supported by Postfix
100    postalias) to include full hostname in aliases file.
101    
102    
103  =cut  =cut
104    
105  sub new {  sub new {
106          my $class = shift;          my $class = shift;
107          my $self = {@_};          my $self = {@_};
108          bless($self, $class);          bless($self, $class);
109    
110          croak "need at least dsn" unless ($self->{'dsn'});          croak "need at least dsn" unless ($self->{'dsn'});
# Line 120  sub new { Line 126  sub new {
126  }  }
127    
128    
129  =head2 new_list  =head2 create_list
130    
131  Create new list. Required arguments are name of C<list>, C<email> address  Create new list. Required arguments are name of C<list>, C<email> address
132  and path to C<aliases> file.  and path to C<aliases> file.
133    
134   $nos->new_list(   $nos->create_list(
135          list => 'My list',          list => 'My list',
136          from => 'Outgoing from comment',          from => 'Outgoing from comment',
137          email => 'my-list@example.com',          email => 'my-list@example.com',
# Line 139  Calls internally C<_add_list>, see detai Line 145  Calls internally C<_add_list>, see detai
145    
146  =cut  =cut
147    
148  sub new_list {  sub create_list {
149          my $self = shift;          my $self = shift;
150    
151          my $arg = {@_};          my $arg = {@_};
# Line 158  sub new_list { Line 164  sub new_list {
164  }  }
165    
166    
167  =head2 delete_list  =head2 drop_list
168    
169  Delete list from database.  Delete list from database.
170    
171   my $ok = delete_list(   my $ok = drop_list(
172          list => 'My list'          list => 'My list'
173            aliases => '/etc/mail/mylist',
174   );   );
175    
176  Returns false if list doesn't exist.  Returns false if list doesn't exist.
177    
178  =cut  =cut
179    
180  sub delete_list {  sub drop_list {
181          my $self = shift;          my $self = shift;
182    
183          my $args = {@_};          my $args = {@_};
# Line 179  sub delete_list { Line 186  sub delete_list {
186    
187          $args->{'list'} = lc($args->{'list'});          $args->{'list'} = lc($args->{'list'});
188    
189            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
190    
191          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
192    
193          my $this_list = $lists->search( name => $args->{'list'} )->first || return;          my $this_list = $lists->search( name => $args->{'list'} )->first || return;
194    
195            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
196    
197          $this_list->delete || croak "can't delete list\n";          $this_list->delete || croak "can't delete list\n";
198    
199          return $lists->dbi_commit || croak "can't commit";          return $lists->dbi_commit || croak "can't commit";
# Line 262  List all members of some list. Line 273  List all members of some list.
273          list => 'My list',          list => 'My list',
274   );   );
275    
276  Returns array of hashes with user informations like this:  Returns array of hashes with user information like this:
277    
278   $member = {   $member = {
279          name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
# Line 415  sub add_message_to_list { Line 426  sub add_message_to_list {
426    
427          my $m = Email::Simple->new($message_text) || croak "can't parse message";          my $m = Email::Simple->new($message_text) || croak "can't parse message";
428    
429          unless( $m->header('Subject') ) {          warn "message doesn't have Subject header\n" unless( $m->header('Subject') );
                 warn "message doesn't have Subject header\n";  
                 return;  
         }  
430    
431          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
432    
# Line 455  Send queued messages or just ones for se Line 463  Send queued messages or just ones for se
463          list => 'My list',          list => 'My list',
464          driver => 'smtp',          driver => 'smtp',
465          sleep => 3,          sleep => 3,
466            verbose => 1,
467   );   );
468    
469  Second option is driver which will be used for e-mail delivery. If not  Second option is driver which will be used for e-mail delivery. If not
# Line 468  Other valid drivers are: Line 477  Other valid drivers are:
477    
478  Send e-mail using SMTP server at 127.0.0.1  Send e-mail using SMTP server at 127.0.0.1
479    
480    =item verbose
481    
482    Display diagnostic output to C<STDOUT> and C<STDERR>.
483    
484  =back  =back
485    
486    Any other driver name will try to use C<Email::Send::that_driver> module.
487    
488  Default sleep wait between two messages is 3 seconds.  Default sleep wait between two messages is 3 seconds.
489    
490    This method will return number of succesfully sent messages.
491    
492  =cut  =cut
493    
494  sub send_queued_messages {  sub send_queued_messages {
# Line 482  sub send_queued_messages { Line 499  sub send_queued_messages {
499          my $list_name = lc($arg->{'list'}) || '';          my $list_name = lc($arg->{'list'}) || '';
500          my $driver = $arg->{'driver'} || '';          my $driver = $arg->{'driver'} || '';
501          my $sleep = $arg->{'sleep'};          my $sleep = $arg->{'sleep'};
502            my $verbose = $arg->{verbose};
503          $sleep ||= 3 unless defined($sleep);          $sleep ||= 3 unless defined($sleep);
504    
505            # number of messages sent o.k.
506            my $ok = 0;
507    
508          my $email_send_driver = 'Email::Send::IO';          my $email_send_driver = 'Email::Send::IO';
509          my @email_send_options;          my @email_send_options;
510    
511          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
512                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
513                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
514            } elsif ($driver && $driver ne '') {
515                    $email_send_driver = 'Email::Send::' . $driver;
516          } else {          } else {
517                  warn "dumping all messages to STDERR\n";                  warn "dumping all messages to STDERR\n" if ($verbose);
518          }          }
519    
520          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
# Line 512  sub send_queued_messages { Line 535  sub send_queued_messages {
535          while (my $m = $my_q->next) {          while (my $m = $my_q->next) {
536                  next if ($m->all_sent);                  next if ($m->all_sent);
537    
538                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";                  print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n" if ($verbose);
539                  my $msg = $m->message_id->message;                  my $msg = $m->message_id->message;
540    
541                  foreach my $u ($user_list->search(list_id => $m->list_id)) {                  foreach my $u ($user_list->search(list_id => $m->list_id)) {
# Line 522  sub send_queued_messages { Line 545  sub send_queued_messages {
545                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);                          my ($from,$domain) = split(/@/, $u->list_id->email, 2);
546    
547                          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 )) {
548                                  print "SKIP $to_email message allready sent\n";                                  print "SKIP $to_email message allready sent\n" if ($verbose);
549                          } else {                          } else {
550                                  print "=> $to_email ";                                  print "=> $to_email " if ($verbose);
551    
552                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;                                  my $secret = $m->list_id->name . " " . $u->user_id->email . " " . $m->message_id;
553                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );                                  my $auth = Email::Auth::AddressHash->new( $secret, $self->{'hash_len'} );
# Line 541  sub send_queued_messages { Line 564  sub send_queued_messages {
564                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";                                  my $m_obj = Email::Simple->new($msg) || croak "can't parse message";
565    
566                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";                                  $m_obj->header_set('Return-Path', $from_email_only) || croak "can't set Return-Path: header";
567                                  $m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";                                  #$m_obj->header_set('Sender', $from_email_only) || croak "can't set Sender: header";
568                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";                                  $m_obj->header_set('Errors-To', $from_email_only) || croak "can't set Errors-To: header";
569                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";                                  $m_obj->header_set('From', $from_addr) || croak "can't set From: header";
570                                  $m_obj->header_set('To', $to) || croak "can't set To: header";                                  $m_obj->header_set('To', $to) || croak "can't set To: header";
# Line 559  sub send_queued_messages { Line 582  sub send_queued_messages {
582                                  }                                  }
583    
584                                  croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);                                  croak "can't send e-mail: $sent_status\n\nOriginal e-mail follows:\n".$m_obj->as_string unless ($sent_status);
585                                  my @bad = @{ $sent_status->prop('bad') };                                  my @bad;
586                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
587                                  croak "failed sending to ",join(",",@bad) if (@bad);                                  croak "failed sending to ",join(",",@bad) if (@bad);
588    
589                                  if ($sent_status) {                                  if ($sent_status) {
# Line 571  sub send_queued_messages { Line 595  sub send_queued_messages {
595                                          });                                          });
596                                          $sent->dbi_commit;                                          $sent->dbi_commit;
597    
598                                          print " - $sent_status\n";                                          print " - $sent_status\n" if ($verbose);
599    
600                                            $ok++;
601                                  } else {                                  } else {
602                                          warn "ERROR: $sent_status\n";                                          warn "ERROR: $sent_status\n" if ($verbose);
603                                  }                                  }
604    
605                                  if ($sleep) {                                  if ($sleep) {
606                                          warn "sleeping $sleep seconds\n";                                          warn "sleeping $sleep seconds\n" if ($verbose);
607                                          sleep($sleep);                                          sleep($sleep);
608                                  }                                  }
609                          }                          }
# Line 588  sub send_queued_messages { Line 613  sub send_queued_messages {
613                  $m->dbi_commit;                  $m->dbi_commit;
614          }          }
615    
616            return $ok;
617    
618  }  }
619    
620  =head2 inbox_message  =head2 inbox_message
# Line 686  sub inbox_message { Line 713  sub inbox_message {
713  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
714  }  }
715    
716    =head2 received_messages
717    
718    Returns all received messages for given list or user.
719    
720     my @received = $nos->received_messages(
721            list => 'My list',
722            email => "john.doe@example.com",
723            from_date => '2005-01-01 10:15:00',
724            to_date => '2005-01-01 12:00:00',
725            message => 0,
726     );
727    
728    If don't specify C<list> or C<email> it will return all received messages.
729    Results will be sorted by received date, oldest first.
730    
731    Other optional parametars include:
732    
733    =over 10
734    
735    =item from_date
736    
737    Date (in ISO format) for lower limit of dates received
738    
739    =item to_date
740    
741    Return just messages older than this date
742    
743    =item message
744    
745    Include whole received message in result. This will probably make result
746    array very large. Use with care.
747    
748    =back
749    
750    Date ranges are inclusive, so results will include messages sent on
751    particular date specified with C<date_from> or C<date_to>.
752    
753    Each element in returned array will have following structure:
754    
755     my $row = {
756            id => 42,                       # unique ID of received message
757            list => 'My list',              # useful if filtering by email
758            ext_id => 9999,                 # ext_id from message sender
759            email => 'jdoe@example.com',    # e-mail of message sender
760            bounced => 0,                   # true if message is bounce
761            date => '2005-08-24 18:57:24',  # date of receival in ISO format
762     }
763    
764    If you specified C<message> option, this hash will also have C<message> key
765    which will contain whole received message.
766    
767    =cut
768    
769    sub received_messages {
770            my $self = shift;
771    
772            my $arg = {@_} if (@_);
773    
774    #       croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
775    
776            my $sql = qq{
777                            select
778                                    received.id as id,
779                                    lists.name as list,
780                                    users.ext_id as ext_id,
781                                    users.email as email,
782            };
783            $sql .= qq{             message,} if ($arg->{'message'});
784            $sql .= qq{
785                                    bounced,received.date as date
786                            from received
787                            join lists on lists.id = list_id
788                            join users on users.id = user_id
789            };
790    
791            my $order = qq{ order by date asc };
792    
793            my $where;
794    
795            $where->{'lists.name'} = lc($arg->{'list'}) if ($arg->{'list'});
796            $where->{'users.email'} = lc($arg->{'email'}) if ($arg->{'email'});
797            $where->{'received.date'} = { '>=', $arg->{'date_from'} } if ($arg->{'date_from'});
798            $where->{'received.date'} = { '<=', $arg->{'date_to'} } if ($arg->{'date_to'});
799    
800            # hum, yammy one-liner
801            my($stmt, @bind)  = SQL::Abstract->new->where($where);
802    
803            my $dbh = $self->{'loader'}->find_class('received')->db_Main;
804    
805            my $sth = $dbh->prepare($sql . $stmt . $order);
806            $sth->execute(@bind);
807            return $sth->fetchall_hash;
808    }
809    
810    
811  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
812    
# Line 694  Beware of dragons! You shouldn't need to Line 815  Beware of dragons! You shouldn't need to
815    
816  =head2 _add_aliases  =head2 _add_aliases
817    
818  Add or update alias in C</etc/aliases> (or equivavlent) file for selected list  Add or update alias in C</etc/aliases> (or equivalent) file for selected list
819    
820   my $ok = $nos->add_aliases(   my $ok = $nos->add_aliases(
821          list => 'My list',          list => 'My list',
# Line 730  sub _add_aliases { Line 851  sub _add_aliases {
851                  chmod 0777, $aliases || warn "can't change permission to 0777";                  chmod 0777, $aliases || warn "can't change permission to 0777";
852          }          }
853    
854            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
855    
856          my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";          my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
857    
858          my $target = '';          my $target = '';
# Line 751  sub _add_aliases { Line 874  sub _add_aliases {
874          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
875          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
876    
877          $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;          $target .= qq#"| cd $self_path && ./sender.pl --inbox='$list'"#;
878    
879            # remove hostname from email to make Postfix's postalias happy
880            $email =~ s/@.+// if (not $self->{full_hostname_in_aliases});
881    
882          if ($a->exists($email)) {          if ($a->exists($email)) {
883                  $a->update($email, $target) or croak "can't update alias ".$a->error_check;                  $a->update($email, $target) or croak "can't update alias ".$a->error_check;
# Line 759  sub _add_aliases { Line 885  sub _add_aliases {
885                  $a->append($email, $target) or croak "can't add alias ".$a->error_check;                  $a->append($email, $target) or croak "can't add alias ".$a->error_check;
886          }          }
887    
888    #       $a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
889    
890          return 1;          return 1;
891  }  }
892    
# Line 841  sub _get_list { Line 969  sub _get_list {
969          return $lists->search({ name => lc($name) })->first;          return $lists->search({ name => lc($name) })->first;
970  }  }
971    
972    
973    =head2 _remove_alias
974    
975    Remove list alias
976    
977     my $ok = $nos->_remove_alias(
978            email => 'mylist@example.com',
979            aliases => '/etc/mail/mylist',
980     );
981    
982    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
983    
984    =cut
985    
986    sub _remove_alias {
987            my $self = shift;
988    
989            my $arg = {@_};
990    
991            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
992            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
993    
994            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
995    
996            if ($a->exists($email)) {
997                    $a->delete($email) || croak "can't remove alias $email";
998            } else {
999                    return 0;
1000            }
1001    
1002            return 1;
1003    
1004    }
1005    
1006  ###  ###
1007  ### SOAP  ### SOAP
1008  ###  ###
# Line 880  Create new SOAP object Line 1042  Create new SOAP object
1042          aliases => '/etc/aliases',          aliases => '/etc/aliases',
1043   );   );
1044    
1045    If you are writing SOAP server (like C<soap.cgi> example), you will need to
1046    call this method once to make new instance of Nos::SOAP and specify C<dsn>
1047    and options for it.
1048    
1049  =cut  =cut
1050    
1051  sub new {  sub new {
1052          my $class = shift;          my $class = shift;
1053          my $self = {@_};          my $self = {@_};
1054    
1055          croak "need aliases parametar" unless ($self->{'aliases'});          croak "need aliases parametar" unless ($self->{'aliases'});
1056    
# Line 896  sub new { Line 1062  sub new {
1062  }  }
1063    
1064    
1065  =head2 NewList  =head2 CreateList
1066    
1067   $message_id = NewList(   $message_id = CreateList(
1068          list => 'My list',          list => 'My list',
1069          from => 'Name of my list',          from => 'Name of my list',
1070          email => 'my-list@example.com'          email => 'my-list@example.com'
# Line 906  sub new { Line 1072  sub new {
1072    
1073  =cut  =cut
1074    
1075  sub NewList {  sub CreateList {
1076          my $self = shift;          my $self = shift;
1077    
1078          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1079    
1080          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1081                  return $nos->new_list(                  return $nos->create_list(
1082                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
1083                          aliases => $aliases,                          aliases => $aliases,
1084                  );                  );
1085          } else {          } else {
1086                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1087          }          }
1088  }  }
1089    
1090    
1091  =head2 DeleteList  =head2 DropList
1092    
1093   $ok = DeleteList(   $ok = DropList(
1094          list => 'My list',          list => 'My list',
1095   );   );
1096    
1097  =cut  =cut
1098    
1099  sub DeleteList {  sub DropList {
1100          my $self = shift;          my $self = shift;
1101    
1102            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1103    
1104          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1105                  return $nos->delete_list(                  return $nos->drop_list(
1106                          list => $_[0],                          list => $_[0],
1107                            aliases => $aliases,
1108                  );                  );
1109          } else {          } else {
1110                  return $nos->delete_list( %{ shift @_ } );                  return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1111          }          }
1112  }  }
1113    
# Line 958  sub AddMemberToList { Line 1127  sub AddMemberToList {
1127    
1128          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1129                  return $nos->add_member_to_list(                  return $nos->add_member_to_list(
1130                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[4],                          list => $_[0], email => $_[1], name => $_[2], ext_id => $_[3],
1131                  );                  );
1132          } else {          } else {
1133                  return $nos->add_member_to_list( %{ shift @_ } );                  return $nos->add_member_to_list( %{ shift @_ } );
# Line 974  sub AddMemberToList { Line 1143  sub AddMemberToList {
1143    
1144  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
1145    
 Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It  
 seems that SOAP::Lite client thinks that it has array with one element which  
 is array of hashes with data.  
   
1146  =cut  =cut
1147    
1148  sub ListMembers {  sub ListMembers {
# Line 1038  sub AddMessageToList { Line 1203  sub AddMessageToList {
1203          }          }
1204  }  }
1205    
1206    =head2 MessagesReceived
1207    
1208    Return statistics about received messages.
1209    
1210     my @result = MessagesReceived(
1211            list => 'My list',
1212            email => 'jdoe@example.com',
1213            from_date => '2005-01-01 10:15:00',
1214            to_date => '2005-01-01 12:00:00',
1215            message => 0,
1216     );
1217    
1218    You must specify C<list> or C<email> or any combination of those two. Other
1219    parametars are optional.
1220    
1221    For format of returned array element see C<received_messages>.
1222    
1223    =cut
1224    
1225    sub MessagesReceived {
1226            my $self = shift;
1227    
1228            if ($_[0] !~ m/^HASH/) {
1229                    die "need at least list or email" unless (scalar @_ < 2);
1230                    return \@{ $nos->received_messages(
1231                            list => $_[0], email => $_[1],
1232                            from_date => $_[2], to_date => $_[3],
1233                            message => $_[4]
1234                    ) };
1235            } else {
1236                    my $arg = shift;
1237                    die "need list or email argument" unless ($arg->{'list'} || $arg->{'email'});
1238                    return \@{ $nos->received_messages( %{ $arg } ) };
1239            }
1240    }
1241    
1242    =head2 SendTest
1243    
1244    Internal function which does e-mail sending using C<Email::Send::Test> driver.
1245    
1246      my $sent = SendTest( list => 'My list' );
1247    
1248    Returns number of messages sent
1249    
1250    =cut
1251    
1252    sub SendTest {
1253            my $self = shift;
1254            my $args = shift;
1255            die "list name required" unless ($args->{list});
1256    
1257            require Email::Send::Test;
1258    
1259            my $nr_sent = $nos->send_queued_messages(
1260                    list => $args->{list},
1261                    driver => 'Test',
1262                    sleep => 0,
1263                    verbose => 0,
1264            );
1265    
1266            my @emails = Email::Send::Test->emails;
1267    
1268            open(my $tmp, ">/tmp/soap-debug");
1269            use Data::Dump qw/dump/;
1270            print $tmp "sent $nr_sent emails\n", dump(@emails);
1271            close($tmp);
1272    
1273            return $nr_sent;
1274    }
1275    
1276  ###  ###
1277    
1278    =head1 NOTE ON ARRAYS IN SOAP
1279    
1280    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1281    seems that SOAP::Lite client thinks that it has array with one element which
1282    is array of hashes with data.
1283    
1284  =head1 EXPORT  =head1 EXPORT
1285    
1286  Nothing.  Nothing.
Legend:
Removed from v.68  
changed lines
  Added in v.93
  ViewVC Help
Powered by ViewVC 1.1.26