/[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 25 - (hide annotations)
Mon May 16 13:52:43 2005 UTC (18 years, 9 months ago) by dpavlin
File size: 5893 byte(s)
added SOAP server and example (non-working) client

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 dpavlin 25 add_member_to_list
13     add_message_to_queue
14 dpavlin 20 ) ] );
15    
16     our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
17    
18     our @EXPORT = qw(
19     );
20    
21     our $VERSION = '0.1';
22    
23     use Class::DBI::Loader;
24     use Email::Valid;
25     use Email::Send;
26     use Carp;
27    
28     =head1 NAME
29    
30     Nos - Notice Sender core module
31    
32     =head1 SYNOPSIS
33    
34     use Nos;
35     my $nos = new Nos();
36    
37     =head1 DESCRIPTION
38    
39     Core module for notice sender's functionality.
40    
41     =head1 METHODS
42    
43     =head2 new
44    
45     Create new instance specifing database, user, password and options.
46    
47     my $nos = new Nos(
48     dsn => 'dbi:Pg:dbname=notices',
49     user => 'dpavlin',
50     passwd => '',
51     debug => 1,
52     verbose => 1,
53     );
54    
55     =cut
56    
57     sub new {
58     my $class = shift;
59     my $self = {@_};
60     bless($self, $class);
61    
62 dpavlin 22 croak "need at least dsn" unless ($self->{'dsn'});
63    
64 dpavlin 20 $self->{'loader'} = Class::DBI::Loader->new(
65     debug => $self->{'debug'},
66     dsn => $self->{'dsn'},
67     user => $self->{'user'},
68     password => $self->{'passwd'},
69     namespace => "Nos",
70     # additional_classes => qw/Class::DBI::AbstractSearch/,
71     # additional_base_classes => qw/My::Stuff/,
72     relationships => 1,
73 dpavlin 22 ) || croak "can't init Class::DBI::Loader";
74 dpavlin 20
75     $self ? return $self : return undef;
76     }
77    
78 dpavlin 23 =head2 add_member_to_list
79    
80     Add new member to list
81    
82     $nos->add_member_to_list(
83     list => "My list",
84     email => "john.doe@example.com",
85     name => "John A. Doe",
86     );
87    
88     C<name> parametar is optional.
89    
90     Return true if user is added.
91    
92     =cut
93    
94     sub add_member_to_list {
95     my $self = shift;
96    
97     my $arg = {@_};
98    
99     my $email = $arg->{'email'} || confess "can't add user without e-mail";
100     my $name = $arg->{'name'} || '';
101     confess "need list name" unless ($arg->{'list'});
102    
103     if (! Email::Valid->address($email)) {
104     warn "SKIPPING $name <$email>";
105     return 0;
106     }
107    
108     print "# $name <$email>\n";
109    
110     my $lists = $self->{'loader'}->find_class('lists');
111     my $users = $self->{'loader'}->find_class('users');
112     my $user_list = $self->{'loader'}->find_class('user_list');
113    
114     my $list = $lists->find_or_create({
115     name => $arg->{'list'},
116     }) || croak "can't add list ",$arg->{'list'},"\n";
117    
118     my $this_user = $users->find_or_create({
119     email => $email,
120     full_name => $name,
121     }) || croak "can't find or create member\n";
122    
123     my $user_on_list = $user_list->find_or_create({
124     user_id => $this_user->id,
125     list_id => $list->id,
126     }) || croak "can't add user to list";
127    
128     $list->dbi_commit;
129     $this_user->dbi_commit;
130     $user_on_list->dbi_commit;
131    
132     return 1;
133     }
134    
135 dpavlin 24 =head2 add_message_to_queue
136    
137     Adds message to one list's queue for later sending.
138    
139     $nos->add_message_to_queue(
140     list => 'My list',
141     message => 'From: My list <mylist@example.com>
142     To: John A. Doe <john.doe@example.com>
143    
144     This is example message
145     ',
146     );
147    
148     On success returns ID of newly created (or existing) message.
149    
150     =cut
151    
152     sub add_message_to_queue {
153     my $self = shift;
154    
155     my $args = {@_};
156    
157     my $list_name = $args->{'list'} || confess "need list name";
158     my $message_text = $args->{'message'} || croak "need message";
159    
160     my $lists = $self->{'loader'}->find_class('lists');
161    
162     my $this_list = $lists->search(
163     name => $list_name,
164     )->first || croak "can't find list $list_name";
165    
166     my $messages = $self->{'loader'}->find_class('messages');
167    
168     my $this_message = $messages->find_or_create({
169     message => $message_text
170     }) || croak "can't insert message";
171    
172     $this_message->dbi_commit() || croak "can't add message";
173    
174     my $queue = $self->{'loader'}->find_class('queue');
175    
176     $queue->find_or_create({
177     message_id => $this_message->id,
178     list_id => $this_list->id,
179     }) || croak "can't add message ",$this_message->id," to list ",$this_list->id, ": ",$this_list->name;
180    
181     $queue->dbi_commit || croak "can't add message to list ",$this_list->name;
182    
183     return $this_message->id;
184     }
185    
186    
187 dpavlin 22 =head2 send_queued_messages
188 dpavlin 20
189 dpavlin 22 Send queued messages or just ones for selected list
190 dpavlin 20
191 dpavlin 24 $nos->send_queued_messages("My list");
192 dpavlin 20
193 dpavlin 21 =cut
194 dpavlin 20
195 dpavlin 22 sub send_queued_messages {
196 dpavlin 21 my $self = shift;
197 dpavlin 20
198 dpavlin 22 my $list_name = shift;
199 dpavlin 20
200 dpavlin 22 my $lists = $self->{'loader'}->find_class('lists');
201     my $queue = $self->{'loader'}->find_class('queue');
202     my $user_list = $self->{'loader'}->find_class('user_list');
203     my $sent = $self->{'loader'}->find_class('sent');
204 dpavlin 20
205 dpavlin 22 my $my_q;
206     if ($list_name ne '') {
207     my $l_id = $lists->search_like( name => $list_name )->first ||
208     croak "can't find list $list_name";
209     $my_q = $queue->search_like( list_id => $l_id ) ||
210     croak "can't find list $list_name";
211     } else {
212     $my_q = $queue->retrieve_all;
213     }
214 dpavlin 20
215 dpavlin 22 while (my $m = $my_q->next) {
216     next if ($m->all_sent);
217 dpavlin 20
218 dpavlin 22 print "sending message ",$m->message_id," enqueued on ",$m->date," to list ",$m->list_id->name,"\n";
219     my $msg = $m->message_id->message;
220 dpavlin 20
221 dpavlin 22 foreach my $u ($user_list->search(list_id => $m->list_id)) {
222 dpavlin 20
223 dpavlin 22 if ($sent->search( message_id => $m->message_id, user_id => $u->user_id )) {
224     print "SKIP ",$u->user_id->email," message allready sent\n";
225     } else {
226     print "\t",$u->user_id->email,"\n";
227 dpavlin 20
228 dpavlin 22 my $hdr = "From: " . $u->list_id->name . " <" . $u->list_id->email . ">\n" .
229     "To: " . $u->user_id->full_name . " <". $u->user_id->email. ">\n";
230 dpavlin 20
231 dpavlin 22 # FIXME do real sending :-)
232     send IO => "$hdr\n$msg";
233    
234     $sent->create({
235     message_id => $m->message_id,
236     user_id => $u->user_id,
237     });
238     $sent->dbi_commit;
239     }
240     }
241     $m->all_sent(1);
242     $m->update;
243     $m->dbi_commit;
244     }
245    
246 dpavlin 20 }
247    
248 dpavlin 25 =head1 EXPORT
249 dpavlin 20
250 dpavlin 25 Exported methods are also available using SOAP interface. For now, those are:
251 dpavlin 20
252 dpavlin 25 =over 4
253    
254     =item add_member_to_list
255    
256     =item add_message_to_queue
257    
258     =back
259    
260    
261 dpavlin 20 =head1 SEE ALSO
262    
263     mailman, ezmlm, sympa, L<Mail::Salsa>
264    
265 dpavlin 25
266 dpavlin 20 =head1 AUTHOR
267    
268     Dobrica Pavlinusic, E<lt>dpavlin@rot13.orgE<gt>
269    
270 dpavlin 25
271 dpavlin 20 =head1 COPYRIGHT AND LICENSE
272    
273     Copyright (C) 2005 by Dobrica Pavlinusic
274    
275     This library is free software; you can redistribute it and/or modify
276     it under the same terms as Perl itself, either Perl version 5.8.4 or,
277     at your option, any later version of Perl 5 you may have available.
278    
279    
280     =cut

  ViewVC Help
Powered by ViewVC 1.1.26