package DADA::MailingList::Schedules; use strict; use lib qw(./ ../ ../../ ../../DADA ../perllib); use DADA::Config qw(!:DEFAULT); use DADA::App::Guts; use DADA::MailingList::Settings; use base "DADA::MailingList::Schedules::MLDb"; use Carp qw(croak carp); =pod =head1 NAME DADA::MailingList::Schedules =head1 Synopsis my $mss = DADA::MailingList::Schedules->new(-List => 'listshortname'); =head1 Description This module holds shared methods used for the Beatitude scheduled mailer. The rest of the methods are located in DADA::MailingList::Schedules::MLDb. =head1 Public Methods =cut =pod =head2 run_schedules my $report = $mss->run_schedules(-test => 0); Returns a nicely formatted report of the schedules that were run. If the B<-test> argument is passed with a value of 1, the schedules will go until actual mailing. =cut sub run_schedules { my $self = shift; my %args = (-test => undef, -verbose => undef, @_); my $r = ''; my $time = time; $r .= "\n" . '-' x 72 . "\nRunning Schedule For: " . $self->{name} . "\n"; $r .= "Current time is: " . $self->printable_date($time) . "\n"; my @record_keys = $self->record_keys(); $r .= " No schedules to run.\n" if ( !@record_keys); foreach my $rec_key(@record_keys){ #for all our schedules - my $mail_status = {}; my $checksums = {}; my $mailing_schedule = $self->mailing_schedule($rec_key); my $rec = $self->get_record($rec_key); my $run_this_schedule = 0; my $never_ran_before = 0; $r .= "\n Examining Schedule: '" . $rec->{message_name} . "'\n"; if($rec->{active} ==1){ #first things first, is this schedule even active? $r .= " '" . $rec->{message_name} . "' is active - \n"; if (! $rec->{last_schedule_run}){ $rec->{last_schedule_run} = ($time - 1); # This must be your first time, don't be nervous; tee hee! $never_ran_before = 1; } if($rec->{last_mailing}){ $r .= " Last mailing: " . $self->printable_date($rec->{last_mailing}) . "\n"; } if($never_ran_before == 1){ $r .= " This seems to be the first time schedule has been looked at...\n"; }else{ $r .= " Schedule last checked: " . $self->printable_date($rec->{last_schedule_run}) . "\n"; } if($mailing_schedule->[0]){ $r .= " Next mailing should be on: " . $self->printable_date($mailing_schedule->[0]) . "\n"; } CHECKSCHEDULE: foreach my $s_time(@$mailing_schedule){ # this should be last mailing, eh?! # no, since not all schedules repeat. if(($s_time <= $time) && ($s_time > $rec->{last_schedule_run})){ # Nothing in the future, mind. # Nothing before we need to. # There's a bug in here. For instance, a schedule will not go out, even # though the scheduled mailing is in the past IF the schedule has never # been checked. # $s_time = scheduled times # $time = right now # $rec->{last_schedule_run} - the last time it was run # $rec->{last_schedule_run} COULD BE $time as well, # if the schedule had never run. What to do? # we could set $rec->{last_schedule_run} to ($time - 1) if it's undefined, # or set the $rec->{last_schedule_run} to the time the schedule was first created...? # OR i guess we can do both.. # # at the moment, i'm going to do both, since I can't remember if $rec->{last_schedule_run} # is wiped out everytime a schedule is edited. $r .= " '" . $rec->{message_name} . "' scheduled to run now! \n"; $run_this_schedule = 1; last CHECKSCHEDULE; # run only the last schedule, lest we bombard a hapless list. } } }else{ $r .= " '" . $rec->{message_name} . "' is inactive. \n"; } if($run_this_schedule == 1){ if($args{-test} == 1){ ($mail_status, $checksums) = $self->send_scheduled_mailing( -key => $rec_key, -test => 1, -hold => 1, ); }else{ ($mail_status, $checksums) = $self->send_scheduled_mailing( -key => $rec_key, -test => $rec->{only_send_to_list_owner}, -hold => 1, ); if(! keys %$mail_status){ $rec->{last_mailing} = $time; # remember we sent the message at this time; } } } if(! $args{-test}){ $rec->{active} = 0 if ! $mailing_schedule->[0]; $rec->{last_schedule_run} = $time; if(keys %$checksums){ $rec->{PlainText_ver}->{checksum} = $checksums->{PlainText_checksum}; $rec->{HTML_ver}->{checksum} = $checksums->{HTML_checksum}; } $self->save_record(-key => $rec_key, -data => $rec, -mode => 'append'); # save the changes we've made to the record. $rec = $self->get_record($rec_key); } if(keys %$mail_status){ $r .= "\n *** Scheduled Mailing Not Sent, Reason(s): ***\n"; $r .= ' - ' . DADA::App::Guts::pretty($_) . "\n" foreach keys %$mail_status; $r .= "\n"; } if((! $args{-test}) && (! keys %$mail_status) && ($rec->{active} == 0) && ($rec->{self_destruct} == 1) ){ $r .= "\n Schedule is set to self destruct! \n"; $self->remove_record($rec_key); }else{ #print "nope!"; } } $r .= '-' x 72 . "\n"; $self->_send_held_messages; return $r; } =pod =head2 mailing_schedule my $mailing_schedule = $mss->mailing_schedule($key); returns a reference to an array of times that a schedule saved in $key has to be sent out. =cut sub mailing_schedule { my $self = shift; my $key = shift; my $today_is = time; croak "no key $!" if ! $key; my $r = $self->get_record($key); my $sched_mailing = $r->{mailing_date}; if($r->{repeat_mailing} != 1){ return [$r->{mailing_date}] if $r->{mailing_date} > $r->{last_schedule_run}; # not right now, when we last try to run the schdule. return []; }else{ return [$r->{mailing_date}] if $r->{repeat_times} < 1; my $timespan = 0; $timespan = 60 if $r->{repeat_label} eq 'minutes'; $timespan = 60 * 60 if $r->{repeat_label} eq 'hours'; $timespan = 60 * 60 * 24 if $r->{repeat_label} eq 'days'; $timespan = 60 * 60 * 24 * 30 if $r->{repeat_label} eq 'months'; $timespan = 60 * 60 * 24 * 265 if $r->{repeat_label} eq 'years'; if($r->{repeat_times}){ $timespan = ($timespan * $r->{repeat_times}); } my $i = 0; my @mailing_times;# = ($r->{mailing_date}); @mailing_times = ($r->{mailing_date}) if $r->{mailing_date} > $r->{last_schedule_run}; #Fucker. $r->{repeat_number} = 1000 if $r->{repeat_number} eq 'indefinite'; $r->{last_schedule_run} = $today_is if ! $r->{last_schedule_run}; $r->{repeat_number} = 0 if ! $r->{repeat_number}; if($r->{repeat_number} eq 'indefinite'){ # yeah, we *could* find each and every time a mailing should # go out, until... inifinity, but come now. # This will just find the next time a mailing should go out. my $i = 1; while($i == 1){ $sched_mailing = ($sched_mailing + $timespan); if($sched_mailing > $r->{last_schedule_run}){ # should /this/ be $r->{last_mailing}? # It doesn't matter, since only one schedule is # passed to the scheduled runner. push(@mailing_times, $sched_mailing); $i = 0; } } }else{ for($i = 0; $i <= $r->{repeat_number}; $i++){ $sched_mailing = ($sched_mailing + $timespan); push(@mailing_times, $sched_mailing) if $sched_mailing > $r->{last_schedule_run}; } } return \@mailing_times; } } =pod =head2 printable_date $mss->printable_date($form_vals->{last_mailing}) returns a date that's pretty to look at, when given a number of seconds since epoch. =cut sub printable_date { my $self = shift; my $date = shift; my %mail_month_values = ( 0 => 'January', 1 => 'February', 2 => 'March', 3 => 'April', 4 => 'May', 5 => 'June', 6 => 'July', 7 => 'August', 8 => 'September', 9 => 'October', 10 => 'November', 11 => 'December', ); my %mail_day_values = ( 1 => '1st', 2 => '2nd', 3 => '3rd', 4 => '4th', 5 => '5th', 6 => '6th', 7 => '7th', 8 => '8th', 9 => '9th', 10 => '10th', 11 => '11th', 12 => '12th', 13 => '13th', 14 => '14th', 15 => '15th', 16 => '16th', 17 => '17th', 18 => '18th', 19 => '19th', 20 => '20th', 21 => '21st', 22 => '22nd', 23 => '23rd', 24 => '24th', 25 => '25th', 26 => '26th', 27 => '27th', 28 => '28th', 29 => '29th', 30 => '30th', 31 => '31st', ); my %mail_minute_values = ( 0 => '00', 1 => '01', 2 => '02', 3 => '03', 4 => '04', 5 => '05', 6 => '06', 7 => '07', 8 => '08', 9 => '09', ); # 0 1 2 3 4 5 6 7 8 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($date); my $ending = 'a.m.'; if($hour >= 12){ $hour -= 12 if $hour != 12; $ending = 'p.m.'; } $min = '0' . $min if $min < 10; #$hour = 12 if $hour == 0; return $mail_month_values{$mon} . ' ' . $mail_day_values{$mday} . ' ' . ($year + 1900) . ' - ' . $hour . ':' . $min . ' '. $ending; } =pod =head2 send_scheduled_mailing my ($mail_status, $checksums) = $self->_send_scheduled_mailing( -key => $rec_key, -test => 0, -hold => 1, ); Sends an individual schedule, as defined by the information in B<-key>. if B<-hold> is set to 1, mailing will be queued until all schedules are run. (should be set to 1). If B<-test> is set to 1, only a test mailing (message to the list owner) will be run. =cut sub send_scheduled_mailing { my $self = shift; my %args = (-key => undef, -test => 0, -hold => 0, @_); croak "no key!" if ! $args{-key}; my ($send_flags, $checksums, $message) = $self->_build_email(-key => $args{-key}); if(! keys %$send_flags){ my $ls = DADA::MailingList::Settings->new(-List => $self->{name}); my $list_info = $ls->get(); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new($list_info); $mh->ignore_schedule_bulk_mailings(1); $mh->bulk_test(1) if $args{-test} == 1; if($args{-hold} == 1){ push(@{$self->{held_mailings}}, {-key => $args{-key}, -test => $args{-test}, -obj => $mh, -message => $message}); }else{ my $message_id = $mh->bulk_send(%$message); if ($args{-test} != 1){ $self->_archive_message(-key => $args{-key}, -message => $message, -mid => $message_id); } } } return ($send_flags, $checksums); } =pod =head1 Private Methods =head2 _send_held_messages $self->_send_held_messages; messages are queued up before being sent. Calling this method will send these queed messages. =cut sub _send_held_messages { my $self = shift; foreach my $held(@{$self->{held_mailings}}){ my $obj = $held->{-obj}; my $message = $held->{-message}; my $key = $held->{-key}; my $test = $held->{-test}; my $message_id = $obj->bulk_send(%$message); if ($held->{-test} != 1){ $self->_archive_message(-key => $key, -message => $message, -mid => $message_id); } } } =pod =head2 _build_email my ($send_flags, $checksums, $message) = $self->_build_email(-key => $key); Creates an email message ($message) that can then be sent with DADA::Mail::Send. It also returns the hashref, $send_flags that will denote any problems with message building, as well as a MD5 checksum of the message itself. =cut sub _build_email { my $self = shift; my %args = (-key => undef, @_); croak "no key!" if ! $args{-key}; my $record = $self->get_record($args{-key}); require MIME::Lite; #$MIME::Lite::PARANOID = $DADA::Config::MIME_PARANOID; MIME::Lite->quiet(1); my $send_flags = {}; my ($pt_flags, $pt_checksum, $pt_headers, $PlainText_ver) = $self->_create_text_ver(-record => $record, -type => 'PlainText'); my ($html_flags, $html_checksum, $html_headers, $HTML_ver) = $self->_create_text_ver(-record => $record, -type => 'HTML'); $send_flags->{PlainText_ver_undefined} = 1 if (! $PlainText_ver) && ($record->{PlainText_ver}->{only_send_if_defined}) == 1; $send_flags->{HTML_ver_undefined} = 1 if (! $HTML_ver) && ($record->{HTML_ver}->{only_send_if_defined}) == 1; %$send_flags = (%$send_flags, %$pt_flags, %$html_flags); my $msg; my $ls = DADA::MailingList::Settings->new(-List => $self->{name}); my $list_info = $ls->get(); if($PlainText_ver && $HTML_ver){ $msg = MIME::Lite->new(Type => 'multipart/alternative'); }elsif($PlainText_ver){ }elsif($HTML_ver){ }else{ $msg = MIME::Lite->new(Type =>'multipart/mixed'); } if($PlainText_ver && $HTML_ver){ $msg->attach( Type => 'text/plain', Data => $PlainText_ver, Encoding => $list_info->{plaintext_encoding}, ); $msg->attach( Type => 'text/html', Data => $HTML_ver, Encoding => $list_info->{html_encoding}, ); foreach(keys %$pt_headers){ $msg->add($_ => $pt_headers->{$_}); } foreach(keys %$html_headers){ $msg->add($_ => $html_headers->{$_}); } }elsif($PlainText_ver){ $msg = MIME::Lite->new( Type => 'text/plain', Data => $PlainText_ver, Encoding => $list_info->{plaintext_encoding}, ); foreach(keys %$pt_headers){ $msg->add($_ => $pt_headers->{$_}); } }elsif($HTML_ver){ $msg = MIME::Lite->new( #Type => $html_content_type, Type => 'text/html', # this is probably fine... Data => $HTML_ver, Encoding => $list_info->{html_encoding}, ); foreach(keys %$html_headers){ $msg->add($_ => $html_headers->{$_}); } } foreach my $att(@{$record->{attachments}}){ $msg->attach( Type => $self->_find_mime_type($att), Path => $att->{attachment_filename}, Disposition => $att->{attachment_disposition} ); } $msg->replace('X-Mailer' =>""); require DADA::App::FormatMessages; my $fm = DADA::App::FormatMessages->new(-List => $self->{name}); $record->{message_subject} = $pt_headers->{Subject} if $pt_headers->{Subject}; $record->{message_subject} = $html_headers->{Subject} if $html_headers->{Subject}; $fm->Subject($record->{message_subject}) if $record->{message_subject}; if($PlainText_ver && $HTML_ver){ $fm->use_plaintext_email_template($record->{PlainText_ver}->{use_email_template}); $fm->use_html_email_template( $record->{HTML_ver}->{use_email_template}); }elsif($PlainText_ver){ $fm->use_plaintext_email_template($record->{PlainText_ver}->{use_email_template}); $fm->use_html_email_template( $record->{PlainText_ver}->{use_email_template}); }elsif($HTML_ver){ $fm->use_plaintext_email_template($record->{HTML_ver}->{use_email_template}); $fm->use_html_email_template( $record->{HTML_ver}->{use_email_template}); } $fm->use_header_info(1); my ($final_header, $final_body) = $fm->format_headers_and_body(-msg => $msg->as_string); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new($list_info); my %headers = $mh->clean_headers($mh->return_headers($final_header)); # are these anyone's children? $pt_headers->{foo} = 'bar'; $html_headers->{foo} = 'bar'; my $return = {}; $return = { %headers, # Not sure if the, "To" and, "From" are needed... #From => '"'. DADA::App::Guts::escape_for_sending($list_info->{list_name}) .'" <'. $list_info->{list_owner_email} .'>', #To => '"'. DADA::App::Guts::escape_for_sending($list_info->{list_name}) .'" <'. $list_info->{list_owner_email} .'>', Subject => $record->{message_subject}, Body => $final_body, }; return ($send_flags, {PlainText_checksum => $pt_checksum, HTML_checksum => $html_checksum}, $return); } =pod =head2 _create_text_ver my ($flags, $checksum, $headers, $message) = $self->_create_text_ver(-record => $record, -type => 'PlainText'); Creates the text part of an email, using the information saved in the $record record. Returns any problemswith building the message in $flags ($hashref), a checksum in $checksum, headers (hashref) in $headers and the actual message in $message. B<-type> needs to be either B or B. =cut sub _create_text_ver { my $self = shift; my %args = (-record => {}, -type => undef, @_); croak "no record! $!" unless keys %{$args{-record}}; croak "no type! $!" unless $args{-type}; my $record = $args{-record}; my $type = $args{-type}; my $headers = {}; my $data = undef; my $create_flags = {}; if($record->{$type . '_ver'}->{source} eq 'from_file'){ $data = $self->_from_file($record->{$type . '_ver'}->{file}); }elsif($record->{$type . '_ver'}->{source} eq 'from_url'){ $data = $self->_from_url($record->{$type . '_ver'}->{url}); }elsif($record->{$type . '_ver'}->{source} eq 'from_text'){ $data = $record->{$type . '_ver'}->{text}; } if($data){ my $we_gotta_virgin = $self->_virgin_check($record->{$type . '_ver'}->{checksum}, \$data); my $checksum = $self->_create_checksum(\$data); unless($we_gotta_virgin){ #mmmm, virgin... if($record->{$type . '_ver'}->{only_send_if_diff} == 1){ # hmmmm different... $create_flags->{$type . '_ver_same_as_last_mailing'} = 1; } } $data = DADA::App::Guts::strip($data); ($headers, $data) = $self->_grab_headers($data) if $record->{$type . '_ver'}->{grab_headers_from_message} == 1; return ($create_flags, $checksum, $headers, $data); }else{ return ({},{}, undef), } } =pod =head2 _from_file my $data = $self->_from_file($filename); Grabs the contents of a file, returns contents. =cut sub _from_file { my $self = shift; my $fn = shift; croak "no filename!" if ! $fn; open(FH, "<$fn") or return undef; my $data = undef; $data = do{ local $/; }; close(FH); return $data; } =pod =head2 _from_url my $data = $self->_from_url($url); returns the $data fetched from a URL =cut sub _from_url { my $self = shift; my $url = shift; croak "no url! $!" if ! $url; my $data = undef; require LWP::Simple; $data = LWP::Simple::get($url); return $data; } =pod =head2 _create_checksum my $cmp_cs = $self->_create_checksum($data_ref); Returns an md5 checksum of the reference to a scalar being passed. =cut sub _create_checksum { my $self = shift; my $data = shift; use Digest::MD5 qw(md5_hex); # Reminder: Ship with Digest::Perl::MD5.... if($] >= 5.008){ require Encode; my $cs = md5_hex(Encode::encode_utf8($$data)); return $cs; }else{ my $cs = md5_hex($$data); return $cs; } } =pod =head2 _virgin_check my $we_gotta_virgin = $self->_virgin_check($record->{$type . '_ver'}->{checksum}, \$data); Figures if a copy of a message has previously been sent, using the previous checksum value. =cut sub _virgin_check { my $self = shift; my $cs = shift; my $data_ref = shift; my $cmp_cs = $self->_create_checksum($data_ref); # carp 'comparing: ' . $cmp_cs . ' with: ' . $cs; return 1 if ! $cs; (($cmp_cs eq $cs) ? (return 0) : (return 1)); } =pod =head2 _grab_headers ($headers, $data) = $self->_grab_headers($data) if $record->{$type . '_ver'}->{grab_headers_from_message} == 1; Splits the message in $data into headers and a body. =cut sub _grab_headers { my $self = shift; my $data = shift; $data =~ m/(.*?)\n\n(.*)/s; my $headers = $1; my $body = $2; #init a new %hash my %headers; # split.. logically my @logical_lines = split /\n(?!\s)/, $headers; # make the hash foreach my $line(@logical_lines) { my ($label, $value) = split(/:\s*/, $line, 2); $headers{$label} = $value; # carp '$label ' . $label; # carp '$value ' . $value; } if(keys %headers){ return (\%headers, $body); }else{ return ({}, $data); } } sub _archive_message { my $self = shift; my %args = ( -key => undef, -message => {}, -mid => undef, @_, ); croak "no -key!" if !$args{-key}; croak "no -message!" if !keys %{$args{-message}}; croak "no -mid!" if ! $args{-mid}; my $rec = $self->get_record($args{-key}); if($rec->{archive_mailings} != 1){ return; } require DADA::MailingList::Archives; my $ls = DADA::MailingList::Settings->new(-List => $self->{name}); my $list_info = $ls->get(); my $la = DADA::MailingList::Archives->new(-List => $list_info); my $raw_msg; foreach(keys %{$args{-message}}){ next if $_ eq 'Body'; $raw_msg .= $_ . ': ' . $args{-message}->{$_} . "\n"; } $raw_msg .= "\n\n" . $args{-message}->{Body}; $la->set_archive_info( $args{-mid}, $args{-message}->{Subject}, undef, undef, $raw_msg, ); } # deprecated. sub can_archive { return 1; } =pod =head2 _find_mime_type my $type = $self->_find_mime_type('filename.txt'); Attempts to figure out the MIME type of a filename. =cut sub _find_mime_type { my $self = shift; my $att = shift; croak "no attachment! $! " if ! $att; my $mime_type = 'AUTO'; if ($att->{attachment_mimetype} =~ m/auto/){ my $file_ending = $att->{attachment_filename}; require MIME::Types; require MIME::Type; if(($MIME::Types::VERSION >= 1.005) && ($MIME::Type::VERSION >= 1.005)){ $file_ending =~ s/^\.//; my $mimetypes = MIME::Types->new; my MIME::Type $attachment_type = $mimetypes->mimeTypeOf($file_ending); $mime_type = $attachment_type; }else{ # Alright, we're going to have to figure this one ourselves... if(exists($DADA::Config::MIME_TYPES {'.'.lc($file_ending)})) { $mime_type = $DADA::Config::MIME_TYPES {'.'.lc($file_ending)}; }else{ # Drat! all hope is lost! Abandom ship! $mime_type = $DADA::Config::DEFAULT_MIME_TYPE; } } }else{ $mime_type = $att->{attachment_mimetype}; } $mime_type = 'AUTO' if(! $mime_type); return $mime_type; } 1; =pod =head1 COPYRIGHT Copyright (c) 1999-2007 Justin Simoni All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. =cut