/[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 66 by dpavlin, Fri Jul 8 11:46:35 2005 UTC revision 76 by dpavlin, Wed Aug 24 22:11:00 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.5';  our $VERSION = '0.8';
20    
21  use Class::DBI::Loader;  use Class::DBI::Loader;
22  use Email::Valid;  use Email::Valid;
# Line 62  encoded) or anything else. Line 62  encoded) or anything else.
62  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
63  possibly remote Notice Sender SOAP server just once), send it out at  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  reasonable rate (so that it doesn't flood your e-mail infrastructure) and
65  track replies.  keep track replies.
66    
67  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
68  list of recipients while allowing individual responses to be examined.  list of recipients while allowing individual responses to be examined.
69  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
70  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 72  which can be used to track some unique i
72  particular user.  particular user.
73    
74  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
75  all available operation from scripts (see C<perldoc sender.pl>).  all available operation from scripts (see C<sender.pl --man>).
76  This command is also useful for debugging while writing client SOAP  This command is also useful for debugging while writing client SOAP
77  application.  application.
78    
# Line 116  sub new { Line 116  sub new {
116    
117          $self->{'hash_len'} ||= 8;          $self->{'hash_len'} ||= 8;
118    
119            $self->{'loader'}->find_class('received')->set_sql(
120                    'received' => qq{
121                            select
122                                    received.id as id,
123                                    lists.name as list,
124                                    users.ext_id as ext_id,
125                                    users.email as email,
126                                    bounced,received.date as date
127                            from received
128                            join lists on lists.id = list_id
129                            join users on users.id = user_id
130                    },
131            );
132    
133          $self ? return $self : return undef;          $self ? return $self : return undef;
134  }  }
135    
136    
137  =head2 new_list  =head2 create_list
138    
139  Create new list. Required arguments are name of C<list> and  Create new list. Required arguments are name of C<list>, C<email> address
140  C<email> address.  and path to C<aliases> file.
141    
142   $nos->new_list(   $nos->create_list(
143          list => 'My list',          list => 'My list',
144          from => 'Outgoing from comment',          from => 'Outgoing from comment',
145          email => 'my-list@example.com',          email => 'my-list@example.com',
146            aliases => '/etc/mail/mylist',
147            archive => '/path/to/mbox/archive',
148   );   );
149    
150  Returns ID of newly created list.  Returns ID of newly created list.
# Line 137  Calls internally C<_add_list>, see detai Line 153  Calls internally C<_add_list>, see detai
153    
154  =cut  =cut
155    
156  sub new_list {  sub create_list {
157          my $self = shift;          my $self = shift;
158    
159          my $arg = {@_};          my $arg = {@_};
# Line 156  sub new_list { Line 172  sub new_list {
172  }  }
173    
174    
175  =head2 delete_list  =head2 drop_list
176    
177  Delete list from database.  Delete list from database.
178    
179   my $ok = delete_list(   my $ok = drop_list(
180          list => 'My list'          list => 'My list'
181            aliases => '/etc/mail/mylist',
182   );   );
183    
184  Returns false if list doesn't exist.  Returns false if list doesn't exist.
185    
186  =cut  =cut
187    
188  sub delete_list {  sub drop_list {
189          my $self = shift;          my $self = shift;
190    
191          my $args = {@_};          my $args = {@_};
# Line 177  sub delete_list { Line 194  sub delete_list {
194    
195          $args->{'list'} = lc($args->{'list'});          $args->{'list'} = lc($args->{'list'});
196    
197            my $aliases = $args->{'aliases'} || croak "need path to aliases file";
198    
199          my $lists = $self->{'loader'}->find_class('lists');          my $lists = $self->{'loader'}->find_class('lists');
200    
201          my $this_list = $lists->search( name => $args->{'list'} )->first || return;          my $this_list = $lists->search( name => $args->{'list'} )->first || return;
202    
203            $self->_remove_alias( email => $this_list->email, aliases => $aliases);
204    
205          $this_list->delete || croak "can't delete list\n";          $this_list->delete || croak "can't delete list\n";
206    
207          return $lists->dbi_commit || croak "can't commit";          return $lists->dbi_commit || croak "can't commit";
# Line 260  List all members of some list. Line 281  List all members of some list.
281          list => 'My list',          list => 'My list',
282   );   );
283    
284  Returns array of hashes with user informations like this:  Returns array of hashes with user information like this:
285    
286   $member = {   $member = {
287          name => 'Dobrica Pavlinusic',          name => 'Dobrica Pavlinusic',
# Line 468  Send e-mail using SMTP server at 127.0.0 Line 489  Send e-mail using SMTP server at 127.0.0
489    
490  =back  =back
491    
492    Any other driver name will try to use C<Email::Send::that_driver> module.
493    
494  Default sleep wait between two messages is 3 seconds.  Default sleep wait between two messages is 3 seconds.
495    
496    This method will return number of succesfully sent messages.
497    
498  =cut  =cut
499    
500  sub send_queued_messages {  sub send_queued_messages {
# Line 482  sub send_queued_messages { Line 507  sub send_queued_messages {
507          my $sleep = $arg->{'sleep'};          my $sleep = $arg->{'sleep'};
508          $sleep ||= 3 unless defined($sleep);          $sleep ||= 3 unless defined($sleep);
509    
510            # number of messages sent o.k.
511            my $ok = 0;
512    
513          my $email_send_driver = 'Email::Send::IO';          my $email_send_driver = 'Email::Send::IO';
514          my @email_send_options;          my @email_send_options;
515    
516          if (lc($driver) eq 'smtp') {          if (lc($driver) eq 'smtp') {
517                  $email_send_driver = 'Email::Send::SMTP';                  $email_send_driver = 'Email::Send::SMTP';
518                  @email_send_options = ['127.0.0.1'];                  @email_send_options = ['127.0.0.1'];
519            } elsif ($driver && $driver ne '') {
520                    $email_send_driver = 'Email::Send::' . $driver;
521          } else {          } else {
522                  warn "dumping all messages to STDERR\n";                  warn "dumping all messages to STDERR\n";
523          }          }
# Line 557  sub send_queued_messages { Line 587  sub send_queued_messages {
587                                  }                                  }
588    
589                                  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);
590                                  my @bad = @{ $sent_status->prop('bad') };                                  my @bad;
591                                    @bad = @{ $sent_status->prop('bad') } if (eval { $sent_status->can('prop') });
592                                  croak "failed sending to ",join(",",@bad) if (@bad);                                  croak "failed sending to ",join(",",@bad) if (@bad);
593    
594                                  if ($sent_status) {                                  if ($sent_status) {
# Line 571  sub send_queued_messages { Line 602  sub send_queued_messages {
602    
603                                          print " - $sent_status\n";                                          print " - $sent_status\n";
604    
605                                            $ok++;
606                                  } else {                                  } else {
607                                          warn "ERROR: $sent_status\n";                                          warn "ERROR: $sent_status\n";
608                                  }                                  }
# Line 586  sub send_queued_messages { Line 618  sub send_queued_messages {
618                  $m->dbi_commit;                  $m->dbi_commit;
619          }          }
620    
621            return $ok;
622    
623  }  }
624    
625  =head2 inbox_message  =head2 inbox_message
# Line 684  sub inbox_message { Line 718  sub inbox_message {
718  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";  #       print "message_id: ",($message_id || "not found")," -- $is_bounce\n";
719  }  }
720    
721    =head2 received_messages
722    
723    Returns all received messages for given list or user.
724    
725     my @received = $nos->received_message(
726            list => 'My list',
727            email => "john.doe@example.com",
728     );
729    
730    Each element in returned array will have following structure:
731    
732     {
733            id => 42,                       # unique ID of received message
734            list => 'My list',              # useful only of filtering by email
735            ext_id => 9999,                 # ext_id from message user
736            email => 'jdoe@example.com',    # e-mail of user
737            bounced => 0,                   # true value if message is bounce
738            date => '2005-08-24 18:57:24',  # date of recival in ISO format
739     }
740    
741    
742    =cut
743    
744    sub received_messages {
745            my $self = shift;
746    
747            my $arg = {@_};
748    
749            croak "need list name or email" unless ($arg->{'list'} || $arg->{'email'});
750    
751            $arg->{'list'} = lc($arg->{'list'});
752            $arg->{'email'} = lc($arg->{'email'});
753    
754            my @out;
755    
756            my $sth = $self->{'loader'}->find_class('received')->sql_received;
757            $sth->execute();
758            return $sth->fetchall_hash;
759    }
760    
761    
762  =head1 INTERNAL METHODS  =head1 INTERNAL METHODS
763    
# Line 692  Beware of dragons! You shouldn't need to Line 766  Beware of dragons! You shouldn't need to
766    
767  =head2 _add_aliases  =head2 _add_aliases
768    
769  Add new list to C</etc/aliases> (or equivavlent) file  Add or update alias in C</etc/aliases> (or equivalent) file for selected list
770    
771   my $ok = $nos->add_aliases(   my $ok = $nos->add_aliases(
772          list => 'My list',          list => 'My list',
# Line 713  sub _add_aliases { Line 787  sub _add_aliases {
787    
788          my $arg = {@_};          my $arg = {@_};
789    
790          croak "need list and email options" unless ($arg->{'list'} && $arg->{'email'});          foreach my $o (qw/list email aliases/) {
791                    croak "need $o option" unless ($arg->{$o});
792            }
793    
794          my $aliases = $arg->{'aliases'} || croak "need aliases";          my $aliases = $arg->{'aliases'};
795            my $email = $arg->{'email'};
796            my $list = $arg->{'list'};
797    
798          unless (-e $aliases) {          unless (-e $aliases) {
799                  warn "aliases file $aliases doesn't exist, creating empty\n";                  warn "aliases file $aliases doesn't exist, creating empty\n";
800                  open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";                  open(my $fh, '>', $aliases) || croak "can't create $aliases: $!";
801                  close($fh);                  close($fh);
802                    chmod 0777, $aliases || warn "can't change permission to 0777";
803          }          }
804    
805            die "FATAL: aliases file $aliases is not writable\n" unless (-w $aliases);
806    
807          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: $!";
808    
809          my $target = '';          my $target = '';
# Line 744  sub _add_aliases { Line 825  sub _add_aliases {
825          $self_path =~ s#/[^/]+$##;          $self_path =~ s#/[^/]+$##;
826          $self_path =~ s#/t/*$#/#;          $self_path =~ s#/t/*$#/#;
827    
828          $target .= qq#| cd $self_path && ./sender.pl --inbox="$arg->{'list'}"#;          $target .= qq#| cd $self_path && ./sender.pl --inbox="$list"#;
829    
830          unless ($a->append($arg->{'email'}, $target)) {          if ($a->exists($email)) {
831                  croak "can't add alias ".$a->error_check;                  $a->update($email, $target) or croak "can't update alias ".$a->error_check;
832            } else {
833                    $a->append($email, $target) or croak "can't add alias ".$a->error_check;
834          }          }
835    
836            #$a->write($aliases) or croak "can't save aliases $aliases ".$a->error_check;
837    
838          return 1;          return 1;
839  }  }
840    
# Line 790  sub _add_list { Line 875  sub _add_list {
875                  list => $name,                  list => $name,
876                  email => $email,                  email => $email,
877                  aliases => $aliases,                  aliases => $aliases,
878          ) || croak "can't add alias $email for list $name";          ) || warn "can't add alias $email for list $name";
879    
880          my $l = $lists->find_or_create({          my $l = $lists->find_or_create({
881                  name => $name,                  name => $name,
# Line 832  sub _get_list { Line 917  sub _get_list {
917          return $lists->search({ name => lc($name) })->first;          return $lists->search({ name => lc($name) })->first;
918  }  }
919    
920    
921    =head2 _remove_alias
922    
923    Remove list alias
924    
925     my $ok = $nos->_remove_alias(
926            email => 'mylist@example.com',
927            aliases => '/etc/mail/mylist',
928     );
929    
930    Returns true if list is removed or false if list doesn't exist. Dies in case of error.
931    
932    =cut
933    
934    sub _remove_alias {
935            my $self = shift;
936    
937            my $arg = {@_};
938    
939            my $email = lc($arg->{'email'}) || confess "can't remove alias without email";
940            my $aliases = lc($arg->{'aliases'}) || confess "can't remove alias without list";
941    
942            my $a = new Mail::Alias($aliases) || croak "can't open aliases file $aliases: $!";
943    
944            if ($a->exists($email)) {
945                    $a->delete($email) || croak "can't remove alias $email";
946            } else {
947                    return 0;
948            }
949    
950            return 1;
951    
952    }
953    
954  ###  ###
955  ### SOAP  ### SOAP
956  ###  ###
# Line 871  Create new SOAP object Line 990  Create new SOAP object
990          aliases => '/etc/aliases',          aliases => '/etc/aliases',
991   );   );
992    
993    If you are writing SOAP server (like C<soap.cgi> example), you will need to
994    call this method once to make new instance of Nos::SOAP and specify C<dsn>
995    and options for it.
996    
997  =cut  =cut
998    
999  sub new {  sub new {
# Line 887  sub new { Line 1010  sub new {
1010  }  }
1011    
1012    
1013  =head2 NewList  =head2 CreateList
1014    
1015   $message_id = NewList(   $message_id = CreateList(
1016          list => 'My list',          list => 'My list',
1017          from => 'Name of my list',          from => 'Name of my list',
1018          email => 'my-list@example.com'          email => 'my-list@example.com'
# Line 897  sub new { Line 1020  sub new {
1020    
1021  =cut  =cut
1022    
1023  sub NewList {  sub CreateList {
1024          my $self = shift;          my $self = shift;
1025    
1026          my $aliases = $self->{'aliases'} || croak "Nos::SOAP need 'aliases' argument to new constructor";          my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1027    
1028          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1029                  return $nos->new_list(                  return $nos->create_list(
1030                          list => $_[0], from => $_[1], email => $_[2],                          list => $_[0], from => $_[1], email => $_[2],
1031                          aliases => $aliases,                          aliases => $aliases,
1032                  );                  );
1033          } else {          } else {
1034                  return $nos->new_list( %{ shift @_ }, aliases => $aliases );                  return $nos->create_list( %{ shift @_ }, aliases => $aliases );
1035          }          }
1036  }  }
1037    
1038    
1039  =head2 DeleteList  =head2 DropList
1040    
1041   $ok = DeleteList(   $ok = DropList(
1042          list => 'My list',          list => 'My list',
1043   );   );
1044    
1045  =cut  =cut
1046    
1047  sub DeleteList {  sub DropList {
1048          my $self = shift;          my $self = shift;
1049    
1050            my $aliases = $nos->{'aliases'} || croak "need 'aliases' argument to new constructor";
1051    
1052          if ($_[0] !~ m/^HASH/) {          if ($_[0] !~ m/^HASH/) {
1053                  return $nos->delete_list(                  return $nos->drop_list(
1054                          list => $_[0],                          list => $_[0],
1055                            aliases => $aliases,
1056                  );                  );
1057          } else {          } else {
1058                  return $nos->delete_list( %{ shift @_ } );                  return $nos->drop_list( %{ shift @_ }, aliases => $aliases );
1059          }          }
1060  }  }
1061    
# Line 965  sub AddMemberToList { Line 1091  sub AddMemberToList {
1091    
1092  Returns array of hashes with user informations, see C<list_members>.  Returns array of hashes with user informations, see C<list_members>.
1093    
 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.  
   
