#!/usr/bin/perl
use strict;
#-----------#
# Dada Mail #
#-----------#
#
# Homepage: http://mojo.skazat.com
#
# Support: http://mojo.skazat.com/support
#
# How To Ask For Free Help:
# http://mojo.skazat.com/support/documentation/getting_help.pod.html
#
# Please Do Not Contact the Author directly about Dada Mail support,
# unless for paid support! Please, and thank you.
#
# How to ask for paid consultation:
# http://mojo.skazat.com/support/regular.html
#---------------------------------------------------------------------#
#---------------------------------------------------------------------#
# The Path to your Perl *Libraries*:
# This IS NOT the path to Perl. The path to Perl is the first line of
# this script.
#
#
use lib qw(
./
./DADA
./DADA/perllib
);
# This list may need to be added to. Find the absolute to path to this
# very file. This:
#
# /home/youraccount/www/cgi-bin/dada/mail.cgi
#
# Is an example of what the absolute path to this file may be.
#
# Get rid of, "/mail.cgi"
#
# /home/youraccount/www/cgi-bin/dada
#
# Add that line after, "./DADA/perllib" above.
#
# Add "DADA", and, "DADA/perllib" from the absolute path you just made right
# after your last entry into the Path to your Perl Libraries:
#
# /home/youraccount/www/cgi-bin/dada/DADA
# /home/youraccount/www/cgi-bin/dada/DADA/perllib
#
# and you should be good to go.
#
# If this doesn't do the job - make sure ALL the directories, including the
# DADA directory have permissions of: 755 and all files have permissions
# of: 644
#---------------------------------------------------------------------#
#---------------------------------------------------------------------#
#
# If you'd like error messages to be printed out in your browser, uncomment the
# line that looks like this:
#
# #print "
$msg
";
#
# Why would you want this commented? Security.
use CGI::Carp qw(fatalsToBrowser set_message);
BEGIN {
sub handle_errors {
my $msg = shift;
print q{
Program Error (Server Error 500)
More information about this error may be available in the
server error log and/or program error log. Specific
information about this error does not appear here, for
security.
};
# Uncomment the BELOW line to receive error messages in your browser:
print "
$msg
";
}
set_message(\&handle_errors);
}
# You can also do this:
# The line above, 'use CGI::Carp qw(fatalsToBrowser set_message);',
# when changed to:
#
# use CGI::Carp "fatalsToBrowser";
#
# captures critical server errors created by Dada Mail and shows them
# in your Web browser. In other words, instead of seeing the,
#
# "Internal Server Error"
#
# message in your browser, you'll see something more interesting.
# If this does not give you any clue on what's wrong, consider
# setting the error log - See, "$PROGRAM_ERROR_LOG" in the Config.pm
# documentation.
#---------------------------------------------------------------------#
#---------------------------------------------------------------------#
# No more user-serviceable parts, please see the:
#
# dada/DADA/Config.pm
#
# file and:
#
# for instructions on how to install Dada Mail (easiest install)
#
# http://mojo.skazat.com/installation/
#
# and:
#
# http://mojo.skazat.com/purchase/sample_chapter-dada_mail_setup.html
#
# for, "Advanced" setup
#
# and:
#
# http://mojo.skazat.com/support/documentation/Config.pm.html
#
# for more than you'd ever want to know.
#---------------------------------------------------------------------#
$|++;
use DADA::Config;
$ENV{PATH} = "/bin:/usr/bin";
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
my $dbi_handle;
if($SUBSCRIBER_DB_TYPE =~ m/SQL/ || $ARCHIVE_DB_TYPE =~ m/SQL/ || $SETTINGS_DB_TYPE =~ m/SQL/){
require DADA::App::DBIHandle;
$dbi_handle = DADA::App::DBIHandle->new;
}
use DADA::App::ScreenCache;
my $c = DADA::App::ScreenCache->new;
use DADA::App::Guts;
use DADA::Template::HTML;
use DADA::MailingList::Subscribers;
$DADA::MailingList::Subscribers::dbi_obj = $dbi_handle;
use CGI;
CGI->nph(1)
if $NPH == 1;
my $q;
if($ENV{QUERY_STRING} =~ m/^\?/){
# DEV Workaround for servers that give a bad PATH_INFO:
# Set the $PROGRAM_URL to have, "?" at the end of the URL
# to change any PATH_INFO's into Query Strings.
# The below lines will then take this extra question mark
# out, so actual query strings will work as before.
$ENV{QUERY_STRING} =~ s/^\?//;
$q = new CGI($ENV{QUERY_STRING});
} else{
$q = new CGI();
}
$q->charset($HTML_CHARSET);
#---------------------------------------------------------------------#
# DEV: Should be removed, soon.
# width of the textarea
my $cols = 70;
# height of the textarea
my $rows = 15;
# wrap
my $wrap = 'NONE';
# style
my $text_area_style = 'font-size:11px';
#---------------------------------------------------------------------#
# Bad - global variable for the archive editor
# - I'll have to figure this out later.
my $skel = [];
#---------------------------------------------------------------------#
# DEV - This is NOT the best place to put this,
# but I guess we'll leave it here for now...
my %list_types = (list => 'Subscribers',
black_list => 'Black Listed',
moderators => 'Moderators',
testers => 'Testers',
white_list => 'White Listed',
);
my $type = $q->param('type') || 'list';
$type = 'list' if ! $list_types{$type};
my $type_title = "Subscribers";
$type_title = "Moderators"
if $type eq 'moderators';
$type_title = "Black Listed"
if $type eq 'black_list';
$type_title = "Testers"
if $type eq 'testers';
$type_title = "White Listed"
if $type eq 'white_list';
#---------------------------------------------------------------------#
if($ENV{PATH_INFO}){
my $dp = $q->url || $PROGRAM_URL;
$dp =~ s/^(http:\/\/|https:\/\/)(.*?)\//\//;
my $info = $ENV{PATH_INFO};
$info =~ s/^$dp//;
# script name should be something like:
# /cgi-bin/dada/mail.cgi
$info =~ s/^$ENV{SCRIPT_NAME}//i;
$info =~ s/(^\/|\/$)//g; #get rid of fore and aft slashes
# seriously, this shouldn't be needed:
$info =~ s/^dada\/mail\.cgi//;
if(!$info && $ENV{QUERY_STRING} && $ENV{QUERY_STRING} =~ m/^\//){
# DEV Workaround for servers that give a bad PATH_INFO:
# Set the $PROGRAM_URL to have, "?" at the end of the URL
# to change any PATH_INFO's into Query Strings.
# The below two lines change query strings that look like PATH_INFO's
# into PATH_INFO's
$info = $ENV{QUERY_STRING};
$info =~ s/(^\/|\/$)//g; #get rid of fore and aft slashes
}
if($info =~ m/css$/){
$q->param('f', 'css');
}elsif($info =~ m/$SIGN_IN_FLAVOR_NAME$/){
$q->param('f', $SIGN_IN_FLAVOR_NAME);
}elsif($info =~ m/$ADMIN_FLAVOR_NAME$/){
$q->param('f', $ADMIN_FLAVOR_NAME);
}elsif($info =~ m/^archive/){
# archive, archive_rss and archive_atom
# form:
#/archive/justin/20050422012839/
my ($pi_flavor, $pi_list, $pi_id, $extran) = split('/', $info);
$q->param('flavor', $pi_flavor)
if $pi_flavor;
$q->param('list', $pi_list)
if $pi_list;
$q->param('id', $pi_id)
if $pi_id;
$q->param('extran', $extran);
}elsif($info =~ /^smtm/){
$q->param('flavor', 'smtm');
}elsif($info =~ /^spacer_image/){
my ($throwaway, $pi_list, $pi_mid, $bollocks) = split('/', $info);
$q->param('flavor', 'm_o_c');
$q->param('list', $pi_list)
if $pi_list;
$q->param('mid', $pi_mid)
if $pi_mid;
}elsif($info =~ /^(s|n|u)/){
my ($pi_flavor, $pi_list, $pi_email, $pi_domain, $pi_pin) = split('/', $info);
# HACK: If there is no name and a domain, the entire email address is in "email"
# and there is no domain.
# move all the other variables to the right
# This being only the pin, at the moment
# 2.10 should have relieved this issue...
if($pi_email !~ m/\@/){
$pi_email = $pi_email . '@' . $pi_domain
if $pi_domain;
}else{
$pi_pin = $pi_domain
if !$pi_pin;
}
$q->param('flavor', $pi_flavor)
if $pi_flavor;
$q->param('list', $pi_list)
if $pi_list;
$q->param('email', $pi_email)
if $pi_email;
$q->param('pin', $pi_pin)
if $pi_pin;
}elsif($info =~ /^subscriber_help|^list/){
my ($pi_flavor, $pi_list) = split('/', $info);
$q->param('flavor', $pi_flavor)
if $pi_flavor;
$q->param('list', $pi_list)
if $pi_list;
}elsif($info =~ /^r/){
my ($pi_flavor, $pi_list, $pi_k, $pi_mid, @pi_url) = split('/', $info);
my $pi_url;
$q->param('flavor', $pi_flavor)
if $pi_flavor;
$q->param('list', $pi_list)
if $pi_list;
$q->param('k', $pi_k)
if $pi_k;
$pi_url = join('/', @pi_url)
if $pi_url[0];
$pi_url =~ s/\%3F/?/g;
$q->param('url', $pi_url)
if $pi_url;
$q->param('mid', $pi_mid)
if $pi_mid;
$q->param('url', 'http://' . $pi_url)
if($pi_k eq 'h');
$q->param('url', 'https://' . $pi_url)
if($pi_k eq 's');
}else{
if($info){
warn "Path Info present - but not valid? - '" . $ENV{PATH_INFO} . '" - filtered: "' . $info . '"' unless $info =~ m/^\x61\x72\x74/;
}
}
}
#---------------------------------------------------------------------#
my $flavor = $q->param('flavor');
$flavor = $q->param('f') unless($flavor);
my $process = $q->param('process');
my $email = $q->param('email') || "";
$email = $q->param('e') || "" unless($email);
my $list = $q->param('list');
$list = $q->param('l') unless($list);
my $list_name = $q->param('list_name');
my $pin = $q->param('pin');
$pin = $q->param('p') unless($pin);
my $admin_email = $q->param('admin_email');
my $list_owner_email = $q->param('list_owner_email');
my $info = $q->param('info');
my $privacy_policy = $q->param('privacy_policy');
my $physical_address = $q->param('physical_address');
my $password = $q->param('password');
my $retype_password = $q->param('retype_password');
my $keyword = $q->param('keyword');
my @address = $q->param('address');
my $done = $q->param('done');
my $id = $q->param('id');
my $quick = $q->param('quick') || 'no';
my $advanced = $q->param('advanced') || 'no';
my $help = $q->param('help');
my $set_flavor = $q->param('set_flavor');
#---------------------------------------------------------------------#
if($email){
$email =~ s/_p40p_/\@/;
$email =~ s/_p2Bp_/\+/g;
}
$list = xss_filter($list);
$flavor = xss_filter($flavor);
$email = xss_filter($email);
$pin = xss_filter($pin);
$keyword = xss_filter($keyword);
$set_flavor = xss_filter($set_flavor);
if($q->param('auth_state')){
$q->param('auth_state', xss_filter($q->param('auth_state')));
}
#external (mostly..) functions called from the web browser)
# a few things this program can do.... :)
my %Mode = (
'default' => \&default,
'subscribe' => \&subscribe,
'subscribe_flash_xml' => \&subscribe_flash_xml,
'unsubscribe_flash_xml' => \&unsubscribe_flash_xml,
'new' => \&confirm,
'unsubscribe' => \&unsubscribe,
#'admin' => \&admin,
'login' => \&login,
'logout' => \&logout,
'log_into_another_list' => \&log_into_another_list,
'change_login' => \&change_login,
'new_list' => \&new_list,
'change_info' => \&change_info,
'html_code' => \&html_code,
'admin_help' => \&admin_help,
'delete_list' => \&delete_list,
'list_stats' => \&list_stats,
'view_list' => \&view_list,
'view_list_options' => \&view_list_options,
'edit_subscriber' => \&edit_subscriber,
'add' => \&add,
'email_password' => \&email_password,
'add_email' => \&add_email,
'delete_email' => \&delete_email,
'subscription_options' => \&subscription_options,
'send_email' => \&send_email,
'preview_form' => \&preview_form,
'checker' => \&checker,
'edit_template' => \&edit_template,
'view_archive' => \&view_archive,
'display_message_source' => \&display_message_source,
'purge_all_archives' => \&purge_all_archives,
'delete_archive' => \&delete_archive,
'edit_archived_msg' => \&edit_archived_msg,
'archive' => \&archive,
'archive_bare' => \&archive_bare,
'archive_rss' => \&archive_rss,
'archive_atom' => \&archive_atom,
'manage_script' => \&manage_script,
'change_password' => \&change_password,
'text_list' => \&text_list,
'send_list_to_admin' => \&send_list_to_admin,
'search_email' => \&search_email,
'archive_options' => \&archive_options,
'adv_archive_options' => \&adv_archive_options,
'back_link' => \&back_link,
'edit_type' => \&edit_type,
'edit_html_type' => \&edit_html_type,
'list_options' => \&list_options,
'sending_options' => \&sending_options,
'adv_sending_options' => \&adv_sending_options,
#'sign_in' => \&sign_in,
'filter_using_black_list' => \&filter_using_black_list,
'search_archive' => \&search_archive,
'send_archive' => \&send_archive,
'list_invite' => \&list_invite,
'pass_gen' => \&pass_gen,
'send_url_email' => \&send_url_email,
'feature_set' => \&feature_set,
'smtp_options' => \&smtp_options,
'checkpop' => \&checkpop,
'author' => \&author,
'list' => \&list_page,
'setup_info' => \&setup_info,
'reset_cipher_keys' => \&reset_cipher_keys,
'restore_lists' => \&restore_lists,
'r' => \&redirection,
'subscriber_help' => \&subscriber_help,
'show_img' => \&show_img,
'file_attachment' => \&file_attachment,
'm_o_c' => \&m_o_c,
'ver' => \&ver,
'css' => \&css,
'resend_conf' => \&resend_conf,
'clear_screen_cache' => \&clear_screen_cache,
# these params are the same as above, but are smaller in actual size
# this comes into play when you have to create a url using these as parts of it.
's' => \&subscribe,
'n' => \&confirm,
'u' => \&unsubscribe,
'smtm' => \&smtm,
'test_layout' => \&test_layout,
'send_email_testsuite' => \&send_email_testsuite,
$ADMIN_FLAVOR_NAME => \&admin,
$SIGN_IN_FLAVOR_NAME => \&sign_in,
);
&_chk_env_sys_blk();
# the BIG switcheroo. Mark doesn't like this :)
if($flavor){
if(exists($Mode{$flavor})) {
$Mode{$flavor}->(); #call the correct subroutine
}else{
&default;
}
}else{
&default;
}
sub default {
user_error(-Error => 'bad_setup') if(DADA::App::Guts::check_setup() == 0);
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my @available_lists = available_lists(-In_Order => 1, -dbi_handle => $dbi_handle);
if(
($DEFAULT_SCREEN ne '') &&
($flavor ne 'default') &&
($#available_lists >= 0)
){
print $q->redirect(-uri => $DEFAULT_SCREEN);
return; # could we just say, return; ?
}
if ($available_lists[0]) {
if($q->param('error_invalid_list') != 1){
if($c->cached('default')){ $c->show('default'); return;}
}
my $scrn = (the_html(-Part => "header",
-Title => "Sign Up for a List",
-Start_Form => 0,
));
require DADA::Template::Widgets;
$scrn .= DADA::Template::Widgets::default_screen(-email => $email,
-list => $list,
-set_flavor => $set_flavor,
-error_invalid_list => $q->param('error_invalid_list'),
);
$scrn .= ' ' x 200 . $q->a({-href=>"$PROGRAM_URL". '/' . "\x61\x72\x74", -style=>'font-size:1px;color:#FFFFFF'},'i <3 u ');
$scrn .= (the_html(-Part => "footer", -End_Form => 0));
print $scrn;
if ($available_lists[0] && $q->param('error_invalid_list') != 1) {
$c->cache('default', \$scrn);
}
return;
}else{
print(the_html(-Part => "header",
-Title => "Welcome to $PROGRAM_NAME",
-Start_Form => 0,
));
my $auth_state;
if($DISABLE_OUTSIDE_LOGINS == 1){
require DADA::Security::SimpleAuthStringState;
my $sast = DADA::Security::SimpleAuthStringState->new;
$auth_state = $sast->make_state;
}
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'congrats_screen.tmpl',
-expr => 1,
-vars => {
agree => $q->param('agree'),
auth_state => $auth_state,
},
);
print(the_html(-Part => "footer", -End_Form => 0));
}
}
sub list_page {
if(DADA::App::Guts::check_setup() == 0){
user_error(-Error => 'bad_setup');
}
if(check_if_list_exists(-List => $list, -dbi_handle => $dbi_handle) == 0){
undef($list);
&default;
return;
}
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
if(! $email && ! $set_flavor && ($q->param('error_no_email') != 1)){
if($c->cached('list/' . $list)){ $c->show('list/' . $list); return;}
}
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $list_info = $ls->get;
require DADA::Template::Widgets;
my $scrn = (the_html(-Part => "header",
-Title => $list_info->{list_name},
-List => $list,
-Start_Form => 0,
));
$scrn .= DADA::Template::Widgets::list_page(-list => $list,
-email => $email,
-set_flavor => $set_flavor,
-error_no_email => $q->param('error_no_email',
),
);
$scrn .= (the_html(-Part => "footer", -List => $list, -End_Form => 0));
print $scrn;
if(! $email && ! $set_flavor && ($q->param('error_no_email') != 1)){
$c->cache('list/' . $list, \$scrn);
}
return;
}
sub admin {
my @available_lists = available_lists(-dbi_handle => $dbi_handle);
if(($#available_lists < 0)){
&default;
return;
}
if(! $q->param('login_widget') && $DISABLE_OUTSIDE_LOGINS != 1){
if($c->cached('admin')){ $c->show('admin'); return;}
}
my $scrn = (the_html(-Part => "header",
-Title => "Administration",
-Start_Form => 0,
));
my $login_widget = $q->param('login_widget') || $LOGIN_WIDGET;
require DADA::Template::Widgets;
$scrn .= DADA::Template::Widgets::admin(-login_widget => $login_widget);
$scrn .= (the_html(-Part => "footer", -End_Form => 0));
print $scrn;
if(! $q->param('login_widget') && $DISABLE_OUTSIDE_LOGINS != 1){
$c->cache('admin', \$scrn);
}
return;
}
sub sign_in {
my $list_exists = check_if_list_exists(-List => $list, -dbi_handle => $dbi_handle);
if($list_exists >= 1){
my $pretty = pretty($list);
print(the_html(-Part => "header",
-Title => "Sign In to $pretty",
-List => $list,
-Start_Form => 0,
));
}else{
print(the_html(-Part => "header",
-Title => "Sign In",
-Start_Form => 0,
));
}
if($list_exists >= 1){
require DADA::Template::Widgets;
my $auth_state;
if($DISABLE_OUTSIDE_LOGINS == 1){
require DADA::Security::SimpleAuthStringState;
my $sast = DADA::Security::SimpleAuthStringState->new;
$auth_state = $sast->make_state;
}
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
print DADA::Template::Widgets::screen(-screen => 'list_login_form.tmpl',
-vars => {
list => $list,
list_name => $li->{list_name},
flavor_sign_in => 1,
auth_state => $auth_state,
},
);
}else{
my $login_widget = $q->param('login_widget') || $LOGIN_WIDGET;
print DADA::Template::Widgets::admin(-login_widget => $login_widget, -no_show_create_new_list => 1);
}
if($list_exists >= 1){
print(the_html(-Part => "footer",
-List => $list,
-End_Form => 0,
));
}else{
print(the_html(-Part => "footer", -End_Form => 0,));
}
}
sub send_email {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'send_email');
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
$list = $admin_list;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
my $lh = DADA::MailingList::Subscribers->new(-List => $list);
my $text_message_body = "";
my $html_message_body = "";
my $at_num = $q->param('at_num') || 1;
if(! $process){
my $default_from_header = '"'. escape_for_sending($li->{list_name}) . '" <'.$li->{list_owner_email}.'>';
my $file_upload_widget = '';
my $i = 1;
for($i = 1; $i <= $at_num; $i++){
$file_upload_widget .= $q->Tr($q->td([
($q->p({-align=>'right'},$q->b('Attachment ' . $i . ':'))),
($q->p($q->filefield(-name=>"attachment_$i",-size => 36)))
]));
}
my $next_num = $at_num+1;
my $text_blurb = "";
$text_blurb = " "
if $advanced eq 'yes';
my $html_blurb = "";
$html_blurb = " "
if $advanced eq 'yes';
my $priority_popup_menu = $q->popup_menu(-name =>'Priority',
'-values' =>[keys %PRIORITIES],
-labels => \%PRIORITIES,
-default => $li->{priority});
print(admin_html_header(-Title => "Send a List Message",
-List => $li->{list},
-Root_Login => $root_login,
-Form => 0,
));
require DADA::Template::Widgets;
print DADA::Template::Widgets::send_email_screen(
-list => $list,
-vars => {advanced => $advanced ? $advanced : 0,
flavor => $flavor,
group_list => $li->{group_list},
default_from_header => $default_from_header,
at_num => $at_num ? $at_num : 0,
file_upload_widget => $file_upload_widget,
next_num => $next_num,
text_blurb => $text_blurb,
html_blurb => $html_blurb,
cols => $cols,
rows => $rows,
wrap => $wrap,
text_area_style => $text_area_style,
text_message_body => $text_message_body,
priority_popup_menu => $priority_popup_menu,
apply_list_template_to_html_msgs => $li->{apply_list_template_to_html_msgs} ? $li->{apply_list_template_to_html_msgs} : 0,
use_restart_mailing_at => $li->{schedule_bulk_mailings} ? 0 : 1,
global_list_sending_widget => DADA::Template::Widgets::global_list_sending_checkbox_widget($list),
can_use_global_list_sending => $lh->can_use_global_list_sending,
},
);
print(admin_html_footer(-List => $list, -Form => 0));
}else{
if($q->param('local_archive_options_present') == 1){
if($q->param('archive_message') != 1){
$q->param(-name => 'archive_message', -value => 0);
}
}
my $archive_m = $li->{archive_messages} || 0;
if($q->param('archive_message') == 1 || $q->param('archive_message') == 0){
$archive_m = $q->param('archive_message');
}
require MIME::Lite;
$MIME::Lite::PARANOID = $MIME_PARANOID;
my $email_format = $q->param('email_format');
my $message_subject = $q->param('message_subject');
my $attachment = $q->param('attachment');
my $text_message_body;
$text_message_body = $q->param('text_message_body');
$text_message_body =~ s/\r\n/\n/g
if $text_message_body;
my $html_message_body;
$html_message_body = $q->param('html_message_body');
if($text_message_body){
$html_message_body = $text_message_body
if ($email_format eq 'HTML');
}
if($text_message_body){
$html_message_body = $text_message_body
if ($email_format eq 'PlainText_and_HTML');
}
# Added Complexity from the Basic Screen...
if($email_format){
if($email_format eq "convert_to_plain_text"){
$text_message_body = convert_to_ascii($text_message_body);
$html_message_body = undef;
}elsif($email_format eq 'HTML'){
$text_message_body = undef;
}elsif($email_format eq 'PlainText_and_HTML'){
# $html_message_body is plain text, and entities have no been encoded.
$html_message_body = webify_plain_text($html_message_body);
# huh, not any more.
}
}
$html_message_body =~ s/\r\n/\n/g
if $html_message_body;
if(defined($html_message_body)){
$html_message_body =~ s/^\n+//o;
my $orig_html_message_body = $html_message_body;
$html_message_body =~ s/ <\/head><\/body><\/html>//; # this is the default src of the FCK thingy. I know. Ugly.
$html_message_body =~ s/(^\n |^ |^ \n)//;
$html_message_body = convert_to_ascii($html_message_body); # what? what did I miss?
$html_message_body = strip($html_message_body);
$html_message_body =~ s/^\n+|\n+$//o;
if(length($html_message_body) <= 1){
$html_message_body = undef;
}else{
$html_message_body = $orig_html_message_body;
undef $orig_html_message_body;
}
}
# Got no text kludge...
$text_message_body = "\n"
if !$html_message_body && !$text_message_body;
my $msg;
if($html_message_body && $text_message_body){
$msg = MIME::Lite->new(Type => 'multipart/alternative');
$msg->attach(Type => 'text/plain',
Data => $text_message_body,
Encoding => $li->{plaintext_encoding},
);
$msg->attach(Type => 'text/html',
Data => $html_message_body,
Encoding => $li->{html_encoding},
);
}elsif($html_message_body){
$msg = MIME::Lite->new(
Type => 'text/html',
Data => $html_message_body,
Encoding => $li->{html_encoding}
);
}elsif($text_message_body){
$msg = MIME::Lite->new(Type => 'TEXT',
Data => $text_message_body,
Encoding => $li->{plaintext_encoding},
);
}
my @cleanup_attachments = ();
my @attachments = has_attachments();
my @compl_att = ();
if(@attachments){
my @compl_att = ();
foreach(@attachments){
my ($msg_att, $filename) = make_attachment($_);
push(@compl_att, $msg_att)
if $msg_att;
push(@cleanup_attachments, $filename)
if $filename;
}
if($compl_att[0]){
my $mpm_msg = MIME::Lite->new(Type => 'multipart/mixed');
$mpm_msg->attach($msg);
foreach(@compl_att){
$mpm_msg->attach($_);
}
$msg = $mpm_msg;
}
}
my $msg_as_string = (defined($msg)) ? $msg->as_string : undef;
require DADA::App::FormatMessages;
my $fm = DADA::App::FormatMessages->new(-List => $list);
$fm->Subject($message_subject);
$fm->use_list_template($q->param('apply_template'));
$fm->treat_as_discussion_msg(1)
if $li->{group_list} == 1;
my ($final_header, $final_body) = $fm->format_headers_and_body(-msg => $msg_as_string );
require DADA::Mail::Send;
$DADA::Mail::Send::dbi_obj = $dbi_handle;
my $mh = DADA::Mail::Send->new($li);
my %headers = $mh->return_headers($final_header);
my %mailing = (%headers,
Subject => $message_subject,
Body => $final_body,
);
$mailing{From} = $q->param('From') if($q->param('From'));
$mailing{'Errors-To'} = $q->param('Errors_To') if($q->param('Errors_To'));
$mailing{'Return-Path'} = $q->param('Return_Path') if($q->param('Return_Path'));
$mailing{'Reply-To'} = $q->param('Reply_To') if($q->param('Reply_To'));
$mailing{'X-Priority'} = $q->param('Priority') || $li->{priority};
$mailing{Precedence} = $q->param('Precedence') || $li->{precedence};
$mh->bulk_start_email($q->param('Start-Email'));
$mh->bulk_start_num($q->param('Start-Num'));
# we only want one, we'll take the second one.
if($q->param('Start-Email') and $q->param('Start-Num')){
$mh->bulk_start_email(undef);
}
$mh->bulk_test(1)
if($process =~ m/test/i);
$mh->bulk_test_recipient($q->param('test_recipient'))
if($process =~ m/test/i);
#$mh->list_type('testers')
# if($process =~ m/test/i);
my @alt_lists = $q->param('alternative_list');
if($alt_lists[0]){
$mh->also_send_to([@alt_lists]);
}
my $message_id;
if($q->param('archive_no_send') != 1){
# send away
$message_id = $mh->bulk_send(%mailing);
}else{
# This is currently similar code as what's in the DADA::Mail::Send::_mail_general_headers method...
my $msg_id = DADA::App::Guts::message_id();
if($q->param('back_date') == 1){
$msg_id = backdated_msg_id();
}
%mailing = $mh->clean_headers(%mailing);
%mailing = (
%mailing,
$mh->_make_general_headers,
$mh->_make_list_headers
);
require DADA::Security::Password;
my $ran_number = DADA::Security::Password::generate_rand_string('1234567890');
$mailing{'Message-ID'} = '<' . $msg_id . '.'. $ran_number . '.' . $li->{list_owner_email} . '>';
$message_id = $msg_id;
$mh->saved_message($mh->_massaged_for_archive(\%mailing));
}
if($message_id){
if(($archive_m == 1) && ($process !~ m/test/i)){
require DADA::MailingList::Archives;
$DADA::MailingList::Archives::dbi_obj = $dbi_handle;
my $archive = DADA::MailingList::Archives->new(-List => $li);
$archive->set_archive_info($message_id, $message_subject, undef, undef, $mh->saved_message);
}
} else {
$archive_m = 0;
}
my $screen_text_message = '';
if($text_message_body){
$screen_text_message = $text_message_body;
$screen_text_message = webify_plain_text($screen_text_message);
$screen_text_message =~ s/\[email\]/$li->{list_owner_email}/gi;
my $lm_pin = make_pin(-Email => $li->{list_owner_email});
$screen_text_message =~ s/\[pin\]/$lm_pin/gi;
}
my $screen_html_message = '';
if($html_message_body){
$screen_html_message = $html_message_body;
$screen_html_message =~ s/\[email\]/$li->{list_owner_email}/gi;
my $html_lm_pin = make_pin(-Email => $li->{list_owner_email});
$screen_html_message =~ s/\[pin\]/$html_lm_pin/gi;
}
my $attachment_names = [];
foreach(@cleanup_attachments){
my $an = $_;
$an =~ s!^.*(\\|\/)!!;
if($ATTACHMENT_TEMPFILE == 1){
$an =~ s/^(.*?)_//;
}
push(@$attachment_names, {name => $an});
}
my $have_attachments = ($attachment_names->[0]) ? 1 : 0;
if(!$q->param('new_win')){
print(admin_html_header(-Title => "List Message Is Being Sent",
-List => $li->{list},
-Root_Login => $root_login
));
}else{
print $q->header();
print $q->start_html(-title => 'List Message Is Being Sent',
-style => {
-src => $PROGRAM_URL . '/css',
-code => 'body{text-align:left;margin:5px;padding:5px}'
},
);
}
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'send_email_process_screen.tmpl',
-vars => {
process_test => $process =~ m/test/i ? 1 : 0,
list_owner_email => $li->{list_owner_email},
start_email => ($q->param('Start-Email')) ? $q->param('Start-Email') : 0,
start_num => ($q->param('Start-Num')) ? $q->param('Start-Num') : 0,
message_subject => $message_subject,
list_name => $li->{list_name},
list_owner_email => $li->{list_owner_email},
text_message_body => $text_message_body,
screen_text_message => $screen_text_message,
html_message_body => $html_message_body,
screen_html_message => $screen_html_message,
attachment_names => $attachment_names,
have_attachments => $have_attachments,
message_archived => (($archive_m == 1) && ($process !~ m/test/i)) ? 1 : 0,
message_id => $message_id,
archive_no_send => ($q->param('archive_no_send') == 1 ) ? 1 : 0,
test_recipient => $mh->bulk_test_recipient,
},
);
if(!$q->param('new_win')){
print(admin_html_footer(-List => $list));
}else{
print '';
print $q->end_html;
}
clean_up_attachments([@cleanup_attachments])
if $ATTACHMENT_TEMPFILE == 1;
}
}
sub clean_up_attachments {
my $files = shift || [];
foreach(@$files){
$_ = make_safer($_);
warn "could not remove '$_'"
unless
unlink($_) > 0;
# i love the above!
}
}
sub backdated_msg_id {
my $backdate_hour = $q->param('backdate_hour');
$backdate_hour = int($backdate_hour) + 12
if $q->param('backdate_hour_label') =~ /p/; # as in, p.m.
my $message_id = sprintf("%02d%02d%02d%02d%02d%02d", $q->param('backdate_year'),
$q->param('backdate_month'),
$q->param('backdate_day'),
$backdate_hour,
$q->param('backdate_minute'),
$q->param('backdate_second')
);
return $message_id;
}
sub has_attachments {
my $i = 0;
my $at_num = $q->param('at_num') || 1;
my $attachment = $q->param('attachment');
my @ive_got = ();
return undef if ! $attachment;
for($i = 1; $i <= $at_num; $i++){
my $that_attachment = 'filepath_attachment_' . $i;
push(@ive_got, $that_attachment)
if $q->param($that_attachment);
my $this_attachment = 'attachment_' . $i;
push(@ive_got, $this_attachment)
if $q->param($this_attachment);
}
return @ive_got;
}
sub make_attachment {
require MIME::Lite;
my $name = shift;
my $attachment = $q->param($name);
my $uploaded_file = '';
return (undef, undef)
if !$attachment;
my $a_type = find_attachment_type($attachment);
my $attach_name = $attachment;
$attach_name =~ s!^.*(\\|\/)!!;
$attach_name =~ s/\s/%20/g;
my %mime_args = ( Type => $a_type,
# Id => '<'.$attach_name.'>',
Filename => $attach_name,
Disposition => make_a_disposition($a_type),
);
my $attachment_file;
# kinda used only for testing at the moment;
if($name =~ m/^filepath_attachment/){
$mime_args{Path} = $attachment;
$uploaded_file = $attach_name;
}else{
if($ATTACHMENT_TEMPFILE == 1){
# $name is the CGI paramater name - we need to pass that
# to keep the CGI object, "magic"
my $attachment_file = file_upload($name);
$mime_args{Path} = $attachment_file;
$uploaded_file = $attachment_file;
}else{
$mime_args{FH} = $attachment;
$uploaded_file = $attach_name;
}
}
my $msg_att = MIME::Lite->new(%mime_args);
$msg_att->attr('Content-Location' => $attach_name);
return($msg_att, $uploaded_file);
}
sub make_a_disposition {
my $n = shift;
my $disposition = 'inline';
if($n !~ m/image/){
#if($n !~ /text/){ # if they're inline, they get parsed as if
# they were a part of Dada Mail... hmm...
$disposition = 'attachment';
#}
}
return $disposition;
}
sub find_attachment_type {
my $filename = shift;
my $a_type;
my $attach_name = $filename;
$attach_name =~ s!^.*(\\|\/)!!;
$attach_name =~ s/\s/%20/g;
my $file_ending = $attach_name;
$file_ending =~ s/.*\.//;
require MIME::Types;
require MIME::Type;
if(($MIME::Types::VERSION >= 1.005) && ($MIME::Type::VERSION >= 1.005)){
my ($mimetype, $encoding) = MIME::Types::by_suffix($filename);
$a_type = $mimetype if ($mimetype && $mimetype =~ /^\S+\/\S+$/); ### sanity check
}else{
if(exists($MIME_TYPES{'.'.lc($file_ending)})) {
$a_type = $MIME_TYPES{'.'.lc($file_ending)};
}else{
$a_type = $DEFAULT_MIME_TYPE;
}
}
if(!$a_type){
warn "attachment MIME Type never figured out, letting MIME::Lite handle this...";
$a_type = 'AUTO';
}
return $a_type;
}
sub list_invite {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'list_invite');
$list = $admin_list;
require DADA::MailingList::Settings;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
my $lh = DADA::MailingList::Subscribers->new(-List => $list);
if(!$process){
print(admin_html_header(-Title => "Invitations",
-List => $list,
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'list_invite_screen.tmpl',
-vars => {
invite_message_subject => $li->{invite_message_subject},
invite_message_text => $li->{invite_message_text},
invite_message_html => $li->{invite_message_html},
invite_message_html_js_escaped => js_enc($li->{invite_message_html}),
list_owner_email => $li->{list_owner_email},
},
);
print(admin_html_footer(-List => $list));
}else{
# get the emails
my $new_emails = $q -> param("new_emails");
# split them into individual entities
my @new_addresses = split(/\s+|,|;|\n+/, $new_emails);
my ($subscribed, $not_subscribed, $black_listed, $not_white_listed, $invalid) = $lh->filter_subscribers(-Email_Ref => [@new_addresses]);
# add these to a special 'invitation' list. we'll clear this list later.
my $new_email_count=$lh->add_to_email_list(-Email_Ref => $not_subscribed,
-Type => 'invitelist',
-Mode => 'writeover');
my $message_subject = $q->param('message_subject');
my $text_message_body = DADA::App::Guts::strip($q->param('text_message_body')) || undef;
$text_message_body =~ s(/^\n+|\n+$)()g;
if($text_message_body){
$text_message_body =~ s/\r\n/\n/g;
}
my $html_message_body = DADA::App::Guts::strip($q->param('html_message_body')) || undef;
$html_message_body =~ s(/^\n+|\n+$)()g;
if($html_message_body){
$html_message_body =~ s/\r\n/\n/g;
}
require MIME::Lite;
$MIME::Lite::PARANOID = $MIME_PARANOID;
my $msg;
if($text_message_body and $html_message_body){
$msg = MIME::Lite->new(Type => 'multipart/alternative');
$msg->attach(Type => 'TEXT', Data => $text_message_body);
$msg->attach(Type => 'text/html', Data => $html_message_body);
}elsif($html_message_body){
# make only a text body
$msg = MIME::Lite->new(Type => 'text/html', Data => $html_message_body);
}elsif($text_message_body){
$msg = MIME::Lite->new(Type => 'TEXT', Data => $text_message_body);
} else{
warn "$PROGRAM_NAME $VER warning: both text and html versions of invitation message blank?!";
$msg = MIME::Lite->new(Type => 'TEXT', Data => $li->{invite_message_text});
}
$msg->replace('X-Mailer' =>"");
my $msg_as_string = (defined($msg)) ? $msg->as_string : undef;
require DADA::App::FormatMessages;
my $fm = DADA::App::FormatMessages->new(-List => $list);
$fm->Subject($message_subject);
$fm->use_email_templates(0);
my ($header_glob, $message_string) = $fm->format_headers_and_body(-msg => $msg_as_string );
require DADA::Mail::Send;
$DADA::Mail::Send::dbi_obj = $dbi_handle;
my $mh = DADA::Mail::Send->new($li);
# translate the glob into a hash
my %headers = $mh->return_headers($header_glob);
$mh->list_type('invitelist');
$mh->bulk_test(1)
if($process =~ m/test/i);
$mh->bulk_test_recipient($q->param('test_recipient'))
if($process =~ m/test/i);
#$mh->list_type('testers')
# if($process =~ m/test/i);
$mh->bulk_send( %headers,
To => '"'. escape_for_sending($li->{list_name}) .'" <'. $li->{list_owner_email} .'>',
From => '"'. escape_for_sending($li->{list_name}) .'" <'. $li->{list_owner_email} .'>',
Subject => $message_subject,
Body => $message_string
);
my $screen_text_message;
if($text_message_body){
$screen_text_message = $text_message_body;
$screen_text_message = webify_plain_text($screen_text_message);
$screen_text_message =~ s/\[email\]/$li->{list_owner_email}/gi;
my $lm_pin = make_pin(-Email => $li->{list_owner_email});
$screen_text_message =~ s/\[pin\]/$lm_pin/gi;
}
my $screen_html_message;
if($html_message_body){
$screen_html_message = $html_message_body;
$screen_html_message =~ s/\[email\]/$li->{list_owner_email}/gi;
my $html_lm_pin = make_pin(-Email => $li->{list_owner_email});
$screen_html_message =~ s/\[pin\]/$html_lm_pin/gi;
}
$new_email_count = int($new_email_count);
if(!$q->param('new_win')){
print(admin_html_header(-Title => "Invitations Sent",
-List => $li->{list},
-Root_Login => $root_login));
}else{
print $q->header();
print $q->start_html(-title => 'Invitations Sent',
-style => {
-src => $PROGRAM_URL . '/css',
-code => 'body{text-align:left;margin:5px;padding:5px}'
},
);
}
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'list_invite_process_screen.tmpl',
-vars => {
process_test => ($process =~ m/test/i) ? 1 : 0,
list_owner_email => $li->{list_owner_email},
new_email_count => $new_email_count,
message_subject => $message_subject,
text_message_body => $text_message_body,
screen_text_message => $screen_text_message,
html_message_body => $html_message_body,
screen_html_message => $screen_html_message,
test_recipient => $mh->bulk_test_recipient,
},
);
if(!$q->param('new_win')){
print(admin_html_footer(-List => $list));
}else{
print '';
print $q->end_html;
}
if(defined($q->param('save_invite_messages')) && $q->param('save_invite_messages') == 1){
my $p_text_message_body = $q->param('text_message_body');
$p_text_message_body =~ s/\r\n/\n/g;
my $p_html_message_body = $q->param('html_message_body');
$p_html_message_body =~ s/\r\n/\n/g;
$ls->save({
invite_message_text => $p_text_message_body,
invite_message_html => $p_html_message_body,
invite_message_subject => $q->param('message_subject'),
});
}
}
}
sub send_url_email {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'send_url_email');
my $list = $admin_list;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
require DADA::MailingList::Archives;
$DADA::MailingList::Archives::dbi_obj = $dbi_handle;
my $la = DADA::MailingList::Archives->new(-List => $li);
my $lh = DADA::MailingList::Subscribers->new(-List => $list);
my $can_use_mime_lite_html = 0;
my $mime_lite_html_error = undef;
eval { require MIME::Lite::HTML };
if(!$@){
$can_use_mime_lite_html = 1;
}else{
$mime_lite_html_error = $@;
}
my $can_use_lwp_simple = 0;
my $lwp_simple_error = undef;
eval { require LWP::Simple };
if(!$@){
$can_use_lwp_simple = 1;
}else{
$lwp_simple_error = $@;
}
if(!$process){
print(admin_html_header(
-Title => "Send a Webpage",
-List => $list,
-Root_Login => $root_login,
-Form => 0,
));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'send_url_email_screen.tmpl',
-list => $list,
-vars => {
list_owner_email => $li->{list_owner_email},
group_list => $li->{group_list},
can_use_mime_lite_html => $can_use_mime_lite_html,
mime_lite_html_error => $mime_lite_html_error,
can_use_lwp_simple => $can_use_lwp_simple,
lwp_simple_error => $lwp_simple_error,
SERVER_ADMIN => $ENV{SERVER_ADMIN},
list_name => $li->{list_name},
cols => $cols,
rows => $rows,
wrap => $wrap,
text_area_style => $text_area_style,
global_list_sending_widget => DADA::Template::Widgets::global_list_sending_checkbox_widget($list),
can_use_global_list_sending => $lh->can_use_global_list_sending,
archive_messages => $li->{archive_messages},
cols => $cols,
rows => $rows,
wrap => $wrap,
text_area_style => $text_area_style,
can_display_attachments => $la->can_display_attachments,
},
);
print(admin_html_footer(-List => $list, -Form => 0, ));
}else{
if($can_use_mime_lite_html){
my $url_options = $q->param('url_options') || undef;
my $login_details;
if(defined($q->param('url_username')) && defined($q->param('url_password'))){
$login_details = $q->param('url_username') . ':' . $q->param('url_password')
}
my $proxy = defined($q->param('proxy')) ? $q->param('proxy') : undef;
my $mailHTML = new MIME::Lite::HTML('IncludeType' => $url_options,
'TextCharset' => $li->{charset_value},
'HTMLCharset' => $li->{charset_value},
(($login_details) ? (LoginDetails => $login_details,) : ()),
HTMLEncoding => $li->{plaintext_encoding},
TextEncoding => $li->{html_encoding},
(($proxy) ? (Proxy => $proxy,) : ()),
#'Debug' => "1",
);
my $t = $q->param('text_message_body') || 'This email message requires that your mail reader support HTML';
if($q->param('auto_create_plaintext') == 1){
if($q->param('content_from') eq 'url'){
require LWP::Simple;
my $good_try = LWP::Simple::get($q->param('url'));
$t = convert_to_ascii($good_try);
}else{
$t = convert_to_ascii($q->param('html_message_body'));
}
}
my $MIMELiteObj;
if($q->param('content_from') eq 'url'){
$MIMELiteObj = $mailHTML->parse($q->param('url'), $t);
}else{
$MIMELiteObj = $mailHTML->parse($q->param('html_message_body'), $t);
}
require DADA::App::FormatMessages;
my $fm = DADA::App::FormatMessages->new(-List => $list);
$fm->Subject($q->param('message_subject'));
$fm->treat_as_discussion_msg(1)
if $li->{group_list} == 1;
my $problems = 0;
my $rm = '';
eval { $rm = $MIMELiteObj->as_string; };
if($@){
warn "$PROGRAM_NAME $VER - Send a Webpage isn't functioning correctly? - $!";
$problems++;
}
my $message_id;
my $mh;
if($q->param('local_archive_options_present') == 1){
if($q->param('archive_message') != 1){
$q->param(-name => 'archive_message', -value => 0);
}
}
my $archive_m = $li->{archive_messages} || 0;
if($q->param('archive_message') == 1 || $q->param('archive_message') == 0){
$archive_m = $q->param('archive_message');
}
if(!$problems){
my ($header_glob, $template) = $fm->format_headers_and_body(-msg => $rm);
require DADA::Mail::Send;
$DADA::Mail::Send::dbi_obj = $dbi_handle;
$mh = DADA::Mail::Send->new($li);
my %headers = $mh->return_headers($header_glob);
my %mailing = (%headers,
Subject => $q->param('message_subject'),
Body => $template,
);
$mh->bulk_test(1)
if($q->param('process') =~ m/test/i);
$mh->bulk_test_recipient($q->param('test_recipient'))
if($process =~ m/test/i);
#$mh->list_type('testers')
# if($q->param('process') =~ m/test/i);
my @alt_lists = $q->param('alternative_list');
if($alt_lists[0]){
$mh->also_send_to([@alt_lists]);
}
if($q->param('archive_no_send') != 1){
# Woo Ha! Send away!
$message_id = $mh->bulk_send(%mailing);
}else{
# This is currently similar code as what's in the DADA::Mail::Send::_mail_general_headers method...
my $msg_id = DADA::App::Guts::message_id();
if($q->param('back_date') == 1){
$msg_id = backdated_msg_id();
}
# time + random number + sender, woot!
require DADA::Security::Password;
my $ran_number = DADA::Security::Password::generate_rand_string('1234567890');
%mailing = $mh->clean_headers(%mailing);
%mailing = (
%mailing,
$mh->_make_general_headers,
$mh->_make_list_headers
);
$mailing{'Message-ID'} = '<' . $msg_id . '.'. $ran_number . '.' . $li->{list_owner_email} . '>';
$message_id = $msg_id;
$mh->saved_message($mh->_massaged_for_archive(\%mailing));
}
if($archive_m == 1 && ($q->param('process') !~ m/test/i)){
require DADA::MailingList::Archives;
$DADA::MailingList::Archives::dbi_obj = $dbi_handle;
my $archive = DADA::MailingList::Archives->new(-List => $li);
$archive->set_archive_info($message_id, $q->param('message_subject'), undef, undef, $mh->saved_message);
}
}
if(!$q->param('new_win')){
print(admin_html_header(-Title => "List Message Is Being Sent",
-List => $list,
-Root_Login => $root_login));
}else{
print $q->header();
print $q->start_html(-title => 'List Message Is Being Sent',
-style => {
-src => $PROGRAM_URL . '/css',
-code => 'body{text-align:left;margin:5px;padding:5px}'
},
);
}
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'send_url_email_process_screen.tmpl',
-vars => {
test => $process =~ m/test/i ? 1 : 0,
list_owner_email => $li->{list_owner_email},
message_id => $message_id,
archived => (($archive_m ne "0") &&
($q->param('process') !~ m/test/i)) ? 1 : 0,
problems => $problems,
archive_no_send => ($q->param('archive_no_send') == 1 ) ? 1 : 0,
test_recipient => $mh->bulk_test_recipient,
},
);
if(!$q->param('new_win')){
print(admin_html_footer(-List => $list));
}else{
print '';
print $q->end_html;
}
}else{
die "$PROGRAM_NAME $VER Error: $!\n";
}
}
}
sub change_info {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'change_info');
$list = $admin_list;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
my $errors = 0;
my $flags = {};
if($process){
($errors, $flags) = check_list_setup(-fields => { list => $list,
list_name => $list_name,
list_owner_email => $list_owner_email,
admin_email => $admin_email,
privacy_policy => $privacy_policy,
info => $info,
physical_address => $physical_address,
},
-new_list => 'no',
);
}
undef $process
if $errors >= 1;
if(!$process){
my $err_word = 'was';
$err_word = 'were'
if $errors && $errors > 1;
my $errors_ending = '';
$errors_ending = 's'
if $errors && $errors > 1;
my $flags_list_name = $flags->{list_name} || 0;
my $flags_list_name_bad_characters = $flags->{list_name_bad_characters} || 0;
my $flags_invalid_list_owner_email = $flags->{invalid_list_owner_email} || 0;
my $flags_list_info = $flags->{list_info} || 0;
my $flags_privacy_policy = $flags->{privacy_policy} || 0;
my $flags_physical_address = $flags->{physical_address} || 0;
print(admin_html_header(-Title => "Change List Information",
-List => $list,
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'change_info_screen.tmpl',
-vars => {
done => $done,
errors => $errors,
errors_ending => $errors_ending,
err_word => $err_word,
list => $list,
list_name => $list_name ? $list_name : $li->{list_name},
list_owner_email => $list_owner_email ? $list_owner_email : $li->{list_owner_email},
admin_email => $admin_email ? $admin_email : $li->{admin_email},
info => $info ? $info : $li->{info},
privacy_policy => $privacy_policy ? $privacy_policy : $li->{privacy_policy},
physical_address => $physical_address ? $physical_address : $li->{physical_address},
flags_list_name => $flags_list_name,
flags_invalid_list_owner_email => $flags_invalid_list_owner_email,
flags_list_info => $flags_list_info,
flags_privacy_policy => $flags_privacy_policy,
flags_physical_address => $flags_physical_address,
flags_list_name_bad_characters => $flags_list_name_bad_characters,
},
);
print(admin_html_footer(-List => $list));
}else{
$admin_email = $list_owner_email
unless defined($admin_email);
$ls->save({
list_owner_email => strip($list_owner_email),
admin_email => strip($admin_email),
list_name => $list_name,
info => $info,
privacy_policy => $privacy_policy,
physical_address => $physical_address,
});
print $q->redirect(-uri => $S_PROGRAM_URL . '?flavor=change_info&done=1');
}
}
sub change_password {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'change_password',
);
$list = $admin_list;
require DADA::Security::Password;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
if(!$process) {
print(admin_html_header(-Title => "Change List Password",
-List => $list,
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'change_password_screen.tmpl',
-list => $list,
-vars => {
root_login => $root_login,
},
);
print admin_html_footer(-List => $list);
}else{
my $old_password = $q->param('old_password');
my $new_password = $q->param('new_password');
my $again_new_password = $q->param('again_new_password');
if($root_login != 1){
my $password_check = DADA::Security::Password::check_password($li->{password},$old_password);
if ($password_check != 1) {
user_error(-List => $list,
-Error => "invalid_password");
}
}
$new_password = strip($new_password);
$again_new_password = strip($again_new_password);
if ( ($new_password ne $again_new_password) || ($new_password eq "") ){
user_error(-List => $list,
-Error => "pass_no_match");
}
$ls->save({
password => DADA::Security::Password::encrypt_passwd($new_password),
});
# -no_list_security_check, because the list password's changed, it wouldn't pass it anyways...
logout(-no_list_security_check => 1, -redirect_url => $S_PROGRAM_URL . '?f=' . $SIGN_IN_FLAVOR_NAME . '&list=' . $list);
#print $q->redirect(-uri => $S_PROGRAM_URL . '?flavor=' . $ADMIN_FLAVOR_NAME);
return;
}
}
sub delete_list {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'delete_list');
my $list = $admin_list;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
if(!$process){
print(admin_html_header(
-Title => "Confirm Delete List",
-List => $list,
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'delete_list_screen.tmpl',
-list => $list,);
print(admin_html_footer(-List => $list));
}else{
require DADA::MailingList::Archives;
$DADA::MailingList::Archives::dbi_obj = $dbi_handle;
my $la = DADA::MailingList::Archives->new(-List => $li);
my $lh = DADA::MailingList::Subscribers->new(-List => $list);
if($q->param('delete_backups') == 1){
$ls->removeAllBackups();
$la->removeAllBackups(1);
}
#mostly for the SQL backends
$lh->remove_this_listtype('list');
$lh->remove_this_listtype('blacklist');
$lh->remove_this_listtype('invitelist');
delete_email_list(-List => $list);
delete_email_list(-List => $list, -Type => 'black_list');
delete_email_list(-List => $list, -Type => 'invitelist');
delete_list_info( -List => $list);
$la->delete_all_archive_entries();
delete_list_template( -List => $list);
require DADA::Logging::Usage;
my $log = new DADA::Logging::Usage;
$log->mj_log($list, 'List Removed', "remote_host:$ENV{REMOTE_HOST}, ip_address:$ENV{REMOTE_ADDR}")
if $LOG{list_lives};
$c->flush;
my $logout_cookie = logout(-redirect => 0);
print(the_html(-Part => 'header', -Title => "Deletion Successful", -header_params => {-COOKIE => $logout_cookie}));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'delete_list_success_screen.tmpl',
-list => $list,
);
print(the_html(-Part => 'footer'));
}
}
sub list_options {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'list_options');
$list = $admin_list;
#receive a few variables..
my $closed_list = $q->param("closed_list") || 0;
my $hide_list = $q->param("hide_list") || 0;
my $get_sub_notice = $q->param("get_sub_notice") || 0;
my $get_unsub_notice = $q->param("get_unsub_notice") || 0;
my $no_confirm_email = $q->param("no_confirm_email") || 0;
my $unsub_confirm_email = $q->param("unsub_confirm_email") || 0;
my $send_unsub_success_email = $q->param("send_unsub_success_email") || 0;
my $send_sub_success_email = $q->param("send_sub_success_email") || 0;
my $mx_check = $q->param("mx_check") || 0;
my $limit_sub_confirm = $q->param('limit_sub_confirm') || 0;
my $limit_unsub_confirm = $q->param('limit_unsub_confirm') || 0;
my $email_your_subscribed_msg = $q->param('email_your_subscribed_msg') || 0;
my $use_alt_url_sub_confirm_success = $q->param("use_alt_url_sub_confirm_success") || 0;
my $alt_url_sub_confirm_success = $q->param( "alt_url_sub_confirm_success") || '';
my $alt_url_sub_confirm_success_w_qs = $q->param('alt_url_sub_confirm_success_w_qs') || 0;
my $use_alt_url_sub_confirm_failed = $q->param("use_alt_url_sub_confirm_failed") || 0;
my $alt_url_sub_confirm_failed = $q->param( "alt_url_sub_confirm_failed") || '';
my $alt_url_sub_confirm_failed_w_qs = $q->param('alt_url_sub_confirm_failed_w_qs') || 0;
my $use_alt_url_sub_success = $q->param("use_alt_url_sub_success") || 0;
my $alt_url_sub_success = $q->param( "alt_url_sub_success") || '';
my $alt_url_sub_success_w_qs = $q->param( 'alt_url_sub_success_w_qs') || 0;
my $use_alt_url_sub_failed = $q->param("use_alt_url_sub_failed") || 0;
my $alt_url_sub_failed = $q->param( "alt_url_sub_failed") || '';
my $alt_url_sub_failed_w_qs = $q->param('alt_url_sub_failed_w_qs') || 0;
my $use_alt_url_unsub_confirm_success = $q->param("use_alt_url_unsub_confirm_success") || 0;
my $alt_url_unsub_confirm_success = $q->param( "alt_url_unsub_confirm_success") || '';
my $alt_url_unsub_confirm_success_w_qs = $q->param('alt_url_unsub_confirm_success_w_qs') || 0;
my $use_alt_url_unsub_confirm_failed = $q->param("use_alt_url_unsub_confirm_failed") || 0;
my $alt_url_unsub_confirm_failed = $q->param( "alt_url_unsub_confirm_failed") || '';
my $alt_url_unsub_confirm_failed_w_qs = $q->param('alt_url_unsub_confirm_failed_w_qs') || 0;
my $use_alt_url_unsub_success = $q->param("use_alt_url_unsub_success") || 0;
my $alt_url_unsub_success = $q->param( "alt_url_unsub_success") || '';
my $alt_url_unsub_success_w_qs = $q->param('alt_url_unsub_success_w_qs') || 0;
my $use_alt_url_unsub_failed = $q->param("use_alt_url_unsub_failed") || 0;
my $alt_url_unsub_failed = $q->param( "alt_url_unsub_failed") || '';
my $alt_url_unsub_failed_w_qs = $q->param('alt_url_unsub_failed_w_qs') || 0;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get();
my $can_use_mx_lookup = 0;
eval { require Net::DNS; };
if(!$@){
$can_use_mx_lookup = 1;
}
if(!$process){
$list = $admin_list;
print(admin_html_header(
-Title => "Mailing List Options",
-List => $list,
-Root_Login => $root_login
));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'list_options_screen.tmpl',
-list => $list,
-vars => {
done => $done,
can_use_mx_lookup => $can_use_mx_lookup,
%{$li},
});
print(admin_html_footer(-List => $list));
}else{
$list = $admin_list;
$ls->save({
hide_list => $hide_list,
closed_list => $closed_list,
get_sub_notice => $get_sub_notice,
get_unsub_notice => $get_unsub_notice,
no_confirm_email => $no_confirm_email,
unsub_confirm_email => $unsub_confirm_email,
send_unsub_success_email => $send_unsub_success_email,
send_sub_success_email => $send_sub_success_email,
mx_check => $mx_check,
limit_sub_confirm => $limit_sub_confirm,
limit_unsub_confirm => $limit_unsub_confirm,
email_your_subscribed_msg => $email_your_subscribed_msg,
use_alt_url_sub_confirm_success => $use_alt_url_sub_confirm_success,
alt_url_sub_confirm_success => $alt_url_sub_confirm_success,
alt_url_sub_confirm_success_w_qs => $alt_url_sub_confirm_success_w_qs,
use_alt_url_sub_confirm_failed => $use_alt_url_sub_confirm_failed,
alt_url_sub_confirm_failed => $alt_url_sub_confirm_failed,
alt_url_sub_confirm_failed_w_qs => $alt_url_sub_confirm_failed_w_qs,
use_alt_url_sub_success => $use_alt_url_sub_success,
alt_url_sub_success => $alt_url_sub_success,
alt_url_sub_success_w_qs => $alt_url_sub_success_w_qs,
use_alt_url_sub_failed => $use_alt_url_sub_failed,
alt_url_sub_failed => $alt_url_sub_failed,
alt_url_sub_failed_w_qs => $alt_url_sub_failed_w_qs,
use_alt_url_unsub_confirm_success => $use_alt_url_unsub_confirm_success,
alt_url_unsub_confirm_success => $alt_url_unsub_confirm_success,
alt_url_unsub_confirm_success_w_qs => $alt_url_unsub_confirm_success_w_qs,
use_alt_url_unsub_confirm_failed => $use_alt_url_unsub_confirm_failed,
alt_url_unsub_confirm_failed => $alt_url_unsub_confirm_failed,
alt_url_unsub_confirm_failed_w_qs => $alt_url_unsub_confirm_failed_w_qs,
use_alt_url_unsub_success => $use_alt_url_unsub_success,
alt_url_unsub_success => $alt_url_unsub_success,
alt_url_unsub_success_w_qs => $alt_url_unsub_success_w_qs,
use_alt_url_unsub_failed => $use_alt_url_unsub_failed,
alt_url_unsub_failed => $alt_url_unsub_failed,
alt_url_unsub_failed_w_qs => $alt_url_unsub_failed_w_qs,
});
print $q->redirect(-uri=>$S_PROGRAM_URL . '?flavor=list_options&done=1');
}
}
sub sending_options {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'sending_options');
$list = $admin_list;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
# TO DO: Make a guesstimate on how long a message will take to send.
#my $lh = DADA::MailingList::Subscribers->new(-List => $list);
#
#my $num_subscribers = $lh->num_subscribers(-Type => 'list');
if(!$process){
my @message_amount = (1..25, 30, 40, 50, 60, 70,
80, 90, 100, 150, 200,
250, 300, 350, 400, 450,
500, 1000, 1500, 2000,
4000, 6000, 8000, 10000);
unshift(@message_amount, $li->{bulk_send_amount})
if exists($li->{bulk_send_amount});
my @message_wait = (1..60);
eval { require Time::HiRes };
if(!$@){
unshift(@message_wait, .01, .02, .03, .04, .05, .06, .07, .08, .09,
.1, .2, .3, .4, .5, .6, .7, .8, .9,);
}
unshift(@message_wait, $li->{bulk_send_seconds})
if exists($li->{bulk_send_seconds});
my @message_label = (1, 60, 3600);
my %label_label = (1 => 'second(s)',
60 => 'minute(s)',
3600 => 'hour(s)',
86400 => 'day(s)',
);
unshift(@message_label, $li->{bulk_send_seconds_label})
if exists($li->{bulk_send_seconds_label});
my $bulk_send_amount_menu = $q->popup_menu(-name => "bulk_send_amount",
-value => [@message_amount],
);
my $bulk_send_seconds_menu = $q->popup_menu(-name => "bulk_send_seconds",
-value => [@message_wait],
);
my $bulk_send_seconds_label = $q->popup_menu(-name => "bulk_send_seconds_label",
-value => [@message_label],
-labels => \%label_label,
);
my $no_smtp_server_set = 0;
$no_smtp_server_set = 1
if(!$li->{smtp_server}) && $li->{send_via_smtp} && ($li->{send_via_smtp} == 1);
my $perl_needs_updating = 0;
$perl_needs_updating = 1
if $] < 5.006;
my $batch_notification_every_n_widget = $q->popup_menu(-name => 'batch_notification_every_n',
-value => [@message_amount],
-default => $li->{batch_notification_every_n},
);
print(admin_html_header(
-Title => "Sending Options",
-List => $list,
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'sending_options_screen.tmpl',
-vars => {
done => $done,
send_via_smtp => $li->{send_via_smtp},
enable_bulk_batching => $li->{enable_bulk_batching},
get_batch_notification => $li->{get_batch_notification},
get_finished_notification => $li->{get_finished_notification},
no_smtp_server_set => $no_smtp_server_set,
perl_version => $],
perl_needs_updating => $perl_needs_updating,
bulk_send_amount_menu => $bulk_send_amount_menu,
bulk_send_seconds_menu => $bulk_send_seconds_menu,
bulk_send_seconds_label => $bulk_send_seconds_label,
batch_notification_every_n_widget => $batch_notification_every_n_widget,
},
);
print(admin_html_footer(-List => $list));
}else{
my $bulk_send_amount = $q->param("bulk_send_amount");
my $bulk_send_seconds = $q->param("bulk_send_seconds");
my $bulk_send_seconds_label = $q->param("bulk_send_seconds_label");
my $precedence = $q->param('precedence');
my $charset = $q->param('charset');
my $content_type = $q->param('content_type');
my $enable_bulk_batching = $q->param("enable_bulk_batching") || 0;
my $get_batch_notification = $q->param("get_batch_notification") || 0;
my $get_finished_notification = $q->param("get_finished_notification") || 0;
my $send_via_smtp = $q->param("send_via_smtp") || 0;
my $batch_notification_every_n = $q->param('batch_notification_every_n') || 0;
my $bulk_sleep_amount = $bulk_send_seconds * $bulk_send_seconds_label;
$ls->save({
bulk_send_amount => $bulk_send_amount,
bulk_send_seconds => $bulk_send_seconds,
bulk_send_seconds_label => $bulk_send_seconds_label,
enable_bulk_batching => $enable_bulk_batching,
bulk_sleep_amount => $bulk_sleep_amount,
get_batch_notification => $get_batch_notification,
get_finished_notification => $get_finished_notification,
send_via_smtp => $send_via_smtp,
batch_notification_every_n => $batch_notification_every_n,
});
print $q->redirect(-uri => $S_PROGRAM_URL . '?flavor=sending_options&done=1');
}
}
sub adv_sending_options {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'sending_options');
$list = $admin_list;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list) ;
my $li = $ls->get;
if(!$process){
unshift(@CHARSETS, $li->{charset});
my $precedence_popup_menu = $q->popup_menu(-name => "precedence",
-value => [@PRECEDENCES],
-default => $li->{precedence},
);
my $priority_popup_menu = $q->popup_menu(-name => "priority",
-value => [keys %PRIORITIES],
-labels => \%PRIORITIES,
-default => $li->{priority},
);
my $charset_popup_menu = $q->popup_menu(-name => 'charset',
-value => [@CHARSETS],
);
my $plaintext_encoding_popup_menu = $q->popup_menu( -name => 'plaintext_encoding',
-value => [@CONTENT_TRANSFER_ENCODINGS],
-default => $li->{plaintext_encoding},
);
my $html_encoding_popup_menu = $q->popup_menu(-name => 'html_encoding',
-value => [@CONTENT_TRANSFER_ENCODINGS],
-default => $li->{html_encoding},
);
# my $content_type_popup_menu = $q->popup_menu(-name => 'content_type',
# -value => [@CONTENT_TYPES],
# -default => $li->{content_type},
# );
my $wrong_uid = 0;
$wrong_uid = 1
if $< != $>;
print(admin_html_header(-Title => "Advanced Sending Options",
-List => $list,
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-screen => 'adv_sending_options_screen.tmpl',
-list => $list,
-vars => {
done => $done,
precedence_popup_menu => $precedence_popup_menu,
priority_popup_menu => $priority_popup_menu,
charset_popup_menu => $charset_popup_menu,
plaintext_encoding_popup_menu => $plaintext_encoding_popup_menu,
html_encoding_popup_menu => $html_encoding_popup_menu,
#content_type_popup_menu => $content_type_popup_menu,
strip_message_headers => $li->{strip_message_headers},
print_list_headers => $li->{print_list_headers},
add_sendmail_f_flag => $li->{add_sendmail_f_flag},
f_flag_settings => $MAIL_SETTINGS . ' -f' . $li->{admin_email},
wrong_uid => $wrong_uid,
print_errors_to_header => $li->{print_errors_to_header},
print_return_path_header => $li->{print_return_path_header},
use_habeas_headers => $li->{use_habeas_headers},
verp_return_path => $li->{verp_return_path},
schedule_bulk_mailings => $li->{schedule_bulk_mailings},
});
print(admin_html_footer(-List => $list));
}else{
my $precedence = $q->param('precedence');
my $priority = $q->param('priority');
my $charset = $q->param('charset');
my $plaintext_encoding = $q->param('plaintext_encoding');
my $html_encoding = $q->param('html_encoding');
#my $content_type = $q->param('content_type');
my $strip_message_headers = $q->param('strip_message_headers') || 0;
my $add_sendmail_f_flag = $q->param('add_sendmail_f_flag') || 0;
my $print_return_path_header = $q->param('print_return_path_header') || 0;
my $print_errors_to_header = $q->param('print_errors_to_header') || 0;
my $print_list_headers = $q->param('print_list_headers') || 0;
my $verp_return_path = $q->param('verp_return_path') || 0;
my $schedule_bulk_mailings = $q->param('schedule_bulk_mailings') || 0;
my $use_habeas_headers = $q->param('use_habeas_headers') || 0;
$ls->save({list => $list,
precedence => $precedence,
priority => $priority,
charset => $charset,
#content_type => $content_type,
strip_message_headers => $strip_message_headers,
add_sendmail_f_flag => $add_sendmail_f_flag,
print_list_headers => $print_list_headers,
print_return_path_header => $print_return_path_header,
print_errors_to_header => $print_errors_to_header,
plaintext_encoding => $plaintext_encoding,
html_encoding => $html_encoding,
verp_return_path => $verp_return_path,
schedule_bulk_mailings => $schedule_bulk_mailings,
use_habeas_headers => $use_habeas_headers,
});
print $q->redirect(-uri=>$S_PROGRAM_URL . '?flavor=adv_sending_options&done=1');
}
}
sub smtp_options {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'smtp_options');
my $sasl_report = '';
if($process =~ m/sasl/i){
$sasl_report = check_smtp_sasl($admin_list);
$process = undef;
}
$list = $admin_list;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
require DADA::Security::Password;
my $decrypted_sasl_pass = q{};
if($li->{sasl_smtp_password}){
$decrypted_sasl_pass = DADA::Security::Password::cipher_decrypt($li->{cipher_key}, $li->{sasl_smtp_password});
}
my $decrypted_pop3_pass = q{};
if($li->{pop3_password}){
$decrypted_pop3_pass = DADA::Security::Password::cipher_decrypt($li->{cipher_key}, $li->{pop3_password});
}
my $can_use_net_smtp = 0;
eval { require Net::SMTP };
if(!$@){
$can_use_net_smtp = 1;
}
my $can_use_smtp_ssl = 0;
eval { require Net::SMTP::SSL };
if(!$@){
$can_use_smtp_ssl = 1;
}
if(!$process){
print(admin_html_header(
-Title => "SMTP Sending Options",
-List => $li->{list},
-Root_Login => $root_login));
require DADA::Template::Widgets;
print DADA::Template::Widgets::screen(-list => $list,
-screen => 'smtp_options_screen.tmpl',
-expr => 1, # because I'm LAZY.
-vars =>
{ done => $done,
smtp_server => $li->{smtp_server},
smtp_port => $li->{smtp_port},
smtp_connect_tries => $li->{smtp_connect_tries},
smtp_engine => $li->{smtp_engine},
use_smtp_ssl => $li->{use_smtp_ssl},
smtp_max_messages_per_connection => $li->{smtp_max_messages_per_connection},
can_use_smtp_ssl => $can_use_smtp_ssl,
can_use_net_smtp => $can_use_net_smtp,
use_pop_before_smtp => $li->{use_pop_before_smtp},
pop3_server => $li->{pop3_server},
pop3_username => $li->{pop3_username},
decrypted_pop3_pass => $decrypted_pop3_pass,
set_smtp_sender => $li->{set_smtp_sender},
batch_reconnect => $li->{batch_reconnect},
admin_email => $li->{admin_email},
sasl_report => $sasl_report,
use_sasl_smtp_auth => $q->param('use_sasl_smtp_auth') ? $q->param('use_sasl_smtp_auth') : $li->{use_sasl_smtp_auth},
sasl_smtp_username => $q->param('sasl_smtp_username') ? $q->param('sasl_smtp_username') : $li->{sasl_smtp_username},
decrypted_sasl_pass => $q->param('pop3_password') ? $q->param('pop3_password') : $decrypted_sasl_pass,
},
);
# is that last line right?!
print(admin_html_footer(-List => $list));
}else{
my $use_pop_before_smtp = $q->param('use_pop_before_smtp') || 0;
my $set_smtp_sender = $q->param('set_smtp_sender') || 0;
my $smtp_server = strip($q->param('smtp_server'));
my $pop3_server = strip($q->param('pop3_server')) || '';
my $pop3_username = strip($q->param('pop3_username')) || '';
my $pop3_password = strip($q->param('pop3_password')) || '';
my $smtp_engine = $q->param('smtp_engine') || 'mail_bulkmail';
my $use_smtp_ssl = $q->param('use_smtp_ssl') || 0;
my $use_sasl_smtp_auth = $q->param('use_sasl_smtp_auth') || 0;
my $sasl_smtp_username = strip($q->param('sasl_smtp_username')) || '';
my $sasl_smtp_password = strip($q->param('sasl_smtp_password')) || '';
my $batch_reconnect = $q->param('batch_reconnect') || 0;
my $smtp_connect_tries = $q->param('smtp_connect_tries') || 0;
$ls->save({
smtp_port => $q->param('smtp_port'),
smtp_connect_tries => $smtp_connect_tries,
use_pop_before_smtp => $use_pop_before_smtp,
smtp_engine => $smtp_engine,
use_smtp_ssl => $use_smtp_ssl,
smtp_server => $smtp_server,
pop3_server => $pop3_server,
pop3_username => $pop3_username,
pop3_password => DADA::Security::Password::cipher_encrypt($li->{cipher_key}, $pop3_password),
use_sasl_smtp_auth => $use_sasl_smtp_auth,
sasl_smtp_username => $sasl_smtp_username,
sasl_smtp_password => DADA::Security::Password::cipher_encrypt($li->{cipher_key}, $sasl_smtp_password),
set_smtp_sender => $set_smtp_sender,
batch_reconnect => $batch_reconnect,
});
print $q->redirect(-uri => $S_PROGRAM_URL . '?flavor=smtp_options&done=1');
}
}
sub checkpop {
my ($admin_list, $root_login) = check_list_security(-cgi_obj => $q,
-Function => 'smtp_options');
$list = $admin_list;
require DADA::Security::Password;
my $user = $q->param('user');
my $pass = $q->param('pass');
my $server = $q->param('server');
require DADA::MailingList::Settings;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
require DADA::Mail::Send;
my $mh = DADA::Mail::Send->new($li);
my $pop_status;
if(!$user || !$pass || !$server){
$pop_status = undef;
}else{
$pop_status = $mh->_pop_before_smtp(-pop3_server => $server,
-pop3_username => $user,
-pop3_password => $pass);
}
print $q->header();
if(defined($pop_status)){
print $q->h2("Success!");
print $q->p($q->b("POP-before-SMTP authentication was successful"));
print $q->p($q->b("Make sure to 'Save Changes' to have your edits take affect."));
}else{
print $q->h2("Warning!");
print $q->p($q->b('POP-before-SMTP authentication was ',$q->i('unsuccessful'),));
}
}
sub check_smtp_sasl {
my $list = shift;
require DADA::Mail::Send;
require DADA::MailingList::Settings;
$DADA::MailingList::Settings::dbi_obj = $dbi_handle;
my $ls = DADA::MailingList::Settings->new(-List => $list);
my $li = $ls->get;
my $mh = DADA::Mail::Send->new($li);
my ($log,$s_report) = $mh->check_sasl_settings(
-smtp_server => $q->param('smtp_server'),
-sasl_smtp_username => $q->param('sasl_smtp_username'),
-sasl_smtp_password => $q->param('sasl_smtp_password'),
-smtp_connect_tries => $q->param('smtp_connect_tries'),
-smtp_port => $q->param('smtp_port'),
-set_smtp_sender => $q->param('set_smtp_sender'),
);
my $report;
$report .= $q->h2("SASL Test Report:");
if($s_report->[0]){
foreach(@$s_report){
$report .= '
' . $_ . "\n";
}
}else{
$report .= q{
Nothing to report -
Make sure you have checked Use SMTP
Authentication (SASL) and entered both a username
and password.
};
}
$report .= q{
};
$report .= $q->h2("Raw Log:");
foreach(@$log){
# not the best way, but probably not the worst way either.
$_ = xss_filter($_);
$report .= '
\n";
my $email_count = $q -> param("email_count");
if(defined($email_count)){
my $add_message = "$email_count people have been added successfully";
print $q->p("$add_message");
}
my $delete_email_count = $q -> param("delete_email_count");
if(defined($delete_email_count)){
print "
",$delete_email_count;
print " emails have been deleted
";
}
#my $any_subscribers = -s "$FILES/$list.list";
# debug
my $any_subscribers = 1;
if($any_subscribers != 0){
print"";
$SHOW_EMAIL_LIST = 0;
my ($everyone, $domains_ref, $count_services_ref) = $lh->list_option_form(-List => $list, -In_Order => $LIST_IN_ORDER);
if($SHOW_DOMAIN_TABLE == 1) {
#initialize some variables
my $key;
my $value;
my $everyone_else = $domains_ref -> {Other};
print <Email addresses sorted by Top Level Domains:
click on the particular domain to view the list of
emails from that top level domain.
EOF
;
}
if($SHOW_SERVICES_TABLE==1){
my $skey;
my $svalue;
my $using;
my @skeys = sort(values %SERVICES);
print $q->p("Email address sorted by popular Email or ISP Services: click on a service to see the list of emails from that particular service.");
print <