API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Dec 13th, 2018
146
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 35.97 KB | None | 0 0
raw download clone embed print report
  1. package DADA::MailingList::Schedules;
  2. use strict;
  3.  
  4. use lib qw(./ ../ ../../ ../../DADA ../perllib);
  5.  
  6.  
  7. use DADA::Config qw(!:DEFAULT);
  8. use DADA::App::Guts;
  9. use DADA::MailingList::Settings;
  10. use base "DADA::MailingList::Schedules::MLDb";
  11.  
  12. use Carp qw(croak carp);
  13. use Encode;
  14.  
  15.  
  16. use strict;
  17. #use vars qw(@EXPORT);
  18.  
  19.  
  20. =pod
  21.  
  22. =head1 NAME DADA::MailingList::Schedules
  23.  
  24. =head1 Synopsis
  25.  
  26. my $mss = DADA::MailingList::Schedules->new({-list => 'listshortname'});
  27.  
  28. =head1 Description
  29.  
  30. This module holds shared methods used for the Beatitude scheduled
  31. mailer. The rest of the methods are located in DADA::MailingList::Schedules::MLDb.
  32.  
  33. =head1 Public Methods
  34.  
  35. =cut
  36.  
  37.  
  38. =pod
  39.  
  40. =head2 run_schedules
  41.  
  42. my $report = $mss->run_schedules(-test => 0);
  43.  
  44. Returns a nicely formatted report of the schedules that were run.
  45.  
  46. If the B<-test> argument is passed with a value of 1, the schedules
  47. will go until actual mailing.
  48.  
  49. =cut
  50.  
  51. sub schedule_schema {
  52.  
  53.  
  54. my %d_form_vals = (
  55. message_name => 'scheduled mailing',
  56. active => 0,
  57. mailing_date => time,
  58. repeat_times => 1,
  59. repeat_label => 'days',
  60. repeat_mailing => 0,
  61. only_send_to_list_owner => 0,
  62. archive_mailings => 0,
  63. only_send_if_diff => 0,
  64. self_destruct => 0,
  65.  
  66. headers =>
  67.  
  68. {
  69.  
  70. 'Reply-To' => undef,
  71. 'Return-Path' => undef,
  72. 'X-Priority' => undef,
  73. Subject => undef,
  74.  
  75. },
  76.  
  77. PlainText_ver => {
  78. source => 'from_text',
  79. use_email_template => 1,
  80. only_send_if_defined => 0,
  81. grab_headers_from_message => 0,
  82.  
  83. },
  84. HTML_ver => {
  85. source => 'from_text',
  86. use_email_template => 1,
  87. only_send_if_defined => 0,
  88. grab_headers_from_message => 0,
  89.  
  90. url_options => 'extern',
  91. url_username => '',
  92. url_password => '',
  93. proxy => '',
  94.  
  95. },
  96. attachments => [],
  97. partial_sending_params => [
  98. # { field_name => '', field_comparison_type => '', field_value => '' },
  99. ],
  100.  
  101. );
  102.  
  103. return %d_form_vals;
  104.  
  105.  
  106. }
  107.  
  108.  
  109.  
  110.  
  111. sub save_from_params {
  112.  
  113. my $self = shift;
  114. my ($args) = @_;
  115. my $q;
  116.  
  117. if(! exists($args->{-cgi_obj}) ){
  118. croak "You must pass a -cgi_obj!";
  119. }
  120. else {
  121. $q = $args->{-cgi_obj};
  122. }
  123.  
  124.  
  125.  
  126. my %form_vals;
  127.  
  128. my $action = $q->param('action');
  129.  
  130. $form_vals{message_name} = $q->param('message_name');
  131. $form_vals{active} = $q->param('active') || 0;
  132. $form_vals{mailing_date} = $self->mailing_date($q);
  133. $form_vals{repeat_mailing} = $q->param('repeat_mailing') || 0;
  134. $form_vals{repeat_times} = $q->param('repeat_times') || 0;
  135. $form_vals{repeat_number} = $q->param('repeat_number');
  136. $form_vals{repeat_label} = $q->param('repeat_label');
  137. $form_vals{only_send_to_list_owner} = $q->param('only_send_to_list_owner') || 0;
  138. $form_vals{archive_mailings} = $q->param('archive_mailings') || 0;
  139.  
  140. my $tmp_record = {};
  141. if($q->param('key')){
  142. $tmp_record = $self->get_record($q->param('key'));
  143. }
  144.  
  145. $form_vals{headers} = {};
  146.  
  147. if(defined($q->param('Reply-To'))){
  148. $form_vals{headers}->{'Reply-To'} = $q->param('Reply-To');
  149. }
  150. if(defined($q->param('Errors-To'))){
  151. $form_vals{headers}->{'Errors-To'} = $q->param('Errors-To');
  152. }
  153. if(defined($q->param('Return-Path'))){
  154. $form_vals{headers}->{'Return-Path'} = $q->param('Return-Path');
  155. }
  156. if(defined($q->param('X-Priority'))){
  157. $form_vals{headers}->{'X-Priority'} = $q->param('X-Priority');
  158. }
  159. if(defined($q->param('Subject'))){
  160. $form_vals{headers}->{Subject} = $q->param('Subject');
  161. }
  162.  
  163. if(keys %{$tmp_record->{headers}}){
  164. # That sure was ugly...
  165. %{$form_vals{headers}} = (%{$tmp_record->{headers}}, %{$form_vals{headers}});
  166. }
  167.  
  168.  
  169. for my $t('PlainText', 'HTML'){
  170. $form_vals{$t.'_ver'}->{source} = $q->param($t.'_source');
  171.  
  172. # $form_vals{$t.'_ver'}->{text} = $q->param($t.'_text');
  173.  
  174. $form_vals{$t.'_ver'}->{url} = $q->param($t.'_url');
  175. $form_vals{$t.'_ver'}->{file} = $q->param($t.'_file');
  176. $form_vals{$t.'_ver'}->{use_email_template} = $q->param($t.'_use_email_template') || 0;
  177. $form_vals{$t.'_ver'}->{only_send_if_defined} = $q->param($t.'_only_send_if_defined') || 0;
  178. $form_vals{$t.'_ver'}->{only_send_if_diff} = $q->param($t.'_only_send_if_diff') || 0;
  179. $form_vals{$t.'_ver'}->{grab_headers_from_message} = $q->param($t.'_grab_headers_from_message') || 0;
  180. $form_vals{$t.'_ver'}->{text} =~ s/\r\n/\n/g; # I hate browsers.
  181.  
  182. $form_vals{$t.'_ver'}->{url_options} = $q->param($t.'_url_options');
  183. $form_vals{$t.'_ver'}->{url_username} = $q->param($t.'_url_username');
  184. $form_vals{$t.'_ver'}->{url_password} = $q->param($t.'_url_password');
  185. $form_vals{$t.'_ver'}->{proxy} = $q->param($t.'_proxy');
  186.  
  187.  
  188.  
  189. if($q->param('key')){
  190. %{$form_vals{$t.'_ver'}} = (%{$tmp_record->{$t.'_ver'}}, %{$form_vals{$t.'_ver'}}); # so as not to whipe out things like the checksums...
  191. }else{
  192. $form_vals{last_schedule_run} = time;
  193. }
  194. }
  195.  
  196. # See what I did, here?
  197. $form_vals{'PlainText_ver'}->{text} = $q->param('PlainText_text');
  198. $form_vals{'HTML_ver'}->{text} = $q->param('html_message_body');
  199.  
  200.  
  201.  
  202.  
  203.  
  204. $form_vals{attachments} = [];
  205.  
  206.  
  207. my $att_i = $q->param('num_attachments') || 0;
  208. my $i = 0;
  209. my $ditch_num;
  210.  
  211.  
  212. if($action =~ m/Remove Attachment /){
  213. $ditch_num = $action;
  214. $ditch_num =~ s/Remove Attachment //;
  215. }
  216. for($i = 0; $i <= $att_i; $i++){
  217. next if(defined($ditch_num) && ($ditch_num eq $i));
  218.  
  219. my $attachment = {};
  220. $attachment->{attachment_filename} = $q->param('attachment_filename_'.$i);
  221. $attachment->{attachment_disposition} = $q->param('attachment_disposition_'.$i);
  222. $attachment->{attachment_mimetype} = $q->param('attachment_mimetype_'.$i);
  223.  
  224. push(@{$form_vals{attachments}}, $attachment) if $q->param('attachment_filename_'.$i);
  225.  
  226. }
  227.  
  228. # Subscriber Profile Fields
  229. # First, let's figure out what they may be...
  230.  
  231. require DADA::MailingList::Subscribers;
  232. my $lh = DADA::MailingList::Subscribers->new(
  233. {
  234. -list => $self->{name},
  235. }
  236. );
  237.  
  238. my $fields = [];
  239. my $saved_pso = [];
  240.  
  241.  
  242. $fields = $lh->subscriber_fields;
  243. push(@$fields, 'email');
  244. for my $field(@$fields){
  245.  
  246. if(defined($q->param('field_comparison_type_' . $field))){
  247. push(@$saved_pso, {
  248.  
  249. field_name => $field,
  250. field_comparison_type => $q->param('field_comparison_type_' . $field),
  251. field_value => $q->param('field_value_' . $field),
  252. }
  253. );
  254.  
  255. }
  256. }
  257.  
  258. $form_vals{partial_sending_params} = $saved_pso;
  259.  
  260. my $s_key = $q->param('key');
  261. my $key = $self->save_record(
  262. -key => $s_key,
  263. -mode => 'append',
  264. -data => \%form_vals
  265. );
  266. return $key;
  267. }
  268.  
  269.  
  270.  
  271.  
  272. sub mailing_date {
  273.  
  274. my $self = shift;
  275. my $q = shift;
  276.  
  277. my $min = $q->param('mail_minute') || 0;
  278. my $hour = $q->param('mail_hour') || 12;
  279. my $mday = $q->param('mail_day') || 1;
  280. my $mon = $q->param('mail_month') || 0;
  281. my $year = $q->param('mail_year') || 0;
  282. my $mail_am_pm = $q->param('mail_am_pm') || 'am';
  283.  
  284. # This is a little hacky...
  285. if ( $mail_am_pm eq 'pm' ) {
  286.  
  287. # But - if the hour is, "12"
  288. # 12 + 12 is, "24" - not, "0' and not just, "12"
  289. if ( $hour != 12 ) {
  290. $hour += 12;
  291. }
  292. }
  293. elsif ( $mail_am_pm eq 'am' ) {
  294. if ( $hour == 12 ) {
  295. $hour = 0;
  296. }
  297. }
  298.  
  299. $min = int($min);
  300. require Time::Local;
  301. my $time = Time::Local::timelocal( 0, $min, $hour, $mday, $mon, $year );
  302.  
  303. return $time;
  304.  
  305. }
  306.  
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  
  313.  
  314. sub run_schedules {
  315. my $self = shift;
  316.  
  317.  
  318. my %args = (-test => undef,
  319. -verbose => undef,
  320. @_);
  321. my $need_to_backup = 0;
  322.  
  323. my $r = '';
  324.  
  325. my $time = time;
  326.  
  327. $r .= "\n" . '-' x 72 . "\nRunning Schedule For: " . $self->{name} . "\n";
  328. $r .= "Current time is: " . $self->printable_date($time) . "\n";
  329.  
  330. my @record_keys = $self->record_keys();
  331.  
  332.  
  333. $r .= " No schedules to run.\n" if ( !@record_keys);
  334. for my $rec_key(@record_keys){ #for all our schedules -
  335.  
  336. my $mail_status = {};
  337. my $checksums = {};
  338.  
  339. my $mailing_schedule = $self->mailing_schedule($rec_key);
  340. my $rec = $self->get_record($rec_key);
  341. my $run_this_schedule = 0;
  342. my $never_ran_before = 0;
  343.  
  344. $r .= "\n Examining Schedule: '" . $rec->{message_name} . "'\n";
  345.  
  346. if($rec->{active} ==1){ #first things first, is this schedule even active?
  347.  
  348. $r .= " '" . $rec->{message_name} . "' is active - \n";
  349.  
  350. if (! $rec->{last_schedule_run}){
  351. $rec->{last_schedule_run} = ($time - 1); # This must be your first time, don't be nervous; tee hee!
  352. $never_ran_before = 1;
  353. }
  354.  
  355. if($rec->{last_mailing}){
  356. $r .= " Last mailing: " . $self->printable_date($rec->{last_mailing}) . "\n";
  357. }
  358.  
  359. if($never_ran_before == 1){
  360. $r .= " This seems to be the first time schedule has been looked at...\n";
  361. }else{
  362. $r .= " Schedule last checked: " . $self->printable_date($rec->{last_schedule_run}) . "\n";
  363. }
  364.  
  365. if($mailing_schedule->[0]){
  366. $r .= " Next mailing should be on: " . $self->printable_date($mailing_schedule->[0]) . "\n";
  367. }
  368. CHECKSCHEDULE: for my $s_time(@$mailing_schedule){
  369. # this should be last mailing, eh?!
  370. # no, since not all schedules repeat.
  371. if(($s_time <= $time) && ($s_time > $rec->{last_schedule_run})){ # Nothing in the future, mind.
  372. # Nothing before we need to.
  373.  
  374. # There's a bug in here. For instance, a schedule will not go out, even
  375. # though the scheduled mailing is in the past IF the schedule has never
  376. # been checked.
  377.  
  378. # $s_time = scheduled times
  379. # $time = right now
  380. # $rec->{last_schedule_run} - the last time it was run
  381.  
  382. # $rec->{last_schedule_run} COULD BE $time as well,
  383. # if the schedule had never run. What to do?
  384.  
  385. # we could set $rec->{last_schedule_run} to ($time - 1) if it's undefined,
  386. # or set the $rec->{last_schedule_run} to the time the schedule was first created...?
  387. # OR i guess we can do both..
  388. #
  389. # at the moment, i'm going to do both, since I can't remember if $rec->{last_schedule_run}
  390. # is wiped out everytime a schedule is edited.
  391.  
  392.  
  393. $r .= " '" . $rec->{message_name} . "' scheduled to run now! \n";
  394. $run_this_schedule = 1;
  395. last CHECKSCHEDULE; # run only the last schedule, lest we bombard a hapless list.
  396. }
  397. }
  398. }else{
  399. $r .= " '" . $rec->{message_name} . "' is inactive. \n";
  400. }
  401.  
  402. if($run_this_schedule == 1){
  403. if($args{-test} == 1){
  404. ($mail_status, $checksums) = $self->send_scheduled_mailing(
  405. -key => $rec_key,
  406. -test => 1,
  407. -hold => 1,
  408. );
  409. }else{
  410. ($mail_status, $checksums) = $self->send_scheduled_mailing(
  411. -key => $rec_key,
  412. -test => $rec->{only_send_to_list_owner},
  413. -hold => 1,
  414. );
  415. if(! keys %$mail_status){
  416. $rec->{last_mailing} = $time; # remember we sent the message at this time;
  417. }
  418. }
  419. }
  420.  
  421.  
  422. if(! $args{-test}){
  423. $rec->{active} = 0 if ! $mailing_schedule->[0];
  424. $rec->{last_schedule_run} = $time;
  425.  
  426. if(keys %$checksums){
  427. $rec->{PlainText_ver}->{checksum} = $checksums->{PlainText_checksum};
  428. $rec->{HTML_ver}->{checksum} = $checksums->{HTML_checksum};
  429. }
  430.  
  431. # DEV: strangely, this will cause a backup to be made, each time you run the schedule.
  432. # DEV: Need to make this, so it only, at the very least, saves once for all the scheds,
  433. # Or things are going to get ridiculous.
  434. $self->save_record(
  435. -key => $rec_key,
  436. -data => $rec,
  437. -mode => 'append',
  438. -backup => 0,
  439. ); # save the changes we've made to the record.
  440.  
  441. $need_to_backup = 1;
  442. $rec = $self->get_record($rec_key);
  443.  
  444.  
  445. }
  446.  
  447. if(keys %$mail_status){
  448. $r .= "\n *** Scheduled Mailing Not Sent, Reason(s): ***\n";
  449. $r .= ' - ' . DADA::App::Guts::pretty($_) . "\n" for keys %$mail_status;
  450. $r .= "\n";
  451.  
  452. }
  453.  
  454. if((! $args{-test}) &&
  455. (! keys %$mail_status) &&
  456. ($rec->{active} == 0) &&
  457. ($rec->{self_destruct} == 1)
  458. ){
  459. $r .= "\n Schedule is set to self destruct! \n";
  460. $self->remove_record($rec_key);
  461. }else{
  462. #print "nope!";
  463. }
  464.  
  465.  
  466. }
  467.  
  468. $r .= '-' x 72 . "\n";
  469.  
  470. $self->_send_held_messages;
  471.  
  472. if($need_to_backup == 1){
  473. $self->backupToDir;
  474. }
  475. return $r;
  476.  
  477.  
  478. }
  479.  
  480.  
  481.  
  482. =pod
  483.  
  484. =head2 mailing_schedule
  485.  
  486. my $mailing_schedule = $mss->mailing_schedule($key);
  487.  
  488. returns a reference to an array of times that a schedule saved in $key has to be sent out.
  489.  
  490. =cut
  491.  
  492.  
  493. sub mailing_schedule {
  494. my $self = shift;
  495. my $key = shift;
  496. my $today_is = time;
  497.  
  498. if ( !defined($key) ) {
  499. croak "no key $!";
  500. }
  501.  
  502. my $r = $self->get_record($key);
  503. my $sched_mailing = $r->{mailing_date};
  504.  
  505. if ( $r->{repeat_mailing} != 1 ) {
  506.  
  507. # not right now, when we last try to run the schedule.
  508. if ( $r->{mailing_date} > $r->{last_schedule_run} ) {
  509. return [ $r->{mailing_date} ];
  510. }
  511. else {
  512. return [];
  513. }
  514. }
  515. else {
  516. if ( $r->{repeat_times} < 1 ) {
  517. return [ $r->{mailing_date} ];
  518. }
  519. else {
  520.  
  521. my $timespan = 0;
  522. $timespan = 60 if $r->{repeat_label} eq 'minutes';
  523. $timespan = 60 * 60 if $r->{repeat_label} eq 'hours';
  524. $timespan = 60 * 60 * 24 if $r->{repeat_label} eq 'days';
  525. $timespan = 60 * 60 * 24 * 30 if $r->{repeat_label} eq 'months';
  526. $timespan = 60 * 60 * 24 * 365 if $r->{repeat_label} eq 'years';
  527.  
  528. if ( $r->{repeat_times} ) {
  529. $timespan = ( $timespan * $r->{repeat_times} );
  530. }
  531.  
  532. my $i = 0;
  533. my @mailing_times; # = ($r->{mailing_date});
  534. if ( $r->{mailing_date} > $r->{last_schedule_run} ) {
  535. @mailing_times = ( $r->{mailing_date} );
  536. }
  537.  
  538. #Fucker. $r->{repeat_number} = 1000 if $r->{repeat_number} eq 'indefinite';
  539.  
  540. if ( !$r->{last_schedule_run} ) {
  541. $r->{last_schedule_run} = $today_is;
  542. }
  543. if ( !$r->{repeat_number} ) {
  544. $r->{repeat_number} = 0;
  545. }
  546.  
  547. if ( $r->{repeat_number} eq 'indefinite' ) {
  548.  
  549. # yeah, we *could* find each and every time a mailing should
  550. # go out, until... inifinity, but come now.
  551. # This will just find the next time a mailing should go out.
  552.  
  553. my $i = 1;
  554. while ( $i == 1 ) {
  555. $sched_mailing = ( $sched_mailing + $timespan );
  556. if ( $sched_mailing > $r->{last_schedule_run} )
  557. { # should /this/ be $r->{last_mailing}?
  558. # It doesn't matter, since only one schedule is
  559. # passed to the scheduled runner.
  560. push ( @mailing_times, $sched_mailing );
  561. $i = 0;
  562. }
  563. }
  564.  
  565. }
  566. else {
  567. for ( $i = 0 ; $i <= $r->{repeat_number} ; $i++ ) {
  568. $sched_mailing = ( $sched_mailing + $timespan );
  569. push ( @mailing_times, $sched_mailing )
  570. if $sched_mailing > $r->{last_schedule_run};
  571. }
  572. }
  573.  
  574. return \@mailing_times;
  575. }
  576.  
  577. }
  578. }
  579.  
  580.  
  581.  
  582.  
  583.  
  584. =pod
  585.  
  586. =head2 printable_date
  587.  
  588. $mss->printable_date($form_vals->{last_mailing})
  589.  
  590. returns a date that's pretty to look at, when given a number of seconds since epoch.
  591.  
  592. =cut
  593.  
  594.  
  595. sub printable_date {
  596.  
  597. # DEV: Tests are needed for this and actually, a better method should be
  598. # used to create this...
  599. my $self = shift;
  600. my $date = shift;
  601. return scalar localtime($date);
  602.  
  603.  
  604. }
  605.  
  606.  
  607. =pod
  608.  
  609. =head2 send_scheduled_mailing
  610.  
  611. my ($mail_status, $checksums)
  612. = $self->_send_scheduled_mailing(
  613. -key => $rec_key,
  614. -test => 0,
  615. -hold => 1,
  616. );
  617.  
  618. Sends an individual schedule, as defined by the information
  619. in B<-key>. if B<-hold> is set to 1, mailing will be queued until all
  620. schedules are run. (should be set to 1). If B<-test> is set to 1,
  621. only a test mailing (message to the list owner) will be run.
  622.  
  623. =cut
  624.  
  625. sub send_scheduled_mailing {
  626.  
  627. my $self = shift;
  628.  
  629. my %args = (-key => undef,
  630. -test => 0,
  631. -hold => 0,
  632. -test_recipient => undef,
  633. @_);
  634.  
  635. croak "no key!" if ! $args{-key};
  636.  
  637. my ($send_flags, $checksums, $message) = $self->_build_email(-key => $args{-key});
  638.  
  639.  
  640. if(! keys %$send_flags){
  641.  
  642. my $ls = DADA::MailingList::Settings->new({-list => $self->{name}});
  643.  
  644. my $list_info = $ls->get();
  645.  
  646. require DADA::Mail::Send;
  647.  
  648. my $mh = DADA::Mail::Send->new(
  649. {
  650. -list => $self->{name},
  651. -ls_obj => $ls,
  652. }
  653. );
  654.  
  655. $mh->ignore_schedule_bulk_mailings(1);
  656. if($args{-test} == 1){
  657. $mh->mass_test(1);
  658. if(defined($args{-test_recipient})){
  659. $mh->mass_test_recipient($args{-test_recipient});
  660. }
  661. }
  662.  
  663. ### Partial Sending Stuff...
  664. ### This is very much... busy, to say the least...
  665. # Probably should put this in its own method...
  666. # What's funny to me, is that it works....
  667.  
  668. my $record = $self->get_record($args{-key});
  669. my $partial_sending_params = $record->{partial_sending_params};
  670. my $partial_sending = {};
  671.  
  672.  
  673. for my $field(@$partial_sending_params){
  674.  
  675. if($field->{field_comparison_type} eq 'equal_to'){
  676. $partial_sending->{$field->{field_name}} = {equal_to => $field->{field_value}};
  677. }
  678. elsif($field->{field_comparison_type} eq 'like'){
  679. $partial_sending->{$field->{field_name}} = {like => $field->{field_value}};
  680. }
  681. }
  682.  
  683. if(keys %$partial_sending){
  684. $mh->partial_sending($partial_sending);
  685. }
  686.  
  687. ###/ Partial Sending Stuff...
  688.  
  689.  
  690.  
  691. if($args{-hold} == 1){
  692. push(@{$self->{held_mailings}}, {-key => $args{-key}, -test => $args{-test}, -obj => $mh, -message => $message});
  693. }else{
  694. my $message_id = $mh->mass_send(%$message);
  695. if ($args{-test} != 1){
  696. $self->_archive_message(-key => $args{-key}, -message => $message, -mid => $message_id);
  697. }
  698. }
  699. }
  700. return ($send_flags, $checksums);
  701.  
  702. }
  703.  
  704.  
  705.  
  706.  
  707.  
  708.  
  709.  
  710. =pod
  711.  
  712. =head1 Private Methods
  713.  
  714. =head2 _send_held_messages
  715.  
  716. $self->_send_held_messages;
  717.  
  718. messages are queued up before being sent. Calling this method will send
  719. these queued messages.
  720.  
  721. =cut
  722.  
  723.  
  724. sub _send_held_messages {
  725.  
  726. my $self = shift;
  727. for my $held(@{$self->{held_mailings}}){
  728. my $obj = $held->{-obj};
  729. my $message = $held->{-message};
  730. my $key = $held->{-key};
  731. my $test = $held->{-test};
  732. my $message_id = $obj->mass_send(%$message);
  733. if ($held->{-test} != 1){
  734. $self->_archive_message(-key => $key, -message => $message, -mid => $message_id);
  735. }
  736. }
  737. }
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  
  746. =pod
  747.  
  748. =head2 _build_email
  749.  
  750. my ($send_flags, $checksums, $message) = $self->_build_email(-key => $key);
  751.  
  752. Creates an email message ($message) that can then be sent with DADA::Mail::Send. It also
  753. returns the hashref, $send_flags that will denote any problems with message building,
  754. as well as a MD5 checksum of the message itself.
  755.  
  756. =cut
  757.  
  758. sub _build_email {
  759.  
  760. my $self = shift;
  761. my %args = (-key => undef,
  762. @_);
  763.  
  764. croak "no key!" if ! $args{-key};
  765.  
  766. my $record = $self->get_record($args{-key});
  767.  
  768. require MIME::Lite;
  769. #$MIME::Lite::PARANOID = $DADA::Config::MIME_PARANOID;
  770. MIME::Lite->quiet(1);
  771.  
  772. my $send_flags = {};
  773.  
  774. # Hmm - we can have this happen, to get the checksum stuff and then *redo* it for the URL stuff, if needed?
  775. # Because - well, the checksum is probably even more accurate, before we bring the data into MIME::Lite::HTML -
  776. # As it says right in the docs the MIME creation stuff is desctruction. Ok? OK.
  777. # Then, if we do pull data from a URL, we just throw the info from $HTML_ver away, remake it, via
  778. # MIME::Lite::HTML and call it good.
  779. my ($pt_flags, $pt_checksum, $pt_headers, $PlainText_ver) = $self->_create_text_ver(-record => $record, -type => 'PlainText');
  780. my ($html_flags, $html_checksum, $html_headers, $HTML_ver) = $self->_create_text_ver(-record => $record, -type => 'HTML');
  781.  
  782.  
  783. #use Data::Dumper;
  784. #die Data::Dumper::Dumper($HTML_ver);
  785.  
  786. # So. Right here?
  787. require DADA::App::FormatMessages;
  788. ($PlainText_ver, $HTML_ver) = DADA::App::FormatMessages::pre_process_msg_strings($PlainText_ver, $HTML_ver);
  789.  
  790. $send_flags->{PlainText_ver_undefined} = 1 if (! $PlainText_ver) && ($record->{PlainText_ver}->{only_send_if_defined}) == 1;
  791. $send_flags->{HTML_ver_undefined} = 1 if (! $HTML_ver) && ($record->{HTML_ver} ->{only_send_if_defined}) == 1;
  792.  
  793.  
  794. %$send_flags = (%$send_flags, %$pt_flags, %$html_flags);
  795.  
  796. # Wait, so EVEN if there's flags that should stop the mailing - we *MAKE* the mailing (just to have it not be sent?)
  797. # I thin it's there, so you can send a test message out to yourself.
  798. #
  799.  
  800.  
  801. my $ls = DADA::MailingList::Settings->new({-list => $self->{name}});
  802. my $list_info = $ls->get();
  803.  
  804. # So... then we have to first check if we have an HTML ver *AND* we need to pull it from a URL
  805. # (Actually, first I have to figure out how to add attachments to a MIME::Lite::HTML thingy...)
  806.  
  807. # Well, wait, I guess this'll be done for *every* type of HTML email?
  808. # This'll be a weird if() statement -
  809.  
  810. my $entity;
  811.  
  812. require MIME::Entity;
  813. if($HTML_ver){
  814.  
  815. require DADA::App::MyMIMELiteHTML;
  816.  
  817. my $login_details = undef;
  818. if(defined($record->{HTML_ver}->{url_username}) && defined($record->{HTML_ver}->{url_password})){
  819. $login_details = $record->{HTML_ver}->{url_username} . ':' . $record->{HTML_ver}->{url_password}
  820. }
  821.  
  822.  
  823. my $mailHTML = new DADA::App::MyMIMELiteHTML(
  824.  
  825. 'IncludeType' => 'cid',
  826. 'IncludeType' => $record->{HTML_ver}->{url_options},
  827.  
  828. # This has to be changed to actually be a changeable var
  829. 'TextCharset' => $ls->param('charset_value'),
  830. 'HTMLCharset' => $ls->param('charset_value'),
  831.  
  832. HTMLEncoding => $ls->param('html_encoding'),
  833. TextEncoding => $ls->param('plaintext_encoding'),
  834.  
  835. # Drrrrr, we're just using a string - these are useless
  836. # Ah! I've placed them in the right places - it all should work, YEAH!
  837. # (($record->{HTML_ver}->{proxy}) ? (Proxy => $record->{HTML_ver}->{proxy},) : ()),
  838. # (($login_details) ? (LoginDetails => $login_details,) : ()),
  839.  
  840. (
  841. ($DADA::Config::CPAN_DEBUG_SETTINGS{MIME_LITE_HTML} == 1) ?
  842. (Debug => 1, ) :
  843. ()
  844. ),
  845. );
  846.  
  847.  
  848. # Have to add the auto-plaintext stuff here... although this should
  849. # *really* be done automatically by Dada::App:FormatMessages...
  850. #
  851. my $plaintext_alt = undef;
  852.  
  853. if($PlainText_ver){
  854. $plaintext_alt = $PlainText_ver;
  855. }
  856. else {
  857. $plaintext_alt = html_to_plaintext({-string => $HTML_ver });
  858. }
  859. $plaintext_alt = safely_encode($plaintext_alt);
  860. $HTML_ver = safely_encode($HTML_ver);
  861.  
  862. my $MIMELiteObj;
  863. if($record->{'HTML_ver'}->{source} eq 'from_url'){
  864. $MIMELiteObj = $mailHTML->parse($HTML_ver, $plaintext_alt, $record->{'HTML_ver'}->{url});
  865. }
  866. else {
  867. $MIMELiteObj = $mailHTML->parse($HTML_ver, $plaintext_alt);
  868. }
  869.  
  870. # Error Handling... well, add later...
  871. my $html_msg = '';
  872. eval {
  873. $html_msg = $MIMELiteObj->as_string;
  874. $html_msg = safely_decode($html_msg);
  875. };
  876. if($@){
  877. # error message...
  878. }
  879. else {
  880. require MIME::Parser;
  881. my $parser = new MIME::Parser;
  882. $parser = optimize_mime_parser($parser);
  883. $entity = $parser->parse_data(
  884. $html_msg = safely_encode($html_msg)
  885. );
  886.  
  887. if(! $record->{attachments}->[0]) {
  888. # well, nothin'
  889. }
  890. else {
  891.  
  892. my $new_entity = MIME::Entity->build(Type => 'multipart/mixed');
  893. $new_entity->add_part($entity);
  894. for my $att(@{$record->{attachments}}){
  895. $new_entity->attach(
  896. Type => $self->_find_mime_type($att),
  897. Path => $att->{attachment_filename},
  898. Disposition => $att->{attachment_disposition}
  899. );
  900. }
  901. $entity = $new_entity;
  902.  
  903. }
  904.  
  905. for(keys %$pt_headers) {
  906. if($entity->head->get($_, 0)){
  907. $entity->head->delete($_);
  908. $entity->head->add($_, $pt_headers->{$_});
  909. }
  910. }
  911. for(keys %$html_headers) {
  912. if($entity->head->get($_, 0)){
  913. $entity->head->delete($_);
  914. $entity->head->add($_, $html_headers->{$_});
  915. }
  916. }
  917.  
  918. }
  919.  
  920.  
  921. }
  922. else {
  923. if($PlainText_ver){
  924.  
  925. $PlainText_ver = safely_encode($PlainText_ver);
  926. $entity = MIME::Entity->build(
  927. Type =>'text/plain',
  928. Encoding => $ls->param('plaintext_encoding'),
  929. Data => $PlainText_ver,
  930. );
  931.  
  932. for(keys %$pt_headers) {
  933. if($entity->head->get($_, 0)){
  934. $entity->head->delete($_);
  935. $entity->head->add($_, $pt_headers->{$_});
  936. }
  937. }
  938.  
  939. }
  940. else{
  941. $entity = MIME::Entity->build(
  942. Type =>'multipart/mixed',
  943. );
  944. }
  945.  
  946. # Attachments...
  947. for my $att(@{$record->{attachments}}){
  948. $entity->attach(
  949. Type => $self->_find_mime_type($att),
  950. Path => $att->{attachment_filename},
  951. Disposition => $att->{attachment_disposition}
  952. );
  953.  
  954.  
  955. }
  956.  
  957. }
  958.  
  959.  
  960. require DADA::App::FormatMessages;
  961. my $fm = DADA::App::FormatMessages->new(-List => $self->{name});
  962. $fm->mass_mailing(1);
  963. # What?
  964. # I think this is only for our return value?
  965. $record->{headers}->{Subject} = $pt_headers->{Subject} if $pt_headers->{Subject};
  966. $record->{headers}->{Subject} = $html_headers->{Subject} if $html_headers->{Subject};
  967.  
  968. if(exists($record->{headers}->{Subject})){
  969. $fm->Subject($record->{headers}->{Subject})
  970. }
  971.  
  972. # OK, we at least have to populate so these get hit?
  973. # Maybe just set these to, "1" or some other type of true value?
  974. if($PlainText_ver && $HTML_ver){
  975.  
  976. $fm->use_plaintext_email_template($record->{PlainText_ver}->{use_email_template});
  977. $fm->use_html_email_template( $record->{HTML_ver}->{use_email_template});
  978.  
  979. }elsif($PlainText_ver){
  980.  
  981. $fm->use_plaintext_email_template($record->{PlainText_ver}->{use_email_template});
  982. $fm->use_html_email_template( $record->{PlainText_ver}->{use_email_template});
  983.  
  984. }elsif($HTML_ver){
  985.  
  986. $fm->use_plaintext_email_template($record->{HTML_ver}->{use_email_template});
  987. $fm->use_html_email_template( $record->{HTML_ver}->{use_email_template});
  988.  
  989. }
  990.  
  991. $fm->use_header_info(1);
  992.  
  993. my $stringify = $entity->stringify;
  994. $stringify = safely_decode($stringify);
  995.  
  996. my ($final_header, $final_body) = $fm->format_headers_and_body(-msg => $stringify);
  997.  
  998. require DADA::Mail::Send;
  999. my $mh = DADA::Mail::Send->new(
  1000. {
  1001. -list => $self->{name},
  1002. -ls_obj => $ls,
  1003. }
  1004. );
  1005. my %headers = $mh->clean_headers($mh->return_headers($final_header));
  1006.  
  1007. my $return = {};
  1008.  
  1009. $return = {
  1010. # In this case, I don't want to overwrite %headers,
  1011. %{$record->{headers}},
  1012. %headers,
  1013. Body => $final_body,
  1014. };
  1015.  
  1016. # Awww, shit - checksums?!
  1017. # I guess for the attachment one... - do an "as_string" on the body? And then, insert it in?
  1018. # This is getting a little messy... hmm...
  1019. #
  1020. return ($send_flags, {PlainText_checksum => $pt_checksum, HTML_checksum => $html_checksum}, $return);
  1021.  
  1022. }
  1023.  
  1024.  
  1025.  
  1026.  
  1027. =pod
  1028.  
  1029. =head2 _create_text_ver
  1030.  
  1031. my ($flags, $checksum, $headers, $message) = $self->_create_text_ver(-record => $record, -type => 'PlainText');
  1032.  
  1033. Creates the text part of an email, using the information saved in the
  1034. $record record. Returns any problemswith building the message in
  1035. $flags ($hashref), a checksum in $checksum, headers (hashref) in
  1036. $headers and the actual message in $message. B<-type> needs to
  1037. be either B<PlaintText> or B<HTML>.
  1038.  
  1039. =cut
  1040.  
  1041.  
  1042.  
  1043.  
  1044. sub _create_text_ver {
  1045.  
  1046. my $self = shift;
  1047.  
  1048. my %args = (-record => {},
  1049. -type => undef,
  1050. @_);
  1051.  
  1052. croak "no record! $!" unless keys %{$args{-record}};
  1053. croak "no type! $!" unless $args{-type};
  1054.  
  1055. my $record = $args{-record};
  1056. my $type = $args{-type};
  1057. my $headers = {};
  1058. my $data = undef;
  1059. my $create_flags = {};
  1060.  
  1061. if($record->{$type . '_ver'}->{source} eq 'from_file'){
  1062. $data = $self->_from_file($record->{$type . '_ver'}->{file});
  1063. }elsif($record->{$type . '_ver'}->{source} eq 'from_url'){
  1064. $data = $self->_from_url($record->{$type . '_ver'}->{url}, $type . '_ver', $record);
  1065. }elsif($record->{$type . '_ver'}->{source} eq 'from_text'){
  1066. $data = $record->{$type . '_ver'}->{text};
  1067. }
  1068.  
  1069. if($data){
  1070.  
  1071. my $we_gotta_virgin = $self->_virgin_check($record->{$type . '_ver'}->{checksum}, \$data);
  1072.  
  1073. my $checksum = $self->_create_checksum(\$data);
  1074.  
  1075. unless($we_gotta_virgin){ #mmmm, virgin...
  1076. if($record->{$type . '_ver'}->{only_send_if_diff} == 1){ # hmmmm different...
  1077. $create_flags->{$type . '_ver_same_as_last_mailing'} = 1;
  1078. }
  1079. }
  1080.  
  1081. $data = DADA::App::Guts::strip($data);
  1082. if ($record->{$type . '_ver'}->{grab_headers_from_message} == 1) {
  1083.  
  1084. ($headers, $data) = $self->_grab_headers($data);
  1085. # use Data::Dumper;
  1086. #die Data::Dumper::Dumper([$headers, $data]);
  1087. }
  1088.  
  1089. return ($create_flags, $checksum, $headers, $data);
  1090.  
  1091. }else{
  1092. return ({},{}, undef),
  1093. }
  1094.  
  1095. }
  1096.  
  1097.  
  1098.  
  1099.  
  1100. =pod
  1101.  
  1102. =head2 _from_file
  1103.  
  1104. my $data = $self->_from_file($filename);
  1105.  
  1106. Grabs the contents of a file, returns contents.
  1107.  
  1108. =cut
  1109.  
  1110.  
  1111. sub _from_file {
  1112.  
  1113. my $self = shift;
  1114. my $fn = shift;
  1115. croak "no filename!" if ! $fn;
  1116.  
  1117. open(FH, '<:encoding(' . $DADA::Config::HTML_CHARSET . ')', $fn) or return undef;
  1118. my $data = undef;
  1119. $data = do{ local $/; <FH> };
  1120.  
  1121. close(FH);
  1122. return $data;
  1123. }
  1124.  
  1125.  
  1126.  
  1127.  
  1128.  
  1129. =pod
  1130.  
  1131. =head2 _from_url
  1132.  
  1133. my $data = $self->_from_url($url);
  1134.  
  1135. returns the $data fetched from a URL
  1136.  
  1137. =cut
  1138.  
  1139.  
  1140. sub _from_url {
  1141.  
  1142. my $self = shift;
  1143. my $url = shift;
  1144. my $type = shift;
  1145. my $record = shift;
  1146.  
  1147. # Create a user agent object
  1148. require LWP::UserAgent;
  1149. my $ua = LWP::UserAgent->new;
  1150.  
  1151. # $ua->agent("MyApp/0.1 ");
  1152.  
  1153. $ua->agent('Mozilla/5.0 (compatible; ' . $DADA::CONFIG::PROGRAM_NAME . ')');
  1154.  
  1155.  
  1156. if(defined($record->{$type . '_ver'}->{proxy})){
  1157. $ua->proxy(
  1158. ['http', 'ftp'],
  1159. $record->{$type . '_ver'}->{proxy}
  1160. );
  1161. }
  1162.  
  1163. # Create a request
  1164. my $req = HTTP::Request->new(
  1165. GET => $url
  1166. );
  1167. # Pass request to the user agent and get a response back
  1168. my $res = $ua->request($req);
  1169. if(
  1170. defined($record->{$type . '_ver'}->{url_username}) &&
  1171. defined($record->{$type . '_ver'}->{url_password})
  1172. ){
  1173. $res->authorization_basic(
  1174. $record->{$type . '_ver'}->{url_username},
  1175. $record->{$type . '_ver'}->{url_password}
  1176. );
  1177. }
  1178. # Check the outcome of the response
  1179. if ($res->is_success) {
  1180. return $res->content;
  1181. }
  1182. else {
  1183. warn $res->status_line;
  1184. return undef;
  1185. }
  1186. }
  1187.  
  1188.  
  1189.  
  1190.  
  1191.  
  1192.  
  1193. =pod
  1194.  
  1195. =head2 _create_checksum
  1196.  
  1197. my $cmp_cs = $self->_create_checksum($data_ref);
  1198.  
  1199. Returns an md5 checksum of the reference to a scalar being passed.
  1200.  
  1201. =cut
  1202.  
  1203.  
  1204. sub _create_checksum {
  1205.  
  1206. my $self = shift;
  1207. my $data = shift;
  1208.  
  1209. use Digest::MD5 qw(md5_hex); # Reminder: Ship with Digest::Perl::MD5....
  1210.  
  1211. if($] >= 5.008){
  1212. require Encode;
  1213. my $cs = md5_hex(safely_encode($$data));
  1214. return $cs;
  1215. }else{
  1216. my $cs = md5_hex($$data);
  1217. return $cs;
  1218. }
  1219. }
  1220.  
  1221.  
  1222.  
  1223.  
  1224.  
  1225. =pod
  1226.  
  1227. =head2 _virgin_check
  1228.  
  1229. my $we_gotta_virgin = $self->_virgin_check($record->{$type . '_ver'}->{checksum}, \$data);
  1230.  
  1231. Figures if a copy of a message has previously been sent, using the previous checksum value.
  1232.  
  1233. =cut
  1234.  
  1235.  
  1236.  
  1237. sub _virgin_check {
  1238.  
  1239. my $self = shift;
  1240. my $cs = shift;
  1241.  
  1242. my $data_ref = shift;
  1243.  
  1244.  
  1245. my $cmp_cs = $self->_create_checksum($data_ref);
  1246.  
  1247. # carp 'comparing: ' . $cmp_cs . ' with: ' . $cs;
  1248.  
  1249. return 1 if ! $cs;
  1250. (($cmp_cs eq $cs) ? (return 0) : (return 1));
  1251.  
  1252. }
  1253.  
  1254.  
  1255.  
  1256.  
  1257.  
  1258. =pod
  1259.  
  1260. =head2 _grab_headers
  1261.  
  1262. ($headers, $data) = $self->_grab_headers($data) if $record->{$type . '_ver'}->{grab_headers_from_message} == 1;
  1263.  
  1264. Splits the message in $data into headers and a body.
  1265.  
  1266. =cut
  1267.  
  1268. sub _grab_headers {
  1269.  
  1270. my $self = shift;
  1271. my $data = shift;
  1272.  
  1273. $data =~ m/(.*?)\n\n(.*)/s;
  1274.  
  1275. my $headers = $1;
  1276. my $body = $2;
  1277.  
  1278. #init a new %hash
  1279. my %headers;
  1280.  
  1281. # split.. logically
  1282. my @logical_lines = split /\n(?!\s)/, $headers;
  1283.  
  1284. # make the hash
  1285. for my $line(@logical_lines) {
  1286. my ($label, $value) = split(/:\s*/, $line, 2);
  1287. $headers{$label} = $value;
  1288.  
  1289. # carp '$label ' . $label;
  1290. # carp '$value ' . $value;
  1291. }
  1292.  
  1293. if(keys %headers){
  1294. return (\%headers, $body);
  1295. }else{
  1296. return ({}, $data);
  1297. }
  1298. }
  1299.  
  1300.  
  1301.  
  1302.  
  1303. sub _archive_message {
  1304. my $self = shift;
  1305. my %args = (
  1306. -key => undef,
  1307. -message => {},
  1308. -mid => undef,
  1309. @_,
  1310. );
  1311. croak "no -key!" if !$args{-key};
  1312. croak "no -message!" if !keys %{$args{-message}};
  1313. croak "no -mid!" if ! $args{-mid};
  1314.  
  1315. my $rec = $self->get_record($args{-key});
  1316.  
  1317. if($rec->{archive_mailings} != 1){
  1318. return;
  1319. }
  1320.  
  1321. require DADA::MailingList::Archives;
  1322. my $ls = DADA::MailingList::Settings->new({-list => $self->{name}});
  1323. my $list_info = $ls->get();
  1324.  
  1325. my $la = DADA::MailingList::Archives->new({-list => $self->{name}});
  1326.  
  1327. my $raw_msg;
  1328.  
  1329. for(keys %{$args{-message}}){
  1330. next if $_ eq 'Body';
  1331. $raw_msg .= $_ . ': ' . $args{-message}->{$_} . "\n";
  1332. }
  1333. $raw_msg .= "\n\n" . $args{-message}->{Body};
  1334.  
  1335.  
  1336. $la->set_archive_info(
  1337. $args{-mid},
  1338. $args{-message}->{Subject},
  1339. undef,
  1340. undef,
  1341. $raw_msg,
  1342. );
  1343.  
  1344. }
  1345.  
  1346.  
  1347.  
  1348. # deprecated.
  1349. sub can_archive {
  1350. return 1;
  1351. }
  1352.  
  1353.  
  1354.  
  1355.  
  1356.  
  1357.  
  1358.  
  1359. =pod
  1360.  
  1361. =head2 _find_mime_type
  1362.  
  1363. my $type = $self->_find_mime_type('filename.txt');
  1364.  
  1365. Attempts to figure out the MIME type of a filename.
  1366.  
  1367. =cut
  1368.  
  1369.  
  1370. sub _find_mime_type {
  1371. my $self = shift;
  1372. my $att = shift;
  1373.  
  1374. croak "no attachment! $! " if ! $att;
  1375.  
  1376. my $mime_type = 'AUTO';
  1377.  
  1378. if ($att->{attachment_mimetype} =~ m/auto/){
  1379. my $file_ending = $att->{attachment_filename};
  1380.  
  1381. require MIME::Types;
  1382. require MIME::Type;
  1383.  
  1384. if(($MIME::Types::VERSION >= 1.005) && ($MIME::Type::VERSION >= 1.005)){
  1385. $file_ending =~ s/^\.//;
  1386. my $mimetypes = MIME::Types->new;
  1387. my MIME::Type $attachment_type = $mimetypes->mimeTypeOf($file_ending);
  1388. $mime_type = $attachment_type;
  1389. }else{
  1390. # Alright, we're going to have to figure this one ourselves...
  1391. if(exists($DADA::Config::MIME_TYPES {'.'.lc($file_ending)})) {
  1392. $mime_type = $DADA::Config::MIME_TYPES {'.'.lc($file_ending)};
  1393. }else{
  1394. # Drat! all hope is lost! Abandom ship!
  1395. $mime_type = $DADA::Config::DEFAULT_MIME_TYPE;
  1396. }
  1397. }
  1398. }else{
  1399. $mime_type = $att->{attachment_mimetype};
  1400. }
  1401.  
  1402. $mime_type = 'AUTO' if(! $mime_type);
  1403.  
  1404. return $mime_type;
  1405. }
  1406.  
  1407. 1;
  1408.  
  1409.  
  1410. =pod
  1411.  
  1412. =head1 COPYRIGHT
  1413.  
  1414. Copyright (c) 1999 - 2012 Justin Simoni All rights reserved.
  1415.  
  1416. This program is free software; you can redistribute it and/or
  1417. modify it under the terms of the GNU General Public License
  1418. as published by the Free Software Foundation; either version 2
  1419. of the License, or (at your option) any later version.
  1420.  
  1421. This program is distributed in the hope that it will be useful,
  1422. but WITHOUT ANY WARRANTY; without even the implied warranty of
  1423. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  1424. GNU General Public License for more details.
  1425.  
  1426. You should have received a copy of the GNU General Public License
  1427. along with this program; if not, write to the Free Software
  1428. Foundation, Inc., 59 Temple Place - Suite 330,
  1429. Boston, MA 02111-1307, USA.
  1430.  
  1431. =cut
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!