1094  =cut  =cut
1095    
1096  sub ListMembers {  sub ListMembers {
# Line 1029  sub AddMessageToList { Line 1151  sub AddMessageToList {
1151          }          }
1152  }  }
1153    
1154    =head1 UNIMPLEMENTED FUNCTIONS
1155    
1156    This is a stub for documentation of unimplemented functions.
1157    
1158    =head2 MessagesReceived
1159    
1160     my @result = MessagesReceived(
1161            list => 'My list',
1162            email => 'jdoe@example.com',
1163     );
1164    
1165    You can specify just C<list> or C<email> or any combination of those.
1166    
1167    For format of returned array element see C<received_messages>.
1168    
1169    =head2 MessagesReceivedByDate
1170    
1171    =head2 MessagesReceivedByDateWithContent
1172    
1173    =head2 ReceivedMessasgeContent
1174    
1175    Return content of received message.
1176    
1177     my $mail_body = ReceivedMessageContent( id => 42 );
1178    
1179    =cut
1180    
1181    
1182    
1183    
1184  ###  ###
1185    
1186    =head1 NOTE ON ARRAYS IN SOAP
1187    
1188    Returning arrays from SOAP calls is somewhat fuzzy (at least to me). It
1189    seems that SOAP::Lite client thinks that it has array with one element which
1190    is array of hashes with data.
1191    
1192  =head1 EXPORT  =head1 EXPORT
1193    
1194  Nothing.  Nothing.
Legend:
Removed from v.66  
changed lines
  Added in v.76
  ViewVC Help
Powered by ViewVC 1.1.26