#!/usr/bin/perl -T use strict; # try this, if you can -> #!/usr/bin/perl -wT # WinNT users! You may want to change the first line of this script to: #!C:/perl/bin/perl.exe # Note: KEEP the '#' character as the first character of that line. # WinNT users! If you're getting warnings in your browser, uncomment # this line: #close STDERR; #!/usr/bin/perl # use CGI::Carp "fatalsToBrowser"; # The line above, when uncommented, gets any server errors created # by Dada Mail and shows them to your web browser. This facilitates # debugging, but it can be annoying if you really don't want this happening. # You'll see something in your browser that says 'Software Error' in big # old letters and then what the error was. Having this on also makes the # # What is in this script that you may want to at least look over are things # that may have to be tweak to fit your server configuration. # 99% of you won't ever have to change this, but then again, you might be # that 1%, so I'll try to walk you through. # First off, if you simply cannot get this script to work, and none of your # error logs point to something that's easy to pick out, try to change the # first line to something else. Its set at: # # #!/usr/bin/perl -w # # as a default. This might not be correct. Other things you can try are: # # # #!/usr/local/bin/perl -w # #!/usr/bin/perl5 -w # #!/usr/local/bin/perl5 -w # # For WinNT folk, you may want to try: # #!C:/perl/bin/perl.exe # # # If you don't know, this is called the 'path to Perl' This script needs to know # where it is, and if you don't know it, it can't figure it out by itself. You may # also need to change this if you're attempting to run this program on a Windows NT server, # ask whoever is in charge of your web hosting server. # Another tid bit that I'll share is the -w at the end of that little line. That's called # the 'warning' flag and, well warns you of stuff that might not be correct. Its nice # to have to figure out weird errors. It also produces a lot of # # Use of uninitialized value at .. blah blah blah blah # # Which you may find annoying and also filling up your error logs with gobble dee gook # take the -w flag of like this # #!/usr/bin/perl # # and most of those warnings will stop. use lib qw(./ ./DADA ./DADA/perllib); # in weird server setups, you may need to change this to the absolute path # to the this program's folder, something like: # # /usr/home/account/www/cgi-bin/dada # # If you move the DADA directory, you'll need to change the # # use lib './'; # # to where it is really located. again, if you're running this on a windows # server, you may have to change this to the full path anyways. $ENV{PATH} = "/bin:/usr/bin"; delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; # If you'd like, you can set a $ENV{PATH} for this program. This is in the ongoing # effort to allow Dada Mail to run in 'Taint' mode. If you don't know what that means, # don't worry. Dada Mail doesn't in the least bit need to run in taint mode. use DADA::Config; use DADA::App::Guts; use DADA::Template::HTML; use DADA::MailingList::Subscribers; # The three lines above load in needed modules, other modules are loaded # dynamically, but these three are needed almost all of the time. ###################################################################### # After popular opinion (aka enough people decided I should do this) # I now allow you to set the size, shape and characteristics of the # "Send a List Message' Form. I don't feel like having these variables in the # Config.pm file, since they're just used for this script, but here goes: # 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'; # check out: # http://www.eskimo.com/%7Ebloo/indexdot/html/tagpages/t/textarea.htm # for the skinny on what these really do, if you don't know ###################################################################### ###################################################################### # ! The variables you need to change are located in the Config.pm # file that is itself located in the DADA folder. ###################################################################### ###################################################################### # Dada Mail. An Easy And Powerful List Management System # # By Justin Simoni <+> justin@skazat.com <+> http://skazat.com # copyright 1999 - 2004 # # This program is Open Source Software and is covered under the General # Public License. You should have gotten a copy of the license with this script. # if not, you can view a copy at: http://www.gnu.org/copyleft/gpl.html # # Dada Mail is free(!) software. Free as in speech, not in as beer or price, # please make sure you understand this. # # I do ask that you also PLEASE keep the link back to the support site intact, # the link that says: # Powered by Dada Mail # Copyright © 1999-2004, Simoni Creative. # # throughout the script, and also keep this header intact as well # # This enables people to find the program and use it themselves. # If you want it removed, you may give a $50 donation, please see: # # http://mojo.skazat.com/purchase/pro.html # # All money will go to support the program, the Dada Mail website # and keeping an exceptionally bright student in college and beyond. # # Changes, Enhancements, Modifications and Professional Installation # of this script can be made on a project by project basis, # # http://mojo.skazat.com/installation/request.html # ##################################################################### # This is the rest of the program, feel free to tweak as needed, if you # find some great enhancement, share it with the community! ###################################################################### # Use the CGI.pm module, to facilitate web page generation and get cookie functions use CGI; CGI->nph(1) if $NPH == 1; # Use strict to make code cleaner, and more safely written use strict; # Unbuffer output for faster page displaying $|++; #Ok, here we go... :) ###################################################################### my $q = new CGI; $q->charset($HTML_CHARSET); my $flavor = $q->param('flavor'); $flavor = $q->param('f') unless($flavor); #$flavor = 'default' if(!$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'); $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); ############################################# #Retrieve the cookie. all the info is saved # #on a seperate cookie for each list. # #logging out erases the password # ############################################# my %logincookie = $q->cookie($LOGIN_COOKIE_NAME); my $admin_list = $logincookie{admin_list}; my $admin_password = $logincookie{admin_password}; #external (mostly..) functions called from the web browser) # a few things this program can do.... :) my %Mode = ( 'default' => \&default, #user start page with all lists 'subscribe' => \&subscribe, #user sends conformation 'subscribe_flash_xml' => \&subscribe_flash_xml, 'unsubscribe_flash_xml' => \&unsubscribe_flash_xml, 'new' => \&confirm, #user adds email 'unsubscribe' => \&unsubscribe, #user unsunbscribes 'admin' => \&admin, #admin login in to the admin area 'login' => \&login, #admin check the user/pass 'logout' => \&logout, #admin erase user/pass 'new_list' => \&new_list, #admin make a new list 'change_info' => \&change_info, #admin change the info in the .db file 'html_code' => \&html_code, #admin get cut + paste code 'admin_help' => \&admin_help, #admin help page 'delete_list' => \&delete_list, #admin delete the list 'list_stats' => \&list_stats, 'view_list' => \&view_list, 'view_list_options' => \&view_list_options, 'edit_subscriber' => \&edit_subscriber, 'add' => \&add, #admin add emails 'email_password' => \&email_password, #admin email the password to the admin 'add_email' => \&add_email, #admin admin add an email 'delete_email' => \&delete_email, #admin admin delete an email 'subscription_options' => \&subscription_options, 'send_email' => \&send_email, #admin send the list email 'preview_form' => \&preview_form, #admin preview the form 'checker' => \&checker, #admin mass delte email 'edit_template' => \&edit_template, #admin edit the template 'view_archive' => \&view_archive, #admin 'edit_archive' => \&edit_archive, 'delete_archive' => \&delete_archive, 'archive' => \&archive, #user look at list the archive 'archive_rss' => \&archive_rss, 'chocolate' => \&chocolate, #chocolate! 'all_list_code' => \&all_list_code, #user, shows signup code for all lists. 'manage_script' => \&manage_script, #admin get info on the script 'change_password' => \&change_password, #change your password 'text_list' => \&text_list, #admin shows email list in new window 'send_list_to_admin' => \&send_list_to_admin, #admin sends email list to adin 'search_email' => \&search_email, #admin search through emails 'archive_options' => \&archive_options, #admin archive options 'adv_archive_options' => \&adv_archive_options, #admin archive options 'back_link' => \&back_link, #create a back button 'edit_type' => \&edit_type, #customize type and stuff 'edit_html_type' => \&edit_html_type, #customize type and stuff 'list_options' => \&list_options, # customize list options 'sending_options' => \&sending_options, # customize sending options 'adv_sending_options' => \&adv_sending_options, # adv sending options #'list_security' => \&list_security, 'sign_in' => \&sign_in, # sign into individual lists 'black_list' => \&black_list, #sign into black lists 'search_archive' => \&search_archive, # search through the archive (user) 'send_archive' => \&send_archive, # send a copy of an archive message 'dada_send_options' => \&dada_send_options, # options for dada_send.pl 'list_invite' => \&list_invite, # invite a whole bunch of people to your list 'pass_gen' => \&pass_gen, # password generation '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, # 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, # subscribe 'n' => \&confirm, # confirm the subscription 'u' => \&unsubscribe, # unsubscribes 'smtm' => \&smtm # SHOW ME THE MONEY! ); &_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; my @available_lists = available_lists(-In_Order => 1); if( ($DEFAULT_SCREEN ne '') && ($flavor ne 'default') && ($#available_lists >= 0) ){ print $q->redirect(-uri => $DEFAULT_SCREEN); exit; # could we just say, return; ? } if ($available_lists[0]) { print(the_html(-Part => "header", -Title => "Sign up for a list", -Start_Form => 0, )); require DADA::Template::Widgets; print DADA::Template::Widgets::default_screen(-email => $email, -list => $list, -set_flavor => $set_flavor, ); print $q->a({-href=>"$PROGRAM_URL?"."\x61\x72\x74", -style=>'font-size:1px;color:#FFFFFF'},'*'); print(the_html(-Part => "footer", -End_Form => 0)); }else{ print(the_html(-Part => "header", -Title => "Welcome to $PROGRAM_NAME", -Start_Form => 0, )); require DADA::Template::Widgets; print DADA::Template::Widgets::congrats_screen(-agree => $q->param('agree')); 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) == 0){ undef($list); &default; exit; } require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings->new(-List => $list); my $list_info = $ls->get; require DADA::Template::Widgets; print(the_html(-Part => "header", -Title => $list_info->{list_name}, -List => $list, -Start_Form => 0, )); print DADA::Template::Widgets::list_page(-list => $list, -email => $email, -set_flavor => $set_flavor, ); print(the_html(-Part => "footer", -List => $list, -End_Form => 0)); } sub admin { my $login_widget; print(the_html(-Part => "header", -Title => "Administration", -Start_Form => 0, )); require DADA::Template::Widgets; print DADA::Template::Widgets::admin(-login_widget => $q->param('login_widget')); print(the_html(-Part => "footer", -End_Form => 0)); } sub sign_in { my $list_exists = check_if_list_exists(-List=>$list); if($list_exists >= 1){ #print header(); my $pretty = pretty($list); print(the_html(-Part => "header", -Title => "Sign In To $pretty", -List => $list)); }else{ #print header(); print(the_html(-Part => "header", -Title => "Sign In" )); } my @available_lists = available_lists(); print $q->end_form(); print $q->start_form(-action => $S_PROGRAM_URL, -method => 'Post'); require DADA::Template::Widgets; if($list_exists >= 1){ print DADA::Template::Widgets::list_login_form(-list => $list); }else{ if($LOGIN_WIDGET eq 'popup_menu'){ print DADA::Template::Widgets::list_popup_login_form(); } elsif($LOGIN_WIDGET eq 'text_box') { print DADA::Template::Widgets::text_box_login_form(); }else{ warn "'$LOGIN_WIDGET' misconfigured!" } } if($list_exists >= 1){ print(the_html(-Part => "footer", -List => $list)); }else{ print(the_html(-Part => "footer")); } } sub send_email { # Howdy! (that's Coloradoian talk for 'hello') saying that, # i'm actually a transplant from Connecticut. But anyways this is # the 'send a list message' function (applause) which is probably the # most interesting function in this pile of code and one you might # want to tweak or something, so here goes. # we'll check a few things here, makes sure info saved in a cookie # is all good and well, my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'send_email'); require DADA::MailingList::Settings; # a bit of a trick, $admin_list is fetched from a cookie, so its not # like you can pass the admin password here in a query string, kinda # makes it impossible for you to spoof the security without a browser. $list = $admin_list; my $ls = DADA::MailingList::Settings->new(-List => $list); # fetch the list info hash. this has all our list information # and related goodies. my $li = $ls->get; my %list_info = %$li; # # # my $text_message_body = ""; my $html_message_body = ""; my $message_subject = $list_info{list_name} . ' Message'; if($q->param('archive_id')){ require DADA::MailingList::Archives; my $la = DADA::MailingList::Archives->new(-List => \%list_info); if($la->check_if_entry_exists($q->param('archive_id')) > 0){ my ($asubject, $amessage, $aformat) = $la->get_archive_info($q->param('archive_id')); $message_subject = $asubject; if($aformat =~ m/HTML/i){ $html_message_body = $amessage; }else{ $text_message_body = $amessage; } } } # # # # 'attachment number' tells how many file upload widgets to show. # pretty frickin exciting eh? my $at_num = $q->param('at_num') || 1; #unless we be doing some sending... unless( (defined($process) ) && ($process ne "") ){ #print our header print(admin_html_header(-Title => "Send A List Message", -List => $list_info{list}, -Root_Login => $root_login)); # end the form that's in the template, we need a special form for # file uploads. print $q->end_form(); print $q->h3("Send a message to people subscribed to: $list_info{list_name}"); print "

Warning! No SMTP Server has been set!

" if((!$list_info{smtp_server}) && ($list_info{send_via_smtp} eq "1")); # we give a link to the basic screen if we be in advanced # and vice versa. if($advanced eq 'yes'){ print $q->p({-align=>'right'}, $q->a({-href=>"$S_PROGRAM_URL?flavor=$flavor"},'Basic...')); }else{ print $q->p({-align=>'right'}, $q->a({-href=>"$S_PROGRAM_URL?flavor=$flavor&advanced=yes"},'Advanced...')); } # start the new form print $q->start_multipart_form(-action=>$S_PROGRAM_URL, -method=>'POST', -name=>'the_form'), $q->hidden('list',$list_info{list}), $q->hidden(-name => 'flavor', -value => 'send_email', -override =>1); # remember its advanced if we have to. print $q->hidden('advanced', $advanced) if($advanced eq 'yes'); # this basically is the widget to say 'is this text or html?' my $format_options = < EOF ; print ""; # this is all for the advanced form, we'll be switching from # basic and advanced, so pay attention! # print the From: field # usually the list owner print $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('From:')))), ($q->p($q->textfield(-name =>'From', -value =>'"'. escape_for_sending($list_info{list_name}) . '" <'.$list_info{list_owner_email}.'>', -size => 49))) ])), # print the 'Reply-To:' field # usually the same as the From: field $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Reply-To:')))), ($q->p($q->textfield(-name =>'Reply_To', -value =>'"' . escape_for_sending($list_info{list_name}) . '" <'.$list_info{list_owner_email}.'>', -size => 49))) ])), (($list_info{print_errors_to_header} == 1) ? ( # print the 'Errors-To' field # usually the List Admin $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Errors-To:')))), ($q->p($q->textfield(-name =>'Errors_To', -value =>"<$list_info{admin_email}>", -size => 49))) ])), ) : ()), (($list_info{print_return_path_header} == 1) ? ( # print the 'Return-Path' field # usually the List Admin $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Return-Path:')))), ($q->p($q->textfield(-name =>'Return_Path', -value =>"<$list_info{admin_email}>", -size => 49))) ])), ) : ()), # print the Precedence, usually list $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Precedence:')))), ($q->p($q->popup_menu(-name => 'Precedence', -values => \@PRECEDENCES, -default => $list_info{precedence}))) ])), #print the Priority, usually 3 or 'Normal' $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Priority:')))), ($q->p($q->popup_menu(-name =>'Priority', -values =>[keys %PRIORITIES], -labels => \%PRIORITIES, -default => $list_info{priority}, ))) ]))if($advanced eq 'yes'); # print the subject print $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Subject:')))), ($q->p($q->textfield(-name =>'message_subject', -value =>"$message_subject", -size => 49))) ])); # this is where we print out the attachments if we be in 'advanced' if($advanced eq 'yes'){ # tell us that we're using attachments print $q->hidden('attachment', 'true'); # remember how many attachment files we have print $q->hidden('at_num', $at_num); # my $i my $i; # foreach of the $at_num's for($i=1; $i<=$at_num; $i++){ # print a file upload form print $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; # and then print a link to make another one. print $q->Tr($q->td([ $q->p(' '), $q->p({-align=>'right'}, $q->i($q->a({-href=>"$S_PROGRAM_URL?flavor=$flavor&advanced=yes&at_num=$next_num"}, 'more attachment fields...'))), ])); } # give an option to *not* archive this message (adv) print $q->Tr($q->td([ ($q->p({-align=>'right'},($q->b('Options:')))), ($q->p( $q->checkbox(-name => 'html_with_images', -value => 1, -label => 'HTML Version uses attached images', ))) ])), $q->Tr($q->td([ ($q->p(' ')), ($q->p($q->checkbox(-name =>'archive_message', -value => 1, -label => 'Archive This message', (($list_info{archive_messages} ne "0") ? (-checked => 'ON',) : (-checked => '0',)), ))) ])), $q->Tr($q->td([ ($q->p(' ')), ($q->p($q->checkbox(-name => 'apply_template', -value => 1, -label => 'Apply the list template to the HTML message', ))) ])) if($advanced eq 'yes'); # print the 'Format' select box if we're in basic. print $q->Tr($q->td([ ($q->p({-align=>'right'},$q->b('Format:'))), ($q->p($format_options)) ])) if($advanced ne 'yes'); print '
'; # print textfield('archive_message', $list_info{archive_messages}) if $advanced ne 'yes'; my $text_blurb = ""; my $html_blurb = ""; $text_blurb = "Text Version
" if($advanced eq 'yes'); $html_blurb = "HTML Version
" if($advanced eq 'yes'); # print one textarea... print $q->p({-align=>'center'}, "$text_blurb", $q->textarea(-name => 'text_message_body', -cols => $cols, -rows => $rows, -wrap => $wrap, -style => $text_area_style, -value => $text_message_body)); # and another if we're in 'advanced' print $q->p({-align=>'center'}, "$html_blurb", $q->textarea(-name => 'html_message_body', -cols => $cols, -rows => $rows, -wrap => $wrap, -style => $text_area_style, -value => $html_message_body)) if($advanced eq 'yes'); if( ($advanced eq 'yes') # && #($list_info{send_via_smtp} ne "1") ){ print $q->hr({-width=>'66%', -size=>1, -color=>'black'}), $q->p({-align=>'center'}, $q->i('These two options are helpful if, for some reason, your list mailing was dropped mid sending - you\'ll be able to pick up the mailing near where it was left off')), $q->p({-align=>'center'},'start this mailing at this address:', $q->br(), $q->textfield(-name=>'Start-Email'), $q->br(), $q->b('-or-'), $q->br(), 'start this mailing at email number:', $q->br(), $q->textfield(-name=>'Start-Num', -size=>6), $q->br()), $q->hr({-width=>'66%', -size=>1, -color=>'black'}), } #print qq{ # #

Test Message Recipients:

#}; print <

I'm sure.
Open in a new window.

EOF ; # end that, wasn't so bad eh? print $q->end_form(); print qq{

\ 

[?] Send a List Message

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); }else{ # pull in the Mime::Lite module require MIME::Lite; MIME::Lite->quiet(1) if $MIME_HUSH == 1; ### I know what I'm doing $MIME::Lite::PARANOID = $MIME_PARANOID; my $email_format = $q->param('email_format') || undef; # get the message subject my $message_subject = $q->param('message_subject'); # get the text message my $text_message_body = $q->param('text_message_body') || undef; # if one was passed, if($text_message_body){ # get rid of weird line breaks caused by textareas $text_message_body =~ s/\r\n/\n/g; # get some saved formatting stuff my $text_template = $list_info{mailing_list_message}; # format $text_template =~ s/\[message_body\]/$text_message_body/g; # switch it back $text_message_body = $text_template; # interpolate [tags] to $tags $text_message_body = interpolate_string(-String => $text_message_body, -List_Db_Ref => \%list_info); } # get the HTML message (if any) my $html_message_body; $html_message_body = $q->param('html_message_body') || undef; if(($email_format eq 'HTML') || ($email_format eq 'HTML_and_text')){ $html_message_body = $q->param('text_message_body') || undef; }else{ $html_message_body = $q->param('html_message_body') || undef; } my $html_archive_message_body; if($html_message_body){ # get rid of weird line breaks $html_message_body =~ s/\r\n/\n/g; # get some saved template my $html_template = $list_info{mailing_list_message_html}; # template it $html_template =~ s/\[message_body\]/$html_message_body/g; # switch it back $html_message_body = $html_template; # interpolate [pusedo tags] $html_message_body = interpolate_string(-String => $html_message_body, -List_Db_Ref => \%list_info); } # escape the list name for query strings. # see if we gots an attachment my $attachment = $q->param('attachment'); my $s_link = subscribe_link(-list => $list, -email => '[email]', -pin => '[pin]'); my $us_link = unsubscribe_link(-list => $list, -email => '[email]', -pin => '[pin]'); my $html_unsubscribe_link = "$us_link"; my $html_subscribe_link = "$s_link"; # make sub links my $text_unsubscribe_link = $us_link; my $text_subscribe_link = $s_link; my $content_type; if($advanced){ # do some advanced stuff. if(defined($text_message_body) ne ""){ # interpolate the sub and unsub links $text_message_body =~ s/\[list_unsubscribe_link\]/$text_unsubscribe_link/g; $text_message_body =~ s/\[list_subscribe_link\]/$text_subscribe_link/g; } if(defined($html_message_body) ne ""){ # interpolate the sub and unsub links $html_message_body =~ s/\[list_unsubscribe_link\]/$html_unsubscribe_link/g; $html_message_body =~ s/\[list_subscribe_link\]/$html_subscribe_link/g; } } if($email_format){ # if we got here, we're using the 'basic' screen if($email_format eq "TEXT"){ # if we have text, treat it as so. $content_type = 'text/plain'; $text_message_body =~ s/\[list_unsubscribe_link\]/$text_unsubscribe_link/g; $text_message_body =~ s/\[list_subscribe_link\]/$text_subscribe_link/g; }elsif($email_format eq "convert_to_plain_text"){ # do our best to strip HTML taghs $content_type = 'text/plain'; $text_message_body = convert_to_ascii($text_message_body); $text_message_body =~ s/\[list_unsubscribe_link\]/$text_unsubscribe_link/g; $text_message_body =~ s/\[list_subscribe_link\]/$text_subscribe_link/g; }elsif($email_format eq 'HTML'){ # its HTML! $content_type = 'text/html'; $html_message_body = $html_message_body; undef($text_message_body); $html_message_body =~ s/\[list_unsubscribe_link\]/

$html_unsubscribe_link/g; $html_message_body =~ s/\[list_subscribe_link\]/

$html_subscribe_link/g; }elsif($email_format eq 'HTML_and_text'){ # make two versions of the message, the other one being converted html to text $content_type = 'multipart/alternative'; $html_message_body = $html_message_body; $html_message_body =~ s/\[list_unsubscribe_link\]/

$html_unsubscribe_link/g; $html_message_body =~ s/\[list_subscribe_link\]/

$html_subscribe_link/g; $text_message_body = convert_to_ascii($text_message_body); $text_message_body =~ s/\[list_unsubscribe_link\]/$text_unsubscribe_link/g; $text_message_body =~ s/\[list_subscribe_link\]/$text_subscribe_link/g; } } if($html_message_body){ if($q->param('apply_template') == 1){ $html_archive_message_body = $html_message_body; $html_message_body = (the_html(-Part => "header", -Title => $message_subject, -List => $list, -Header => 0)) . $html_message_body . the_html(-Part => "footer", -List => $list); } } ####################################################################### my $plaintext_ver; my $html_ver; my $attachments; my $msg; my $attachment_filenames = []; my $uploaded_files = []; if($text_message_body){ $plaintext_ver = MIME::Lite->new(Type => 'TEXT', Data => $text_message_body, Encoding => $list_info{plaintext_encoding}, ); } if($html_message_body){ $html_ver = MIME::Lite->new(Type => 'text/html', Data => $html_message_body, Encoding => $list_info{html_encoding}); if($q->param('html_with_images') == 1){ my $mpr_msg = MIME::Lite->new(Type => 'multipart/related'); $mpr_msg->attach($html_ver); if($attachment){ my $tmp = $mpr_msg; if(has_attachments()){ my $attachment_msg; ($attachment_msg, $attachment_filenames, $uploaded_files) = make_attachments('multipart/related', 'attachment', $tmp); undef $tmp; $mpr_msg = $attachment_msg; undef $tmp; } } $html_ver = $mpr_msg; }else{ } } if($plaintext_ver && $html_ver){ my $mpa_msg = MIME::Lite->new(Type => 'multipart/alternative'); $mpa_msg->attach($plaintext_ver); $mpa_msg->attach($html_ver); if($attachment){ $msg = MIME::Lite->new(Type => 'multipart/mixed'); $msg->attach($mpa_msg); }else{ $msg = $mpa_msg; } }elsif($html_ver){ $msg = $html_ver; }else{ $msg = $plaintext_ver; } if((has_attachments() == 1) && ($q->param('html_with_images') != 1)){ my $attachment_msg; ($attachment_msg, $attachment_filenames, $uploaded_files) = make_attachments(undef, undef, undef); if ($attachment_msg){ $msg->attach($attachment_msg); } } $msg->replace('X-Mailer' => ""); my $header_glob = $msg->header_as_string(); # get the body my $message_string = $msg->body_as_string(); my $archive_m = $q->param('archive_message') || $list_info{archive_messages} || 0; if($advanced eq 'yes'){ if($q->param('archive_message') != 1){ $archive_m = 0; } } # pull in the DADA::Mail::Send mod require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); # translate the glob into a hash my %headers = $mh->return_headers($header_glob); # make a mailing my %mailing = (%headers, To => '"'. escape_for_sending($list_info{list_name}) .'" <'. $list_info{list_owner_email} .'>', Subject => $message_subject, Body => $message_string, ); $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') || $list_info{priority}; $mailing{Precedence} = $q->param('Precedence') || $list_info{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); # send away my $message_id = $mh->bulk_send(%mailing); # archive, if needed #{ #local $| = 0; if(($archive_m == 1) && ($process !~ m/test/i)){ require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives->new(-List => \%list_info); if($html_archive_message_body){ $archive->set_archive_info($message_id, $message_subject, $html_archive_message_body, 'text/html'); }elsif($html_message_body){ $archive->set_archive_info($message_id, $message_subject, $html_message_body, 'text/html'); }elsif($text_message_body){ $archive->set_archive_info($message_id, $message_subject, $text_message_body, 'text/plain'); } # } } # report a good job done. print(admin_html_header( -Title => "List Message is Being Sent", -List => $list_info{list}, -Root_Login => $root_login )); if($process =~ m/test/i){ print $q->p("Your", $q->b($q->i("test")), "message is being sent to the list owner,($list_info{list_owner_email})"); }elsif($q->param('Start-Email')){ print $q->p("Your list mailing will be sent to all your list subscribers, starting at " . $q->strong($q->param('Start-Email'))); }elsif($q->param('Start-Num')){ print $q->p("Your list mailing will be sent to all your list subscribers, starting at # " . $q->strong($q->param('Start-Num'))); }else{ print $q->p("Your message, $message_subject, is currently being sent to all your list subscribers"); } print '
'; print '
'; print $q->p($q->b("To: $list_info{list_name}"), $q->br(), $q->b("From: $list_info{list_owner_email}"), $q->br(), $q->b("Subject: $message_subject")); if($text_message_body){ print '
'; my $screen_text_message = $text_message_body; $screen_text_message = webify_plain_text($screen_text_message); $screen_text_message =~ s/\[email\]/$list_info{list_owner_email}/gi; my $lm_pin = make_pin(-Email => $list_info{list_owner_email}); $screen_text_message =~ s/\[pin\]/$lm_pin/gi; print $q->p($q->b('Text Message:'), $q->br(), $screen_text_message); } if($html_message_body){ print '
'; my $screen_html_message = $html_message_body; $screen_html_message =~ s/\[email\]/$list_info{list_owner_email}/gi; my $html_lm_pin = make_pin(-Email => $list_info{list_owner_email}); $screen_html_message =~ s/\[pin\]/$html_lm_pin/gi; print $q->p($q->b('HTML Message:'), $q->br(), $screen_html_message); } if(@$attachment_filenames){ print '

'; print $q->strong('Attachments:'), $q->br(); print '

    '; print '
  • ' . $_ . '
    • ' foreach(@$attachment_filenames); print '

'; } #print $attach_report if(defined($attach_report)); print '
'; print '
'; if(($archive_m == 1) && ($process !~ m/test/i)){ print $q->p($q->i('This message has been', $q->a({-href=>"$S_PROGRAM_URL?flavor=view_archive&id=$message_id"}, 'archived'))) } clean_up_attachments($uploaded_files) if $ATTACHMENT_TEMPFILE == 1; print(admin_html_footer(-List => $list)); } } sub clean_up_attachments { my $files = shift || []; foreach(@$files){ warn "could not remove '$_'" unless unlink($_) > 0; # i love the above! } } sub has_attachments { my $i = 0; my $at_num = $q->param('at_num') || 1; my $attachment = $q->param('attachment'); return undef if ! $attachment; for($i = 1; $i <= $at_num; $i++){ my $this_attachment = 'attachment_' . $i; return 1 if $q->param($this_attachment); } return undef; } sub make_attachments { require MIME::Lite; my $Type = shift || 'multipart/related'; my $Disposition = shift || 'attachment'; my $saved_attachments = shift || MIME::Lite->new(Type => $Type); my @uploaded_files; my @attachment_filenames; my $attachment = $q->param('attachment'); return undef if !$attachment; my $i = 0; my $at_num = $q->param('at_num') || 1; for($i = 1; $i <= $at_num; $i++){ my $this_attachment = 'attachment_' . $i; # get it by argument, my $get_attachment = $q->param($this_attachment); if($get_attachment){ my $a_type = find_attachment_type($get_attachment); my $attach_name = $get_attachment; $attach_name =~ s!^.*(\\|\/)!!; $attach_name =~ s/\s/%20/g; my %mime_args = ( Type => $a_type, Id => '<'.$attach_name.'>', Filename => $attach_name, Disposition => $Disposition, # most likely... inline, persay? ); my $attachment_file; if($ATTACHMENT_TEMPFILE == 1){ $attachment_file = file_upload($this_attachment); $mime_args{Path} = $attachment_file; push(@uploaded_files, $attachment_file); }else{ $mime_args{FH} = $get_attachment, } $saved_attachments->attach(%mime_args); push(@attachment_filenames, $attach_name); $saved_attachments->attr('Content-Location' => $attach_name); } } return ($saved_attachments, \@attachment_filenames, \@uploaded_files); } 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 $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'list_invite'); $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); unless($process){ # unless we have something to do, give them the first screen: print(admin_html_header(-Title => "Invitations", -List => $list_info{list}, -Root_Login => $root_login)); print $q->p("Send an invitation email by pasting the addresses of people you want to invite to your list, and then writing an invitation message. Your invitation list will be cleaned of duplicate addresses, people who are already subscribed to your list, invalid e-mail addresses and any black listed addresses."); print $q->p($q->b("Your Invitation List:"), $q->br(), $q->textarea(-name => 'new_emails', -cols => 50, -rows => 5)), $q->hidden('flavor', 'list_invite'); print '

'; print $q->p("You can send the invitation message in plain text, HTML, or both. Type in your message in the appropriate text box, leaving either of them blank if no mailing of that format is desired"); print $q->p($q->b("Subject:"), $q->br(), $q->textfield(-name => 'message_subject', -size => 50, -value => $list_info{invite_message_subject})); #Plain Text print $q->p({-align=>'center'}, $q->b("Text Message"), $q->br(), $q->textarea(-name => 'text_message_body', -value => $list_info{invite_message_text}, -cols => $cols, -rows => $rows, -wrap => $wrap, -style => $text_area_style)); # HTML print $q->p({-align=>'center'}, $q->b("HTML Message"), $q->br(), $q->textarea(-name => 'html_message_body', -value => $list_info{invite_message_html}, -cols => $cols, -rows => $rows, -wrap => $wrap, -style => $text_area_style)); print $q->p( $q->checkbox(-name => 'save_invite_messages', -value => 1, -label => ''), $q->b('Save these messages and the subject for future invitation messages')); print qq{
}; print qq{

\ 

[?] Send a List Invitation

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); exit; # what's up with this? }else{ ####################################################################### # # # The code below is very similar to the 'add_email()' function, please note. # Later on, I may take the below code and create a function from it. # ####################################################################### # q: what exactly are we doing here? # a: we're filtering out the emails given to the script # in various steps my %seen; # get the emails my $new_emails = $q -> param("new_emails"); # split them into individual entities my @new_addresses = split(/\s+|,|;|\n+/, $new_emails); my @good_emails = (); my @bad_emails = (); my $invalid_email; foreach my $check_this_address(@new_addresses) { # see they're valid my $pass_fail_address = check_for_valid_email($check_this_address); if ($pass_fail_address >=1){ # save em if tey aint push(@bad_emails, $check_this_address); }else{ # save em if they are valid $check_this_address = lc_email($check_this_address); push(@good_emails, $check_this_address); } } # this filters through the emails and takes out al duplicates %seen = (); my @unique_good_emails = grep { ! $seen{$_}++} @good_emails; %seen = (); my @unique_bad_emails = grep { ! $seen{$_}++} @bad_emails; @unique_good_emails = sort(@unique_good_emails); @unique_bad_emails =sort(@unique_bad_emails); # this filters out emails addresses, taken them out of our list if they're already there # figure out what unique emails we have from the new list when compared to the old list my ($unique_ref, $not_unique_ref) = $lh->unique_and_duplicate(-New_List => \@unique_good_emails, -List => $list); #initialize my @black_list; my $found_black_list_ref; my $clean_list_ref; my $black_listed_ref; my $black_list_ref; if($list_info{black_list} eq "1"){ #open the black list $black_list_ref = $lh->open_email_list(-List => $list, -Type => "black_list", -As_Ref=>1); # now, from that new list of clean emails, see which ones are black listed ($found_black_list_ref) = $lh->get_black_list_match($black_list_ref, $unique_ref); #now, tell me which ones still are ok. ($clean_list_ref, $black_listed_ref) = $lh->find_unique_elements($unique_ref, $found_black_list_ref); }else{ $clean_list_ref = $unique_ref; } # add these to a special 'invitation' list. we'll clear this list later. my $new_email_count=$lh->add_to_email_list(-Email_Ref => $clean_list_ref, -List => $list_info{list}, -Type => 'invitelist', -Mode => 'writeover'); ##################################################################### # SUBJECT # ########### # get the message subject my $message_subject = $q->param('message_subject'); ##################################################################### # TEXT # ######## # get the text message my $text_message_body = DADA::App::Guts::strip($q->param('text_message_body')) || undef; $text_message_body =~ s(/^\n+|\n+$)()g; # if text version was passed, if($text_message_body){ # get rid of weird line breaks caused by textareas $text_message_body =~ s/\r\n/\n/g; # interpolate [tags] to $tags $text_message_body = interpolate_string(-String => $text_message_body, -List_Db_Ref => \%list_info); } ##################################################################### # HTML # ######## # get the HTML message (if any) 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){ # get rid of weird line breaks $html_message_body =~ s/\r\n/\n/g; # interpolate [pusedo tags] $html_message_body = interpolate_string(-String => $html_message_body,-List_Db_Ref => \%list_info); } my $s_link = subscribe_link(-list => $list, -email => '[email]', -pin => '[pin]'); my $us_link = unsubscribe_link(-list => $list, -email => '[email]', -pin => '[pin]'); # make unsub links my $html_subscribe_link = "$s_link"; my $html_unsubscribe_link = "$us_link"; # make sub links my $text_unsubscribe_link = $s_link; my $text_subscribe_link = $us_link; if(defined($text_message_body) ne ""){ # interpolate the sub and unsub links $text_message_body =~ s/\[list_unsubscribe_link\]/$text_unsubscribe_link/g; $text_message_body =~ s/\[list_subscribe_link\]/$text_subscribe_link/g; } if(defined($html_message_body) ne ""){ # interpolate the sub and unsub links $html_message_body =~ s/\[list_unsubscribe_link\]/$html_unsubscribe_link/g; $html_message_body =~ s/\[list_subscribe_link\]/$html_subscribe_link/g; } require MIME::Lite; MIME::Lite->quiet(1) if $MIME_HUSH == 1; ### I know what I'm doing $MIME::Lite::PARANOID = $MIME_PARANOID; my $msg; if($text_message_body and $html_message_body){ # if we have text and html, we need to make a multipart/alternative message, $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); }else{ $msg = MIME::Lite->new(Type => 'TEXT', Data => $text_message_body); } $msg->replace('X-Mailer' =>""); # get the header, my $header_glob = $msg->header_as_string(); # get the body my $message_string = $msg->body_as_string(); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); # translate the glob into a hash my %headers = $mh -> return_headers($header_glob); # make a mailing my %mailing = ( %headers, To => '"'. escape_for_sending($list_info{list_name}) .'" <'. $list_info{list_owner_email} .'>', From => $list_info{list_owner_email}, Subject => $message_subject, Body => $message_string); # just testing? $mh->list_type('invitelist'); $mh->bulk_test(1) if($process =~ m/test/i); $mh->bulk_send(%mailing); print(admin_html_header(-Title => "Invitations Sent", -List => $list_info{list}, -Root_Login => $root_login)); $new_email_count = int($new_email_count); if($process =~ m/test/i){ print $q->p("Your", $q->b($q->i("test")), " invitation message is being sent to the list owner, ($list_info{list_owner_email})"); }else{ print $q->p("$new_email_count invitation messages are now being sent. The list owner will also get a copy of this invitation message."); } print '
'; print '
'; print $q->p($q->b("To: Invite List"), $q->br(), $q->b("From: $list_info{list_owner_email}"), $q->br(), $q->b("Subject: $message_subject")); if($text_message_body){ print '
'; my $screen_text_message = $text_message_body; $screen_text_message = webify_plain_text($screen_text_message); $screen_text_message =~ s/\[email\]/$list_info{list_owner_email}/gi; my $lm_pin = make_pin(-Email => $list_info{list_owner_email}); $screen_text_message =~ s/\[pin\]/$lm_pin/gi; print $q->p($q->b('Text Message:'), $q->br(),$screen_text_message); } if($html_message_body){ print '
'; my $screen_html_message = $html_message_body; $screen_html_message =~ s/\[email\]/$list_info{list_owner_email}/gi; my $html_lm_pin = make_pin(-Email => $list_info{list_owner_email}); $screen_html_message =~ s/\[pin\]/$html_lm_pin/gi; print $q->p($q->b('HTML Message:'), $q->br(), $screen_html_message); } print '
'; print '
'; print(admin_html_footer(-List => $list)); if($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; require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings->new(-List => $list); $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 $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'send_url_email'); $list = $admin_list; my %list_info = open_database(-List => $list); if(!$process){ print(admin_html_header( -Title => "Send A Webpage", -List => $list_info{list}, -Root_Login => $root_login)); eval { require MIME::Lite::HTML}; if($@){ print $q->p($q->b($q->i("Sorry, this feature is not available on this server. Ask your server administrator to install the 'lwp Perl library"))); }else{ print $q->p('Send a web page to your subscribers. Enter the complete URL (including the http://) of the webpage you want to send out. It\'s well advised that you send a test message before committing on a real list sending.'), $q->p($q->strong('Note:'), 'Mailing List Message email templates are not applied to webpage messages. It\'s advised that you put the necessary list information, including unsubscription links, into the webpage itself.'), $q->p($q->b('Message Subject:'), $q->br(), $q->textfield(-name =>'message_subject', -value =>"$list_info{list_name} message", -size => 49)), $q->p($q->b('Web Page Address (URL):'), $q->br(), $q->textfield(-name=>'url', size=>'65', -value=>'http://')); print $q->p($q->strong($q->a({-href=>'#', -onclick => 'toggleDivDisplay(\'adv\')'}, 'Show/Hide Advanced Options'))); print ''; print $q->p($q->b('Plain Text Version (optional, but recommended)'), $q->br(), $q->textarea(-name => 'text_message_body', -cols => $cols, -rows => $rows, -wrap => $wrap, -style => $text_area_style, -value => ' ') ), $q->hidden('flavor', 'send_url_email'), $q->hr(); print <

EOF ; print qq{

\ 

[?] Send a Webpage

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); } }else{ eval { require MIME::Lite::HTML }; if(!@$){ 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; if(defined($q->param('proxy'))){ $proxy = $q->param('proxy'); } my $mailHTML = new MIME::Lite::HTML('IncludeType' => $url_options, #'Debug' => "1", 'TextCharset' => $list_info{charset_value}, 'HTMLCharset' => $list_info{charset_value}, (($login_details) ? (LoginDetails => $login_details,) : ()), HTMLEncoding => $list_info{plaintext_encoding}, TextEncoding => $list_info{html_encoding}, (($proxy) ? (Proxy => $proxy,) : ()), ); my $t = $q->param('text_message_body') || 'This email message requires that your mail reader support HTML'; my $MIMELiteObj = $mailHTML->parse($q->param('url'), $t); my $content = $MIMELiteObj->body_as_string(); require MIME::Lite; MIME::Lite->quiet(1) if $MIME_HUSH == 1; ### I know what I'm doing $MIME::Lite::PARANOID = $MIME_PARANOID; my $base_url = $q->param('url'); #if($q->param('add_base_tag') eq 'yes'){$content = "\n$content";} my $s_link = subscribe_link(-list => $list, -email => '[email]', -pin => '[pin]'); my $us_link = unsubscribe_link(-list => $list, -email => '[email]', -pin => '[pin]'); my $html_subscribe_link = "$s_link"; my $html_unsubscribe_link = "$us_link"; my $template = $list_info{mailing_list_message_html}; # $template =~ s/\[message_body\]/$content/g; $template = $content; $template =~ s/\[list_unsubscribe_link\]/$html_unsubscribe_link/g; $template =~ s/\[list_subscribe_link\]/$html_subscribe_link/g; $template = interpolate_string(-String=>$template, -List_Db_Ref=>\%list_info); #my $msg = MIME::Lite->new(Type => 'text/html', Data => $template); #my $header_glob = $msg->header_as_string(); #my $message_string = $msg->body_as_string(); $MIMELiteObj->replace('X-Mailer' =>""); my $header_glob = $MIMELiteObj->header_as_string(); # pull in the DADA::Mail::Send mod require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); my %headers = $mh ->return_headers($header_glob); my %mailing = (%headers, To => '"'. escape_for_sending($list_info{list_name}) .'" <'. $list_info{list_owner_email} .'>', Subject => $q->param('message_subject'), # Body => $message_string, Body => $template, ); # just testing? $mh->bulk_test(1) if($q->param('process') =~ m/test/i); my $message_id = $mh->bulk_send(%mailing); if(($list_info{archive_messages} ne "0") && ($q->param('process') !~ m/test/i)){ require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives->new(-List => \%list_info); require LWP::Simple; my $archived_page = LWP::Simple::get($base_url); $archived_page =~ s/\[list_unsubscribe_link\]/$html_unsubscribe_link/g; $archived_page =~ s/\[list_subscribe_link\]/$html_subscribe_link/g; $archived_page = interpolate_string(-String => $archived_page , -List_Db_Ref=>\%list_info); # gimmee a base href, justin style. my $base_href = $base_url; my $base_href2 = $base_url; $base_href2 =~ s(^.*/)(); $base_href =~ s/$base_href2$//; # one wonders how this would possibly affect the archived page... $archived_page = "\n\n" . $archived_page; $archive->set_archive_info($message_id, $q->param('message_subject'), $archived_page, 'text/html'); } print(admin_html_header(-Title => "List Message is Being Sent", -List => $list_info{list}, -Root_Login => $root_login)); if($process =~ m/test/i){ print $q->p("Your", $q->b($q->i("test")), "message is being sent to the list owner,($list_info{list_owner_email})"); }else{ print $q->p("Your message is currently being sent to all your list subscribers"); } print $q->p($q->i('This message has been', $q->a({-href=>"$S_PROGRAM_URL?flavor=view_archive&id=$message_id"}, 'archived'))) if($list_info{archive_messages} ne "0" and $q->param('process') !~ m/test/i); print(admin_html_footer(-List => $list)); }else{ die "$PROGRAM_NAME $VER Error: $!\n"; } } } sub change_info { my ($errors, $flags) = @_; my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'change_info'); unless (defined($process)){ $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Change List Information", -List => $list_info{list}, -Root_Login => $root_login)); if(defined($errors) >= 1){ my $ending = ''; my $err_word = 'was'; $ending = 's' if $errors > 1; $err_word = 'were' if $errors > 1; print "

$errors field$ending on this form $err_word filled out incorrectly and need to be fixed for all new information to be saved.

"; } print $GOOD_JOB_MESSAGE if(defined($done)); print $q->hidden('flavor', 'change_info'), $q->hidden('list', $list_info{list}), $q->hidden('process', 'true'); print $q->p('Your list\'s ', $q->b('short name'), 'is:', $q->b($q->i($list_info{list}))); print '

You did not fill in a list name

' if $flags->{list_name} == 1; print $q->p('What is the name of your list?', $q->br(), $q->textfield(-name=>'list_name', -value=>$list_info{list_name}, -size=>30)); print '

You need to give a valid e-mail address for the list owner

' if $flags->{invalid_list_owner_email} == 1; print $q->p('What e-mail address corresponds to the list owner? When e-mails are sent, they are sent using this address.', $q->br(), $q->textfield(-name=>'list_owner_email', -value=>$list_info{list_owner_email}, -size=>30)), $q->p($q->i($q->b('optional')), 'What e-mail address corresponds to the list administrator?, All e-mail errors will be sent to this address, instead of the list owner. If left, blank, this job will be left to the list owner, which might be just fine for you.', $q->br(), $q->textfield(-name=>'admin_email', -value => $list_info{admin_email}, -size=>30)); print '

You need to give your list a description.

' if $flags->{list_info} == 1; print $q->p("Description of $list_info{list_name}", $q->br(), $q->textarea(-name => 'info', -value => $list_info{info}, -cols => 33, -rows => 4, -wrap => 'VIRTUAL',)); print '

You need to give your list a privacy policy.

' if $flags->{privacy_policy} == 1; print $q->p('Please write a small privacy policy for your list. Some people don\'t subscribe to lists because they fear their e-mail addresses will be used for spamming purposes.', $q->br(), $q->textarea(-name => 'privacy_policy', -value => $list_info{privacy_policy}, -cols => 33, -rows => 4, -wrap => 'VIRTUAL',)); print '

You need to give your list a physical address.

' if $flags->{physical_address} == 1; print $q->p('What is the physical address associated with this mailing list?', $q->br(), $q->textarea(-name => 'physical_address', -value => $list_info{physical_address}, -cols => 33, -rows => 4, -wrap => 'VIRTUAL',)); print submit_form(); print qq{

\ 

[?] Change List Information

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); }else{ my ($list_errors, $list_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', ); if ($list_errors >= 1){ undef $process; change_info($list_errors, $list_flags); }else{ $admin_email = $list_owner_email if ($admin_email eq ""); my %new_info = (list_owner_email => $list_owner_email, admin_email => $admin_email, list => $list, list_name => $list_name, info => $info, privacy_policy => $privacy_policy, physical_address => $physical_address, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=change_info&done=1"); } } } sub change_password { # a few variables my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'change_password'); require DADA::Security::Password; $list = $admin_list; my %list_info = open_database(-List => $list, ); unless(defined($process)) { print(admin_html_header(-Title => "Change List Password", -List => $list_info{list}, -Root_Login => $root_login)); print $q->p('After you have changed your password, you will need to log back into this list\'s control panel.'); print $q->hidden('flavor', 'change_password'), $q->hidden('process', 'true'), $q->hidden('list', $list); if($root_login != 1){ print $q->p('Enter your old password:',$q->br(), $q->password_field('old_password')); } print $q->p('Enter your new password:', $q->br(), $q->password_field('new_password')), $q->p('Re-enter your new password:', $q->br(), $q->password_field('again_new_password')), submit_form(-Submit=>'Change Password'); print qq{

\ 

[?] Change Your Password

} if $SHOW_HELP_LINKS == 1; 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){ #check if the old password checks out, if it doesn't, throw an error my $password_check = DADA::Security::Password::check_password($list_info{password},$old_password); user_error(-List => $list, -Error => "invalid_password") if ($password_check != 1); } #check to see if the new password is the same when typed twice. $new_password = strip($new_password); $again_new_password = strip($again_new_password); user_error(-List => $list, -Error => "pass_no_match") if ($new_password ne $again_new_password) || ($new_password eq ""); my $new_encrypt_pass = DADA::Security::Password::encrypt_passwd($new_password); my %new_info = ( list => $list, password => $new_encrypt_pass ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=admin"); } } sub delete_list { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'delete_list' ); my $list = $admin_list; my %list_info = open_database(-List => $list); my $password_check = DADA::Security::Password::check_password($admin_password, $list_info{password}); unless (defined($process)){ print(admin_html_header( -Title => "Confirm Delete List", -List => $list_info{list}, -Root_Login => $root_login)); print $q->p("Are you sure you want to totally delete this list?"), $q->p("This will delete the list and cannot be undone."), $q->hidden('flavor', 'delete_list'), $q->hidden('process', 'true'); print $q->p($q->checkbox( -name => 'delete_backups', -value => 1, -label => 'Delete List Backups', -checked => 'checked', )); print ""; print(admin_html_footer(-List => $list)); }else{ require DADA::MailingList::Archives; my $ls = DADA::MailingList::Settings->new(-List => $list); my $la = DADA::MailingList::Archives->new(-List => $ls->get); 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_list_info( -List => $list); $la->delete_all_archive_entries(); delete_list_archive( -List => $list); 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}; print(the_html(-Part => "header", -Title => "Deletion Successful")); print $q->p("You have deleted the list."); print $q->p("Return to the $PROGRAM_NAME main page."); print(the_html(-Part => "footer")); } } sub list_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'list_options' ); #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 $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 $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 $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 $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 $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 $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 $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 $use_alt_url_unsub_failed = $q->param("use_alt_url_unsub_failed") || 0; my $alt_url_unsub_failed = $q->param( "alt_url_unsub_failed") || ''; unless(defined($process)){ $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header( -Title => "Mailing List Options", -List => $list_info{list}, -Root_Login => $root_login )); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print $q->p($q->b('General')); print "\n"; print "\n"; print "\n"; print "\n"; print "
"; print "

\n"; print "		"; print "

Hide Your List
"; print "This list will not be listed on the $PROGRAM_NAME main screen. "; print "This list will still have a list page and "; print " people will still be able to subscribe/unsubscribe with the proper information.

You will also have to manually enter this"; print " list's shortname when logging onto the list control panel.

"; print "
"; print "\n"; print ""; print "

Close Your List
"; print "No one will be allowed to subscribe to this list, subscribers can only be added via "; print "from the administration control panel."; print "People can still unsubscribe at any time"; print "

"; print "\n"; print ""; print "

Lookup Hostnames When Validating Email Addresses. (mx lookup)
"; print "When an email address is submitted to be validated, the domain of the address will be checked for its existance. "; print "

"; print $q->p(' '); print $q->p($q->b('Subscription Confirmations')); print "\n"; print "\n"; print "\n"; print "\n"; print '
"; print "\n"; print ""; print "

Send Subscription Confirmation Emails (Double Opt-In)
"; print "Subscribers will have to reply to a confirmation e-mail sent to their address. "; print " STRONGLY recommended.

"; print "
"; print "\n"; print ""; print "

If submission for subscription confirmation is successful, redirect to this URL:
"; print "    

"; print "
"; print "\n"; print ""; print "

If submission for subscription confirmation failed, redirect to this URL:
"; print "    

"; print "
'; print $q->p(' '); print $q->p($q->b('Subscriptions')); print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print '
"; print "\n"; print ""; print "

Receive Subscription Notices
"; print "Be notified every time someone subscribes to your list with a short email."; print "

"; print "\n"; print ""; print "

Send Subscription Successful Emails
"; print "After a person subscribes, an email will be sent to announce the subscription.

"; print "
"; print "\n"; print ""; print "

If a subscription is successful, redirect to this URL:
"; print "    

"; print "
"; print "\n"; print ""; print "

If a subscription failed, redirect to this URL:
"; print "    

"; print "
'; print $q->p(' '); print $q->p($q->b('Unsubscription Confirmations')); print "\n"; print "\n"; print "\n"; print "\n"; print "
"; print "\n"; print ""; print "

Send Unsubscription Confirmation Emails (Double Opt-Out)"; print "

"; print "
"; print "\n"; print ""; print "

If submission for unsubscription confirmation is successful, redirect to this URL:
"; print "    

"; print "
"; print "\n"; print ""; print "

If submission for unsubscription confirmation failed, redirect to this URL:
"; print "    

"; print "
"; print $q->p(' '); print $q->p($q->b('Unsubscriptions')); print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "
"; print "\n"; print ""; print "

Receive Unsubscription Notices
"; print "Be notified every time someone unsubscribes to your list with a short e-mail"; print "

"; print "\n"; print ""; print "

Send Unsubscription Successful Emails
"; print "After a person unsubscribes, an email will be sent to announce the unsubscription.

"; print "
"; print "\n"; print ""; print "

If an unsubscription is successful, redirect to this URL:
"; print "    

"; print "
"; print "\n"; print ""; print "

If an unsubscription failed, redirect to this URL:
"; print "    

"; print "
"; print $q->hr(); print ""; print ""; print submit_form(-Submit=>'Save List Options'); print qq{

\ 

[?] Mailing List Options

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, 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, use_alt_url_sub_confirm_success => $use_alt_url_sub_confirm_success, alt_url_sub_confirm_success => $alt_url_sub_confirm_success, use_alt_url_sub_confirm_failed => $use_alt_url_sub_confirm_failed, alt_url_sub_confirm_failed => $alt_url_sub_confirm_failed, use_alt_url_sub_success => $use_alt_url_sub_success, alt_url_sub_success => $alt_url_sub_success, use_alt_url_sub_failed => $use_alt_url_sub_failed, alt_url_sub_failed => $alt_url_sub_failed, use_alt_url_unsub_confirm_success => $use_alt_url_unsub_confirm_success, alt_url_unsub_confirm_success => $alt_url_unsub_confirm_success, use_alt_url_unsub_confirm_failed => $use_alt_url_unsub_confirm_failed, alt_url_unsub_confirm_failed => $alt_url_unsub_confirm_failed, use_alt_url_unsub_success => $use_alt_url_unsub_success, alt_url_unsub_success => $alt_url_unsub_success, use_alt_url_unsub_failed => $use_alt_url_unsub_failed, alt_url_unsub_failed => $alt_url_unsub_failed, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=list_options&done=1"); } } sub sending_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'sending_options' ); $list = $admin_list; my %list_info = open_database(-List => $list, ); #a few variables 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; unless(defined($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, $list_info{bulk_send_amount}) if exists($list_info{bulk_send_amount}); my @message_wait = (1..60); unshift(@message_wait, $list_info{bulk_send_seconds}) if exists($list_info{bulk_send_seconds}); my @message_label = (1, 60, 3600); my %label_label = (1 => 'seconds', 60 => 'minutes', 3600 => 'hours', 86400 => 'days'); unshift(@message_label, $list_info{bulk_send_seconds_label}) if exists($list_info{bulk_send_seconds_label}); print(admin_html_header( -Title => "Sending Options", -List => $list_info{list}, -Root_Login => $root_login)); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print $q->p("$PROGRAM_NAME is able to send its bulk mailings in \"batches\", allowing you, to send to a fairly large list without browser timeouts, or your mail program, complaining about too many messages being sent at once."), $q->p("$PROGRAM_NAME will send as many individual messages as you specify., After that mailing is over it will wait the amount of time you set before it sends out its next batch., This pattern will repeat until all subscribers receive a copy of your message."); print ""; print ""; print "
"; print "\n"; print ""; print "

Send E-mail Using SMTP send all e-mail from $PROGRAM_NAME using a straight SMTP connection "; print " instead of through a mail program such as sendmail.

"; print "

Warning! No SMTP Server has been set!

" if((!$list_info{smtp_server}) && ($list_info{send_via_smtp} eq "1")); print "

Warning! SMTP cannot be used. Your version of Perl (" . $] . ") is not up to date.

" if $] < 5.006; print "

SMTP settings...

"; print "
"; print "\n"; print ""; print "

Enable Batch Sending You must enable batch sending for batch sending to start working."; print "Lists under 100 people may not need it at all.

"; print "
"; print "
"; print ""; print $q->Tr($q->td([$q->p("Send"), $q->p($q->popup_menu( -name => "bulk_send_amount", -value => [@message_amount], )), $q->p("Messages")])); print $q->Tr($q->td([$q->p("Every"), $q->p($q->popup_menu( -name => "bulk_send_seconds", -value => [@message_wait], )), $q->p($q->popup_menu( -name => "bulk_send_seconds_label", -value => [@message_label], -labels => \%label_label, ))])); print "
"; print "
"; print ""; print "
"; print "\n"; print ""; print "

Receive Batch Confirmations Receive notices by e-mail every time"; print " a batch is complete. You'll be told what batch $PROGRAM_NAME is on and "; print " how many people have received your message so far.

"; print "
"; print ""; print "
"; print "\n"; print ""; print "

Receive Finishing Message Receive notice by e-mail when $PROGRAM_NAME has sent all your list messages.

"; print "
"; print "

Advanced ...

\n"; print ""; print ""; print submit_form(-Submit=>'Save Sending Options'); print qq{

\ 

[?] Sending Options

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); }else{ my $bulk_sleep_amount = $bulk_send_seconds * $bulk_send_seconds_label; $list = $admin_list; my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, 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, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=sending_options&done=1"); } } sub adv_sending_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'sending_options' ); $list = $admin_list; my %list_info = open_database(-List => $list, ); #a few variables 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 $use_habeas_headers = $q->param('use_habeas_headers') || 0; unless(defined($process)){ print(admin_html_header( -Title => "Advanced Sending Options", -List => $list_info{list}, -Root_Login => $root_login)); print $GOOD_JOB_MESSAGE if(defined($done)); unshift(@CHARSETS, $list_info{charset}); print $q->table({-cellpadding => 5}, $q->Tr($q->td([$q->p($q->b('Default Precedence of Bulk Mailings')), $q->p($q->popup_menu( -name => "precedence", -value => [@PRECEDENCES], -default => $list_info{precedence} ))])), $q->Tr($q->td([$q->p($q->b('Default Priority of Bulk Mailings')), $q->p($q->popup_menu( -name => "priority", -value => [keys %PRIORITIES], -labels => \%PRIORITIES, -default => $list_info{priority} ))])), $q->Tr($q->td([$q->p($q->b('Default Character Set of Mailings')), $q->p($q->popup_menu( -name => 'charset', -value => [@CHARSETS], ))])), $q->Tr( $q->td([ $q->p( $q->b('Default PlainText Message Encoding')), $q->p($q->popup_menu( -name => 'plaintext_encoding', -value => [@CONTENT_TRANSFER_ENCODINGS], -default => $list_info{plaintext_encoding}, ) )])), $q->Tr( $q->td([ $q->p( $q->b('Default HTML Message Encoding')), $q->p($q->popup_menu( -name => 'html_encoding', -value => [@CONTENT_TRANSFER_ENCODINGS], -default => $list_info{html_encoding}, ) )])), $q->Tr($q->td([$q->p($q->b('Default Content Type of Mailings')), $q->p($q->popup_menu( -name => 'content_type', -value => [@CONTENT_TYPES], -default => $list_info{content_type} ))])), ); print ""; print "'; print "'; print "'; print "'; print "'; print "'; print "

"; print "\n"; print "

"; print "Send all e-mails with only the address in the 'To' and 'From' message headers
"; print "Some SMTP servers get confused when 'To:' and 'From:' mail headers contain both the address and name
(example: "John Smith" <johm\@smith.com>)
"; print "All messages sent will only contain the actual address
(example: john\@smith.com)

"; print '

"; print "\n"; print "

"; print "Print list-specific headers in all list emails
"; print "List-specific headers store information on how to subscribe and unsubscribe from a list, as well as other list specific information, in the header of the email."; print " It is highly advised to take advantage of these headers.

"; print '

"; print "\n"; print "

"; print qq{Add the Sendmail '-f' flag when sending messages, using $MAILPROG
Sometimes the Return-Path header, useful when dealing with bounced emails, will not get set correctly. To fix this, messages will be sent with the '-f' flag and the admin email:

$MAIL_SETTINGS -f $list_info{admin_email}

}; print "

Warning! Your effective uid is not the same as your real uid; using this option may break mail sending.

" if $< != $>; print '

"; print "\n"; print "

"; print qq{Print the 'Errors-To' header in all list emails
The 'Errors-To' header is used to tell mail servers where to direct a message when an error in delivery occurs. This header has been deprecated

}; print '

"; print "\n"; print "

"; print qq{Print the 'Return-Path header in all list emails
The 'Return-Path' header works much like setting the '-f' flag. Alternatives to Sendmail (like Qmail) allow you to use the Return-Path header.

}; print '

"; print "\n"; print "

"; print qq{Use the Habeas Warrant Mark
Warning!:Use of the Habeas Water Mark must be in accordance with a license from Habeas (see http://www.habeas.com for details).

"Habeas SWE" is or is part of a trademark of Habeas, Inc., 3045 Park Blvd., Palo Alto, CA 94306

}; print '

"; print $q->hidden('process', 'true'); print $q->hidden('list', $list); print $q->hidden('flavor', 'adv_sending_options'); print submit_form(); print $q->p({-align=>'right'}, $q->b($q->a({-href=>"$S_PROGRAM_URL?flavor=sending_options"},'Basic...'))); print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; my %list_info = open_database(-List => $list,); my %new_info = ( 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, use_habeas_headers => $use_habeas_headers, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=adv_sending_options&done=1"); } } sub list_security { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'list_security'); $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header( -Title => "SMTP Sending Options", -List => $list_info{list}, -Root_Login => $root_login)); print "hello."; print(admin_html_footer(-List => $list)); } sub smtp_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'smtp_options'); require DADA::Security::Password; $list = $admin_list; my %list_info = open_database(-List => $list); if(!$process){ print(admin_html_header( -Title => "SMTP Sending Options", -List => $list_info{list}, -Root_Login => $root_login)); print $GOOD_JOB_MESSAGE if(defined($done)); print ''; print $q->Tr($q->td([($q->p($q->b('SMTP Server:'))), ($q->p($q->textfield(-name=>'smtp_server', -value=>$list_info{smtp_server}, -size=>30 )))])); print $q->Tr($q->td([($q->p($q->b('Port:'))), ($q->p($q->textfield(-name=>'smtp_port', -value=>$list_info{smtp_port}, -size=>5 )))])); print $q->Tr($q->td([($q->p($q->b('Connection Tries:'))), ($q->p($q->textfield(-name=>'smtp_connect_tries', -value=>$list_info{smtp_connect_tries}, -size=>2 )))])); print '
'; print $q->hr(); print ''; print "
"; print '\n"; print ""; print "

Use SMTP Authentication (SASL)"; print $q->table({-border => 0}, $q->Tr( $q->td([ ( $q->p('username: '), $q->textfield( -name => 'sasl_smtp_username', -value => $list_info{sasl_smtp_username}, -size => 30 ), ) ])), $q->Tr( $q->td([ ( $q->p('password: '), $q->password_field( -name => 'sasl_smtp_password', -value => DADA::Security::Password::cipher_decrypt($list_info{cipher_key}, $list_info{sasl_smtp_password}), -size => 30 ), ) ])) ); print "

"; print $q->hr(); print ""; print "
"; print "\n"; print ""; print "

Use POP-before-SMTP Authentication"; print "
A connection to your POP Server will be created before any mail will be sent. "; print "This can authenticate your outgoing mail requests, if your SMTP server uses POP-before-SMTP or your SMTP server does not use SASL.

"; print $q->p("POP-before-SMTP Authentication will require your username and password for your POP3 Account:"); print $q->table({-border => 0}, $q->Tr( $q->td([ ( $q->p('POP3 server: '), $q->textfield( -name => 'pop3_server', -value => $list_info{pop3_server}, -size => 30 ), ) ])), $q->Tr( $q->td([ ( $q->p('POP3 username: '), $q->textfield( -name => 'pop3_username', -value => $list_info{pop3_username}, -size => 30 ), ) ])), $q->Tr( $q->td([ ( $q->p('POP3 password: '), $q->password_field( -name => 'pop3_password', -value => DADA::Security::Password::cipher_decrypt($list_info{cipher_key}, $list_info{pop3_password}), -size => 30 ), ) ])) ); print $q->p({-align => 'right'}, $q->button( -value => 'Test POP-before-SMTP settings', -style => $STYLE{yellow_submit}, -onClick => 'javascript:testPOPBeforeSMTP();', ) ); print "
"; print $q->hr(); print ""; print "
"; print "\n"; print ""; print "

Set the Sender of SMTP mailings to the list administration email address"; print "
This will ultimately set the 'Return-Path' email header to the list administration email address ($list_info{admin_email}), and bounced messages will return to that address. Otherwise, they will go to the list owner."; print "

"; print "
"; print $q->hidden('process', 'true'); print $q->hidden('list', $list); print $q->hidden('flavor', 'smtp_options'); print $q->hr(); print submit_form(); 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 $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 %ni = ( list => $list_info{list}, smtp_port => $q->param('smtp_port'), smtp_connect_tries => $q->param('smtp_connect_tries'), use_pop_before_smtp => $use_pop_before_smtp, smtp_server => $smtp_server, pop3_server => $pop3_server, pop3_username => $pop3_username, pop3_password => DADA::Security::Password::cipher_encrypt($list_info{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($list_info{cipher_key}, $sasl_smtp_password), set_smtp_sender => $set_smtp_sender, ); my $status = setup_list(\%ni); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=smtp_options&done=1"); } } sub checkpop { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'dada_send_options', ); $list = $admin_list; require DADA::Security::Password; my $user = $q->param('user'); my $pass = $q->param('pass'); my $server = $q->param('server'); my %list_info = open_database(-List => $list); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); 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 dada_send_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'dada_send_options'); $list = $admin_list; my %list_info = open_database(-List => $list); #a few variables my $group_list = $q->param('group_list') || 0; my $allow_group_interpolation = $q->param('allow_group_interpolation') || 0; my $only_allow_group_plain_text = $q->param('only_allow_group_plain_text') || 0; my $append_list_name_to_subject = $q->param('append_list_name_to_subject') || 0; my $mail_group_message_to_poster = $q->param('mail_group_message_to_poster') || 0; my $add_reply_to = $q->param('add_reply_to') || 0; unless(defined($process)){ print(admin_html_header( -Title => "Group Options", -List => $list_info{list}, -Root_Login => $root_login)); print $GOOD_JOB_MESSAGE if(defined($done)); print $q->p("You can use the dada_send.pl to send e-mails using your mail reader, such as Outlook or Eudora. dada_send.pl can also be used to set up group lists, where everyone on your list will be able to send to everyone else on your list, using a special address"), $q->p("Please be sure that dada_send.pl is properly installed before you use it!"), $q->table( $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'group_list', -value => 1, -label=>'', (($list_info{group_list} eq "1") ? (-checked=>'ON') : (-checked=> 0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(0)', -class=>'black'}, 'Make Your List a Group List')), $q->br(), 'Everyone subscribed to your list can send to e-mails to everyone else on your list.')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'allow_group_interpolation', -value => 1, -label=>'', (($list_info{allow_group_interpolation} eq "1") ? (-checked=>'ON') : (-checked=>0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(1)', -class=>'black'}, 'Allow Variable Interpolation In Group Mailings')), $q->br(), "Variable Interpolation means that pseudo tags like this: [program_url] will be changed to what they really are ($PROGRAM_URL) ")) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'only_allow_group_plain_text', -value => 1, -label=>'', (($list_info{only_allow_group_plain_text} eq "1") ? (-checked=>'ON') : (-checked=>0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(2)', -class=>'black'}, 'Only Allow Plain Text Messages To Be Sent From Group Members')), $q->br(), 'Only e-mails seen as being plain text (no HTML) will be allowed to post to the group')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'append_list_name_to_subject', -value => 1, -label=>'', (($list_info{append_list_name_to_subject} ne "0") ? (-checked=>'ON') : (-checked=>0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(3)', -class=>'black'}, 'Add the list name to the subject of group mailings')), $q->br(), 'List messages will be sent out with the list name at the beginning of the message, surrounded by brackets. This helps subscribers with identifying an e-mail message that originates from your list.')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'add_reply_to', -value => 1, -label=>'', (($list_info{add_reply_to} ne "0") ? (-checked=>'ON') : (-checked=>0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(4)', -class=>'black'}, 'Automatically have replies to messages directed to the group')), $q->br(), 'A \'Reply-To\' header will be added to group list mailings that will direct replys to list messages back to the list.')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'mail_group_message_to_poster', -value => 1, -label=>'', (($list_info{mail_group_message_to_poster} ne "0") ? (-checked=>'ON') : (-checked=>0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(5)', -class=>'black'}, 'Send Posters Their Own Message')), $q->br(), 'People who post messages to the list will receive their own email messages.')) ]) ), ); print $q->hidden('flavor','dada_send_options'), $q->hidden('process','true'); print submit_form(); print qq{

\ 

[?] Group Options

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; my %list_info = open_database(-List => $list,); my %new_info = ( list => $list, group_list => $group_list, allow_group_interpolation => $allow_group_interpolation, only_allow_group_plain_text => $only_allow_group_plain_text, append_list_name_to_subject => $append_list_name_to_subject, mail_group_message_to_poster => $mail_group_message_to_poster, add_reply_to => $add_reply_to, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=dada_send_options&done=1"); } } sub view_list { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'view_list', ); $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $start = $q->param('start') || 0; my $length = $list_info{view_list_subscriber_number}; #$q->param('length') || 100; print(admin_html_header( -Title => "Your Subscribers", -List => $list_info{list}, -Root_Login => $root_login)); print $q->end_form(); my $num_subscribers = $lh->num_subscribers; my $screen_finish = $length+$start; $screen_finish = $num_subscribers if $num_subscribers < $length+$start; my $screen_start = $start; $screen_start = 1 if (($start == 0) && ($num_subscribers != 0)); if($q->param('delete_email_count')){ print $q->p({-class => 'smallred'}, $q->param('delete_email_count') . ' address(es) have been unsubscribed.'); } if($q->param('email_count')){ print $q->p({-class => 'smallred'}, $q->param('email_count') . ' address(es) have been subscribed.'); } print '
'; print $q->p('Subscribers ', $q->b($screen_start), ' to ' . $q->b(($screen_finish))); print ''; print $q->p({-align => 'right'}, 'Total number of subscribers: ', $q->b($num_subscribers), $q->a({-href => $S_PROGRAM_URL . '?f=add'}, 'add...')); print '
'; print ''; print '' if($start-$length) >= 0 ; print '' if($num_subscribers > ($start + $length)); print '

<- previous ' . $length . '

next '. $length . '->

'; print '
'; print $q->start_form(-action => $S_PROGRAM_URL, -method => 'post', -name => 'email_form'); # style="border: 1px solid black" print ''; print $q->Tr( $q->td([ ($q->p(' ')), ($q->p($q->b('Email'))), ]), ); #{-style=> 'border:1px solid black'}, my $subscribers = $lh->subscription_list(-start => $start, '-length' => $length); foreach(@$subscribers){ print $q->Tr( $q->td([ (delete_checkbox($_->{email})), ($q->p(edit_subscriber_link($_->{email}))), ]), ); } print '
'; print $q->p(' '); print $q->p(' '); print '
'; print ''; print '' if($start-$length) >= 0 ; print '' if($num_subscribers > ($start + $length)); print '

<- previous ' . $length . '

next '. $length . '->

'; print "

check all :: uncheck all

"; print ""; print ""; print qq{

}; print ''; print qq{

Search List For a Particular Address:

}; print qq{
}; print $q->p({-align => 'right'}, $q->b($q->a({-href => $S_PROGRAM_URL . '?f=view_list_options'}, 'View Options...'))); print qq{

\ 

[?] Manage Subscribers: View

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); } sub view_list_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'view_list_options', ); my @list_amount = (10,25,50,100,150,200,250,300,350,400,450,500,550,600,650,700,750,800,850,900,950,1000); $list = $admin_list; require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings->new(-List => $list); my $list_info = $ls->get; if($process == 1){ $ls->save({view_list_subscriber_number => $q->param('view_list_subscriber_number')}); print $q->redirect(-uri => $S_PROGRAM_URL . '?f=view_list_options&done=1'); } print(admin_html_header( -Title => "View List Options", -List => $list_info->{list}, -Root_Login => $root_login)); print $GOOD_JOB_MESSAGE if $q->param('done') == 1; print $q->p('Show', $q->popup_menu(-name => 'view_list_subscriber_number', -values => [ @list_amount], -default => $list_info->{view_list_subscriber_number}), 'subscribers at one time'), $q->hidden('f', 'view_list_options'), $q->hidden('process', 1); print submit_form(); print $q->p($q->a({-href => $S_PROGRAM_URL . '?f=view_list'}, '<- View Subscription List')); print(admin_html_footer(-List => $list)); } sub edit_subscriber { print $q->redirect(-uri => $S_PROGRAM_URL . '?f=view_list') if ! $email; my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'edit_subscriber', ); $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); print $q->redirect(-uri => $S_PROGRAM_URL . '?f=view_list&error=no_such_address') if($lh->check_for_double_email(-Email => $email) == 0); if($process eq 'edit'){ my $edit_email = $q->param('edit_email'); my ($status, $errors) = $lh->subscription_check(-Email => $edit_email); if($errors->{invalid_email} == 1){ print $q->redirect(-uri => $S_PROGRAM_URL . '?f=edit_subscriber&email='.$email.'&error=invalid_email') }elsif(($errors->{subscribed} == 1) && ($email ne $edit_email)){ print $q->redirect(-uri => $S_PROGRAM_URL . '?f=edit_subscriber&email='.$email.'&error=email_subscribed') }else{ $lh->remove_from_list(-Email_List => [$email]); $lh->add_to_email_list(-Email_Ref => [$edit_email]); print $q->redirect(-uri => $S_PROGRAM_URL . '?f=edit_subscriber&email='.$edit_email.'&success=1'); } }else{ print(admin_html_header( -Title => "Edit Subscriber", -List => $list_info{list}, -Root_Login => $root_login)); print $GOOD_JOB_MESSAGE if $q->param('success') == 1; print '

The email address you typed is invalid.

' if $q->param('error') eq 'invalid_email'; print '

The email address you typed is already subscribed.

' if $q->param('error') eq 'email_subscribed'; print $q->p($q->b('email address: '), $q->textfield(-name => 'edit_email', -value => $email, -size => 30)); print $q->hidden(-name => 'email', -value => $email, -override=>1,); print $q->hidden(-name => 'f', -value => 'edit_subscriber', -override=>1); print $q->hidden(-name => 'process', -value => 'edit', -override=>1), $q->p({-align => 'right'}, $q->submit(-value => "Edit Information...", -style => $STYLE{yellow_submit})); print $q->end_form(); print $q->start_form(-action => $S_PROGRAM_URL, -method => 'POST'), $q->hidden('process', 'delete'), $q->hidden(-name => 'address', -value => $email), $q->hidden(-name => 'f', -value => 'checker', -override=>1), $q->p({-align => 'right'}, $q->submit(-value => "Delete Address", -style => $STYLE{red_submit})), $q->end_form(); print $q->p($q->a({-href => $S_PROGRAM_URL . '?f=view_list'}, '<- Back to Subscription List')); print qq{

Search List For a Particular Address:

}; print(admin_html_footer(-List => $list)); } } sub edit_subscriber_link { my $email = shift; return '' . $email . ''; } sub delete_checkbox { my $email = shift; return $q->checkbox(-name => 'address', -value => $email, -label => ''); } sub list_stats { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'list_stats', ); # view whos on the list, add delete addresses $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); print(admin_html_header( -Title => "Subscriber Statistics", -List => $list_info{list}, -Root_Login => $root_login)); print "

\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 <E-mail addresses sorted by Top Level Domains, click on the particular domain to view the list of e-mails from that top level domain

EOF ; my @keys = sort(keys %$domains_ref); foreach $key (@keys){ if($key !~ m/Other/i){ $value = $domains_ref -> {$key}; my $percentage; if($everyone > 0){ $percentage = ($value * 100)/$everyone; }else{ $percentage = 0; } $percentage= sprintf("%.2f", $percentage); print $q->Tr($q->td({-bgcolor=>'#FFFFFF'},[ $q->a({href=>"$S_PROGRAM_URL?flavor=search_email&method=domain&keyword=.$key"},$key), $value, "$percentage\%" ])); # now, find what "other" is } } $value = $domains_ref -> {Other}; my $percentage; if($everyone > 0){ $percentage = ($value * 100)/$everyone; }else{ $percentage = 0; } $percentage= sprintf("%.2f", $percentage); print $q->Tr($q->td({-bgcolor=>'#FFFFFF'},[ 'Other', $value, "$percentage\%" ])); print <
Domain Number Percent

 

EOF ; } if($SHOW_SERVICES_TABLE==1){ my $skey; my $svalue; my $using; my @skeys = sort(values %SERVICES); print $q->p("E-mail address sorted by popular E-mail or ISP Services, click on a service to see the list of e-mails from that particular service"); print <
EOF ; %SERVICES = reverse(%SERVICES); foreach $skey (@skeys){ $svalue = $count_services_ref->{$skey} || 0; my $spercentage; if($everyone > 0){ $spercentage = ($svalue * 100)/$everyone; }else{ $spercentage = 0; } $spercentage= sprintf("%.2f", $spercentage); if($SERVICES{$skey} !~ m/Other/i){ print $q->Tr($q->td({-bgcolor=>'#FFFFFF'},[ $q->a({href=>"$S_PROGRAM_URL?flavor=search_email&method=service&keyword=$skey"},$SERVICES{$skey}), $svalue, "$spercentage\%" ])); } } $svalue = $count_services_ref -> {Other}; my $spercentage; if($everyone > 0){ $spercentage = ($svalue * 100)/$everyone; }else{ $spercentage = 0; } $spercentage= sprintf("%.2f", $spercentage); print $q->Tr($q->td({-bgcolor=>'#FFFFFF'},[ 'Other', $svalue, "$spercentage\%" ])); print <
Service Number Percent

 

EOF ; print qq{

\ 

[?] Statistics

} if $SHOW_HELP_LINKS == 1; } }else{ print $NO_ONE_SUBSCRIBED; } print(admin_html_footer(-List => $list)); } sub add { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'add' ); # view whos on the list, add delete addresses $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $num_subscribers = $lh->num_subscribers; print(admin_html_header( -Title => "Manage Additions", -List => $list_info{list}, -Root_Login => $root_login, -Form => 0)); if($list_info{use_subscription_quota} == 1){ if($num_subscribers >= $list_info{subscription_quota}){ print $q->p({-class => 'smallred'}, 'Warning! You are at or above the number of subscribers allowed ('.$list_info{subscription_quota}.')! You cannot add anymore subscribers.'); }else{ print $q->p({-class => 'smallred'}, 'You have a limit of '. $list_info{subscription_quota} .' total subscribers. You currently have '.$num_subscribers.' subscribers.'); } } unless(($list_info{use_subscription_quota} == 1) && ($num_subscribers >= $list_info{subscription_quota})){ print $q->p("To Add e-mails, enter the addresses below, separated by spaces, commas or carriage returns. Extemely large lists added (over 1000 addresses) may take a minute or two to process, so please exercise patience.

"); print $q->p($q->start_multipart_form(-action=>$S_PROGRAM_URL, -method=>'POST', -name=>'default_form'), $q->hidden(-name =>'flavor', -value => 'add_email', -override=>1), $q->textarea(-name=>'new_emails', -cols=>40, -rows=>4), '
Skip Confirmation Screen'); print $q->p("Alternatively, import from a file containing the email addresses would like to be added to the list", $q->br(), $q->filefield(-name => 'new_email_file')); print ""; print $q->end_form(); print qq{

\ 

[?] Manage Subscribers: Add

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); } } sub add_email { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'add_email'); my %seen; $list = $admin_list; my %list_info = open_database( -List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); unless (defined($process)){ my $new_emails; my $email_file = $q->param('new_email_file'); if(DADA::App::Guts::strip($q->param("new_emails")) ne ""){ $new_emails = $q->param("new_emails"); }else{ if($email_file){ my $new_file = file_upload('new_email_file'); open(UPLOADED, "$new_file") or die $!; { local $/ = undef; $new_emails = ; } close(UPLOADED); unlink($new_file) or warn "could not remove uploaded subscriber list, '$new_file': $!"; } } my @new_addresses = split(/\s+|,|;|\n+/, $new_emails); my @good_emails = (); my @bad_emails = (); my $invalid_email; foreach my $check_this_address(@new_addresses) { my $pass_fail_address = check_for_valid_email($check_this_address); if ($pass_fail_address >=1){ push(@bad_emails, $check_this_address); }else{ $check_this_address = lc_email($check_this_address); push(@good_emails, $check_this_address); } } %seen = (); my @unique_good_emails = grep { ! $seen{$_}++} @good_emails; %seen = (); my @unique_bad_emails = grep { ! $seen{$_}++} @bad_emails; @unique_good_emails = sort(@unique_good_emails); @unique_bad_emails =sort(@unique_bad_emails); # figure out what unique emails we have from the new list when compared to the old list my ($unique_ref, $not_unique_ref) = $lh->unique_and_duplicate(-New_List => \@unique_good_emails, -List => $list); #initialize my @black_list; my $found_black_list_ref; my $clean_list_ref; my $black_listed_ref; my $black_list_ref; if($list_info{black_list} eq "1"){ #open the black list $black_list_ref = $lh->open_email_list( -List => $list, -Type => "black_list", -As_Ref=>1); # now, from that new list of clean emails, see which ones are black listed ($found_black_list_ref) = $lh->get_black_list_match($black_list_ref, $unique_ref); #now, tell me which ones still are ok. ($clean_list_ref, $black_listed_ref) = $lh->find_unique_elements($unique_ref, $found_black_list_ref); }else{ $clean_list_ref = $unique_ref; } my $num_subscribers = $lh->num_subscribers; # *whew* # if((($num_subscribers + $#$clean_list_ref) >= $list_info{subscription_quota}) && ($list_info{use_subscription_quota} == 1)){ $quick = 'no'; } if($quick eq "yes"){ #my @address = $q -> param("address"); my $new_email_count=$lh->add_to_email_list(-Email_Ref => $clean_list_ref, -List => $list_info{list} ); print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=view_list&email_count=$new_email_count"); }else{ print(admin_html_header( -Title => "Verify Additions", -List => $list_info{list}, -Root_Login => $root_login)); unless( (($num_subscribers + $#$clean_list_ref) >= $list_info{subscription_quota}) && ($list_info{use_subscription_quota} == 1)){ print "
"; print""; print""; print $q->p("These addresses have passed verification. Click \"Subscribe Checked Emails\" to add these emails. Uncheck any email address you don't want added.")if(defined(@$unique_ref[0])); print <
EOF ; foreach(@$clean_list_ref){ print"   $_
\n"; } print <check all :: uncheck all

EOF ; if($list_info{black_list} eq "1"){ print $q->p("These addresses are Black Listed and won't be added unless they are checked
")if(defined(@$black_listed_ref[0])); foreach(@$black_listed_ref){ print "  ", $_, "
\n"; } } print $q->p("These addresses are already subscribed to $list_info{list_name}, so they won't be added again:
    ")if(defined(@$not_unique_ref[0])); foreach(@$not_unique_ref){ print "

  • ",$_,"

    • \n"; } print "
" if(defined(@$not_unique_ref[0])); print $q->p("These addresses did not go through validation successfully. Perhaps you typed them incorrectly? To correct, push your back button and enter again
    ")if(defined($unique_bad_emails[0])); foreach(@unique_bad_emails){ print "

  • ",$_,"

    • \n"; } print "
"if(defined($unique_bad_emails[0])); }else{ print $q->p({-class => 'smallred'}, 'Warning! You cannot subscribe all the addresses that you have submitted, since you will go over your subscription limit of ' .$list_info{subscription_quota} . ' subscribers. Please resubmit a smaller amount of addresses to subscribe. '); } print(admin_html_footer(-List => $list)); } }else { my @address = $q -> param("address"); my $new_email_count=$lh->add_to_email_list(-Email_Ref => \@address, -List => $list_info{list} ); print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=view_list&email_count=$new_email_count"); } } sub delete_email{ my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'delete_email' ); # view whos on the list, add delete addresses $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); #my $any_subscribers = -s "$FILES/$list.list"; # debug my $any_subscribers = 1; if($any_subscribers == 0){ print(admin_html_header( -Title => "Manage Deletions", -List => $list_info{list}, -Root_Login => $root_login )); print $NO_ONE_SUBSCRIBED; print(admin_html_footer(-List => $list)); } unless(defined($process)){ print(admin_html_header( -Title => "Manage Deletions", -List => $list_info{list}, -Root_Login => $root_login )); print '

To delete an e-mail, enter it into Your Delete List'; print 'You can also pick the e-mail from Your Subscription List (if available). Scroll through the e-mail addresses, select it and press Copy to Delete List>> .' if($SHOW_EMAIL_LIST ==1); print ' After you are finished, press Submit E-mail List

'; print <
EOF ; print $q->start_multipart_form(-action=>$S_PROGRAM_URL, -method=>'POST', -name=>'the_form'); if($SHOW_EMAIL_LIST ==1) { print '

Your Subscription List
'; print"

\n"; print "

"; }else{ print $q->p(' '); } print <

Your Delete List

Alternatively, use a file containing the email addresses you would like to be removed to the list.

EOF ; print $q->p($q->filefield(-name => 'delete_email_file')); print submit_form(-Reset=>'Re-Enter E-mail List',-Submit=>'Submit E-mail List'); print ' '; print <

You can also search for the address yourself, and delete the results of your search

Search List For a Particular Address:
EOF ; print qq{

\ 

[?] Manage Subscribers: Remove

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); }else{ # this is kinda like "add emails" but in reverse, instead of saying # that the email addresses are already in the list, # we say "oh, those are the ones you want to delete eh? ok. my @bad_emails; my @good_emails; my %seen=(); my $delete_list; my $delete_email_file = $q->param('delete_email_file'); if($delete_email_file){ my $new_file = file_upload('delete_email_file'); open(UPLOADED, "$new_file") or die $!; { local $/ = undef; $delete_list = ; } close(UPLOADED); }else{ $delete_list = $q->param('delete_list'); } my @delete_addresses = split(/\s+|,|;|\n+/, $delete_list); foreach my $check_this_address(@delete_addresses) { unless($check_this_address eq ""){ if ($check_this_address =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)/ || #Dude, This needs to be change pronto... # I know this is simple for optimization... but com'on... $check_this_address !~ /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)$/) { push(@bad_emails, $check_this_address); }else{ push(@good_emails, $check_this_address); } } } %seen = (); my @unique_good_emails = grep { ! $seen{$_}++} @good_emails; %seen = (); my @unique_bad_emails = grep { ! $seen{$_}++} @bad_emails; @unique_good_emails = sort(@unique_good_emails); @unique_bad_emails =sort(@unique_bad_emails); my ($unique_ref, $not_unique_ref) = $lh->unique_and_duplicate(-New_List => \@unique_good_emails, -List => $list, ); print(admin_html_header( -Title => "Verify Deletions", -List => $list_info{list}, -Root_Login => $root_login )); print "
"; print""; print ""; if(($list_info{black_list} eq "1") and ($list_info{add_unsubs_to_black_list} eq "1")){ print $q->hidden('add_to_black_list',1); } print $q->p("These addresses have passed verification, click the checkbox next to the address to delete it.:

")if(defined($not_unique_ref ->[0])); print <

EOF ; foreach(@$not_unique_ref){ print "   $_
\n" if(defined($not_unique_ref -> [0])); } print "

check all :: uncheck all

"; print < EOF ; # # # print $q->p("These addresses are not part of list at present, they may have already been deleted, or were never in the list.
    ")if(defined($unique_ref -> [0])); foreach (@$unique_ref){ print "

  • ",$_,"

    • \n"; } print "
" if(defined($unique_ref -> [0])); # # # print $q->p("These addresses did not go through validation successfully. Perhaps you typed them incorrectly? To correct, push your back button and enter again

")if(defined($unique_bad_emails[0])); foreach(@unique_bad_emails){ print "",$_,"
\n"; } print "

"if(defined($unique_bad_emails[0])); print(admin_html_footer(-List => $list)); } } sub black_list { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'black_list' ); my $black_list = $q->param("black_list"); # view whos on the list, add delete addresses $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); if($process eq "add"){ my $black_list_add = strip($q->param('black_list_add')); $black_list_add =~ s(/^\n+|\n+$)()g; if($black_list_add){ $lh->add_to_email_list(-List => $list, -Email_Ref => [$black_list_add], -Type => "black_list" ); } } if($process eq "delete"){ my $rm_status = $lh->remove_from_list( -List => $list, -Email_List => \@address, -Type => "black_list", ); #are these even relevant anymore? user_error(-List => $list, -Error => 'no_list') if $rm_status eq 'no list'; user_error(-List => $list, -Error => 'too_busy') if $rm_status eq 'too busy'; } if($process eq "switch"){ my %new_info = ( list => $list_info{list}, black_list => $black_list, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; $done = 1; $list_info{black_list} = $black_list; } if($process eq 'options'){ my $add_unsubs_to_black_list = $q -> param('add_unsubs_to_black_list') || 0; my $allow_blacklisted_to_subscribe = $q -> param('allow_blacklisted_to_subscribe') || 0; my $allow_admin_to_subscribe_blacklisted = $q -> param('allow_admin_to_subscribe_blacklisted') || 0; my %new_info = ( list => $list_info{list}, add_unsubs_to_black_list => $add_unsubs_to_black_list, allow_blacklisted_to_subscribe => $allow_blacklisted_to_subscribe, allow_admin_to_subscribe_blacklisted => $allow_admin_to_subscribe_blacklisted, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=black_list&done=1"); exit(); #huh? } print(admin_html_header( -Title => "Black List Rules", -List => $list_info{list}, -Root_Login => $root_login )); print $GOOD_JOB_MESSAGE if(defined($done)); print <A black list is like a set of rules that say who cannot subscribe to your list. You can disallow a single e-mail address by adding that e-mail address (you\@yours.com) to the black list.

You can also use the black list to match a part of an e-mail address, adding '.com' to the black list will disallow anyone that has '.com' in their e-mail address.

EOF ; print "

"; print ""; print" "; if($list_info{black_list} eq "1"){ print "

Black List Rules are active

"; print ""; print "

"; }else{ print "

Black List Rules are inactive

"; print ""; print "

"; } print "

\n"; print "
"; print "
"; my $black_list_ref = $lh->open_email_list(-List => $list, -Type => "black_list", -As_Ref=>1); print "
\n"; print <

Your Black List

EOF ; foreach(@$black_list_ref){ print"   $_
\n"; } print <

check all :: uncheck all
EOF ; print ""; print "

"; print ""; print ""; print ""; print <

EOF ; print "\n"; print "
"; print '

Black List Options

'; print "
"; print ""; print ""; print ""; print '

"; print "\n"; print "

"; print "Move e-mail addresses that have just been unsubscribed to the black list"; print "

"; print "\n"; print "

"; print "Allow past subscribers to subscribe again, even though they are black listed"; print "

"; print "\n"; print "

"; print "Allow administration to subscribe black listed e-mail addresses"; print "

'; print ''; print ''; print submit_form(); print qq{

\ 

[?] Black List Rules

} if $SHOW_HELP_LINKS == 1; print(admin_html_footer(-List => $list)); } sub subscription_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'subscription_options' ); $list = $admin_list; require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings->new(-List => $list); my $list_info = $ls->get; my @quota_values = qw(1 10 25 50 100 150 200 250 300 350 400 450 500 600 700 800 900 1000 1500 2000 2500 3000 3500 4000 4500 5000 5500 6000 6500 7000 7500 8000 8500 9000 9500 10000 11000 12000 13000 14000 15000 16000 17000 18000 19000 20000 30000 40000 50000 60000 70000 80000 90000 100000 200000 300000 400000 500000 600000 700000 800000 900000 1000000); my $html; if(!$process){ $html = admin_html_header(-Title => "Subscriber Options", -List => $list, -Root_Login => $root_login ); $html .= $GOOD_JOB_MESSAGE if(defined($done)); $html .= $q->table({-cellpadding => 5}, $q->Tr( $q->td([ ($q->p($q->checkbox(-name => 'use_subscription_quota', -value => 1, -label => '', (($list_info->{use_subscription_quota} == 1) ? (-checked => 'on',) : (-checked => 0 )), ) ), ($q->p( $q->strong( $q->a({-href => 'javascript:checklink(0)', -class => 'black'}, 'Limit The Number of Subscribers') ) ) )), ])), $q->Tr( $q->td([ ($q->p(' ')), ($q->p('Limit to:' . $q->popup_menu(-name => 'subscription_quota', '-values' => [@quota_values], -default => $list_info->{ subscription_quota}, ) . 'Subscribers')), ]))); $html .= $q->p(' '); $html .= $q->hidden('process', 'true'); $html .= $q->hidden('flavor', 'subscription_options'); $html .= submit_form(-Submit=>'Save Subscription Options'); $html .= admin_html_footer(-List => $list); print $html; }else{ my $use_subscription_quota = $q->param('use_subscription_quota') || 0; my $subscription_quota = $q->param( 'subscription_quota'); $ls->save({ use_subscription_quota => $use_subscription_quota, subscription_quota => $subscription_quota, }); print $q->redirect(-uri => $S_PROGRAM_URL . '?f=subscription_options&done=1'); } } sub view_archive { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'view_archive' ); $list = $admin_list; my %list_info = open_database(-List => $list); # let's get some info on this archive, shall we? require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives -> new(-List => \%list_info); my $entries = $archive -> get_archive_entries(); #ok, that's cool. #if we don't have nothin, print the index, unless(defined($id)){ #print header print(admin_html_header( -Title => "Manage Archives", -List => $list_info{list}, -Root_Login => $root_login)); # print the good stuff print"
"; print""; print"

Here is the list of the archived messages for $list_info{list_name}. To delete an entry, check it and press \"Delete Checked\"

"; print "
    \n"; #reverse if need be @$entries = reverse(@$entries) if($list_info{sort_archives_in_reverse} eq "1"); # print those mofo's my $entry; foreach $entry (@$entries){ my ($subject, $message, $format) = $archive -> get_archive_info($entry); my $pretty_subject = pretty($subject); print "

  1. $pretty_subject
    "; my $date = date_this( -Packed_Date => $entry, -Write_Month => $list_info{archive_show_month}, -Write_Day => $list_info{archive_show_day}, -Write_Year => $list_info{archive_show_year}, -Write_H_And_M => $list_info{archive_show_hour_and_minute}, -Write_Second => $list_info{archive_show_second}, ); print "Sent $date \n"; print "

    2. \n"; } #finish this off print "
\n"; print "

check all :: uncheck all

"; print ""; print $q->end_form(); print $q->start_form(-action => $S_PROGRAM_URL); print $q->hidden('f', 'edit_archive'); print $q->hidden('new_archive', 1); print ""; #done. print(admin_html_footer(-List => $list)); }else{ #check to see if $id is a real id key my $entry_exists = $archive -> check_if_entry_exists($id); user_error(-List => $list, -Error => "no_archive_entry")if($entry_exists <= 0); # if we got something, print that entry. print(admin_html_header( -Title => "Manage Archives", -List => $list_info{list}, -Root_Login => $root_login)); #get the archive info my ($subject, $message, $format) = $archive -> get_archive_info($id); $message = webify_plain_text($message) if($format !~ /HTML/i); my $pretty_subject = pretty($subject); print"

$pretty_subject

"; print"

$message

"; my $cal_date = date_this(-Packed_Date => $id, -All => 1); print <

Sent $cal_date

EOF ; my $nav_table = $archive -> make_nav_table(-Id => $id, -List => $list_info{list}, -Function => "admin"); print "
$nav_table
"; print(admin_html_footer(-List => $list)); } } sub delete_archive { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'delete_archive' ); $list = $admin_list; my @address = $q -> param("address"); my %list_info = open_database(-List => $list); # let's get some info on this archive, shall we? require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives -> new(-List => \%list_info); my $entries = $archive -> get_archive_entries(); #ok, that's cool. my $entry; #{ #local $| = 0; foreach $entry(@address){ my $exists = $archive -> check_if_entry_exists($entry); $archive -> delete_archive($entry) if($exists >= 1); } #} print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=view_archive"); } sub edit_archive { #security checks.. my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'edit_archive' ); my $archive_subject = $q->param("archive_subject"); my $archive_message = $q->param("archive_message"); my $archive_format = $q->param("archive_format"); my $new_archive = $q->param("new_archive"); $list = $admin_list; my %list_info = open_database(-List => $list); require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives->new(-List => \%list_info); my $entries = $archive -> get_archive_entries(); # what to do? if($process eq "true"){ # safe some information $archive_message =~ s/\r\n/\n/g; if($new_archive){ $id = sprintf("%02d", $q->param('year')) . sprintf("%02d", $q->param('month')) . sprintf("%02d", $q->param('day')) . sprintf("%02d", $q->param('hour')) . sprintf("%02d", $q->param('minute')) . sprintf("%02d", $q->param('second')); } #{ #local $| = 0; $archive->set_archive_info($id, $archive_subject, $archive_message, $archive_format); #} # and go print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=edit_archive&id=$id&done=1"); }else{ print(admin_html_header( -Title => "Archived Messages: Edit", -List => $list_info{list}, -Root_Login => $root_login )); print $GOOD_JOB_MESSAGE if(defined($done)); my $the_archive_subject = ""; my $the_archive_message = ""; my $the_archive_format = 'text/plain'; if(!$new_archive){ ($the_archive_subject, $the_archive_message, $the_archive_format) = $archive->get_archive_info($id); } print $q->p($q->b('Date:'), $q->br(), $q->popup_menu(-name => 'month', -value => [1..12]), '/', $q->popup_menu(-name => 'day', '-values' => [1..31]), '/', $q->popup_menu(-name => 'year', '-values' => [1980 .. 2100]), '-', $q->popup_menu(-name => 'hour', '-values' => [0..23]), ':', $q->popup_menu(-name => 'minute', '-values' => [0..59]), ':', $q->popup_menu(-name => 'second', '-values' => [0..59])) if $new_archive; print $q->p('Subject:
',$q->textfield(-size=>49,-name=>'archive_subject', -value=>$the_archive_subject)), $q->p('Message:
',$q->textarea(-name=>'archive_message', -value=>$the_archive_message, -rows=>20,-columns=>50)), $q->hidden('flavor','edit_archive'), $q->hidden('process','true'), $q->table($q->Tr($q->td([ $q->p('Treat this message as:'), $q->p($q->popup_menu(-name =>'archive_format', '-values' =>[$the_archive_format, 'HTML', 'Text'])), ]))); print $q->hr(); print $q->hidden('id',$id) if ! $new_archive; print $q->hidden('new_archive', 1) if $new_archive; if(! $new_archive){ print submit_form(-Submit => 'Edit Archived Message'); }else{ print submit_form(-Submit => 'Create New Archived Message'); } print $archive->make_nav_table(-Id => $id, -List => $list_info{list}, -Function => "admin") if ! $new_archive; $the_archive_message = webify_plain_text($the_archive_message) if($the_archive_format !~ /HTML/i); print $q->p('This Message currently appears as:'), $q->table({-width=>'100%',-border=>0, -cellpadding=>1, -cellspacing=>0,-bgcolor=>'#000000'}, $q->Tr($q->td( $q->table({-width=>'100%',-border=>0, -cellpadding=>5, -cellspacing=>0,-bgcolor=>'#FFFFFF'}, $q->Tr($q->td( $q->h3($the_archive_subject), $q->p($the_archive_message) ))) ))) if !$new_archive; print(admin_html_footer(-List => $list)); } } sub archive_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'archive_options' ); # a few variables... my $show_archives = $q->param('show_archives') || 0; my $archive_messages = $q->param('archive_messages') || 0; my $archive_subscribe_form = $q->param('archive_subscribe_form') || 0; my $archive_search_form = $q->param('archive_search_form') || 0; my $archive_send_form = $q->param('archive_send_form') || 0; unless(defined($process)){ $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header( -Title => "Archives Options", -List => $list_info{list}, -Root_Login => $root_login )); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print $q->table({-cellpadding=>5}, $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'archive_messages', -value => 1, -label=>'', (($list_info{archive_messages} ne "0") ? (-checked=>'ON') : (-checked=> 0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(0)', -class=>'black'}, 'Archive Your Messages')), $q->br(), 'Any messages already archived will still be available to your visitors')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'show_archives', -value => 1, -label=>'', (($list_info{show_archives} ne "0") ? (-checked=>'ON') : (-checked=> 0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(1)', -class=>'black'}, 'Display Your Archives')), $q->br(), 'Messages will still be archived unless you choose not to above. Archived messages will still be viewable in your control panel')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'archive_subscribe_form', -value => 1, -label=>'', (($list_info{archive_subscribe_form} ne "0") ? (-checked=>'ON') : (-checked=> 0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(2)', -class=>'black'}, 'Add a Subscription Form to the Archive Pages')), $q->br(), 'A subscription form will be added with the name of the list and the description of list at the bottom of every archive page.')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'archive_search_form', -value => 1, -label=>'', (($list_info{archive_search_form} eq "1") ? (-checked=>'ON') : (-checked=> 0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(3)', -class=>'black'}, 'Add a Search Form to the Archive Pages')), $q->br(), 'Allow your visitors to easily search through your list\'s archives')) ]) ), $q->Tr( $q->td({-valign=>'top'},[ ($q->checkbox(-name => 'archive_send_form', -value => 1, -label=>'', (($list_info{archive_send_form} eq "1") ? (-checked=>'ON') : (-checked=> 0)), )), ($q->p($q->b($q->a({-href=>'javascript:checklink(4)', -class=>'black'}, 'Add a "send this archive to a friend" form')), $q->br(), 'Visitors will be able to send archived messages they find interesting to friends')) ]) ), ); print $q->p({-align=>'right'},$q->a({-href =>"$S_PROGRAM_URL?flavor=adv_archive_options"}, 'Advanced...')); print "
"; print $q->hidden('process', 'true'), $q->hidden('flavor', 'archive_options'); print submit_form(-Submit=>'Change Archive Options'); print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, show_archives => $show_archives, archive_messages => $archive_messages, archive_subscribe_form => $archive_subscribe_form, archive_search_form => $archive_search_form, archive_send_form => $archive_send_form); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=archive_options&done=1"); } } sub adv_archive_options { my $root_login = check_list_security( -Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'adv_archive_options' ); my $sort_archives_in_reverse = $q->param('sort_archives_in_reverse') || 0; my $archive_show_year = $q->param('archive_show_year') || 0; my $archive_show_month = $q->param('archive_show_month') || 0; my $archive_show_day = $q->param('archive_show_day') || 0; my $archive_show_hour_and_minute = $q->param('archive_show_hour_and_minute') || 0; my $archive_show_second = $q->param('archive_show_second') || 0; my $archive_index_count = $q->param('archive_index_count') || 10; my $stop_message_at_sig = $q->param('stop_message_at_sig') || 0; my $publish_archives_rss = $q->param('publish_archives_rss') || 0; unless(defined($process)){ $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Archives Options", -List => $list_info{list}, -Root_Login => $root_login)); my @index_this=("$list_info{archive_index_count}",1..10,15,20,25,30,40,50,75,100); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print ""; print ""; print ""; print ""; print '"; print "

"; print "\n"; print "

"; print "

Show archive messages until the message signature
"; print "Archived messages will be displayed until double dashes ('--'), are reached in the message. This is a popular convention to clue systems that work with e-mail as to where the message stops and the signature begins.

"; print "

"; print " "; print "

"; print "

Sort Your Archives In:
"; print "Chronological Order
\n"; print "Reverse Chronological Order \n"; print "

"; print " "; print "

"; print "

Show Archive Dates With The:
"; print " Day (Wednesday)
\n"; print " Month (September)
\n"; print " Year (2000)
\n"; print " Hour and Minute (9:30)
\n"; print " Second (:59)
\n"; print "

 

'; print $q->table({-align=>'center',cellpadding=>1}, $q->Tr($q->td([$q->p('Show the archived message index ')])), $q->Tr($q->td([$q->p('with',$q->popup_menu(-name=>'archive_index_count', -value=>[@index_this], -style =>'font-family:arial;font-size:11px;'), 'links at a time') ]))); print "

"; print "\n"; print "

"; print "

Publish your archives index in RSS
"; print "The archive RSS is located here.

"; print "
"; print $q->p({-align=>'right'},$q->a({-href =>"$S_PROGRAM_URL?flavor=archive_options"}, 'Basic...')); print "
"; print $q->hidden('process', 'true'), $q->hidden('flavor', 'archive_options'); print submit_form(-Submit=>'Change Archive Options'); print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, stop_message_at_sig => $stop_message_at_sig, sort_archives_in_reverse => $sort_archives_in_reverse, archive_show_year => $archive_show_year, archive_show_month => $archive_show_month, archive_show_day => $archive_show_day, archive_show_hour_and_minute => $archive_show_hour_and_minute, archive_show_second => $archive_show_second, archive_index_count => $archive_index_count, publish_archives_rss => $publish_archives_rss, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error =>"no_permissions_to_write") if $status == 0; print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=adv_archive_options&done=1"); } } sub html_code { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'html_code'); $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Cut and Paste Code", -List => $list_info{list}, -Root_Login => $root_login)); print $q->p("You may change what the signup form will look like by typing what you want in the text boxes below. Click \"set\" to change the code in the main text box, click preview to see what it will look like."); print < EOF ; if($HTML_FOOTER){ print < EOF ; }else{ print ''; } print <

Copy the code in the text box and add it to any page on your site.

(will open a new window)

EOF ; print(admin_html_footer(-List => $list)); } sub edit_template { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'edit_template'); my $default_template = default_template($PROGRAM_URL); unless(defined($process)) { #set the _list $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Edit Your Template", -List => $list_info{list}, -Root_Login => $root_login)); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print qq{

$PROGRAM_NAME uses 'psuedo tags' to format its information on a webpage. These tags are replaced with the information they represent when shown to your visitors. The psuedo tags available are at the bottom of this screen.

}; my $cleared_code_template = $default_template; $cleared_code_template =~ s//>/g; $cleared_code_template =~ s/\"/"/g; print " Use This Information For The Template:
"; print "'; eval { require LWP::Simple; }; if(!@$){ print '

 

'; print " Use this URL as the template:
"; print $q->textfield(-name => 'url_template', -value => $list_info{url_template}, size=>'65'); } print qq{

Form Field Size

Form Field Label

Put Subscription Unsubscription Radio Buttons?

Button Label

Give $PROGRAM_NAME Credit?

}; #print "

 

[?] List Template Tutorial

" if $SHOW_HELP_LINKS == 1; print qq{
This TagIs Replaced With
[dada] Instructions, warnings and general information. this tag is needed think of this tag as the content of your webpage.
[message] A brief header describing what the message on the screen is about
[version] Shows the version of the script
}; print(admin_html_footer(-List => $list)); }else{ my $template_info; my $test_header; my $test_footer ; if($process eq "preview template") { if($q->param('get_template_data') eq 'from_url'){ eval {require LWP::Simple;}; if(!$@){ $template_info = LWP::Simple::get($q->param('url_template')); ($test_header, $test_footer) = split(/\[dada\]/,$template_info); } }else{ $template_info = $q->param("template_info"); ($test_header, $test_footer) = split(/\[dada\]/,$template_info); } print $q->header(); $test_header =~ s/\[message\]/preview of template/g; $test_header =~ s/\[version\]/$VER/g; print $test_header; print "

This is a preview (read: not saved!!!!) of your template.

to save, or edit, close this window and hit the Change Template button

 

"; $test_footer =~ s/\[message\]/preview of template/g; $test_footer =~ s/\[version\]/$VER/g; print $test_footer; }else{ $list = $admin_list; my $template_info = $q->param("template_info"); my $get_template_data = $q->param("get_template_data") || ''; my $url_template = $q->param('url_template') || ''; setup_list({list => $list, get_template_data => $get_template_data, url_template => $url_template}); make_template(-List => $list, -Template => $template_info); print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=edit_template&done=1"); } } } sub back_link { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'back_link'); # a few variables... my $website_name = $q -> param("website_name"); my $website_url = $q -> param("website_url"); unless(defined($process)){ $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Create a Back Link", -List => $list_info{list}, -Root_Login => $root_login)); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print < EOF ; my $w_name = $list_info{website_name} || ''; my $w_url = $list_info{website_url} || ''; print ""; print ""; print "

Site Name:
"; print "

"; print "

Site Address: (http://)
"; print "

"; print submit_form(-Submit=>'Change Back Link'); print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, website_name => $website_name, website_url => $website_url); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q -> redirect(-uri=>"$S_PROGRAM_URL?flavor=back_link&done=1"); } } sub edit_type { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'edit_type'); # a few variables... my $edit_subscribed_message = $q->param('edit_subscribed_message'); my $edit_unsubscribed_message = $q->param('edit_unsubscribed_message'); my $edit_confirmation_message = $q->param('edit_confirmation_message'); my $edit_unsub_confirmation_message = $q->param('edit_unsub_confirmation_message'); my $edit_mailing_list_message = $q->param('edit_mailing_list_message'); my $edit_mailing_list_message_html = $q->param('edit_mailing_list_message_html'); my $edit_send_archive_message = $q->param('edit_archive_message'); my $edit_send_archive_message_html = $q->param('edit_archive_message_html'); my $edit_not_allowed_to_post_message = $q->param('edit_not_allowed_to_post_message'); unless(defined($process)){ $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Customize E-mail Messages", -List => $list_info{list}, -Root_Login => $root_login)); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); my $submit_form = submit_form(-Submit=>'Save All Changes', -Reset=>'Clear All Changes'); print $q->hidden('process', 'true'); print $q->hidden('flavor', 'edit_type'); print $q->p("You can customize many of the e-mail messages $PROGRAM_NAME sends. $PROGRAM_NAME uses 'Pseudo Tags' to represent data that may change regularly. Use the Psuedo tags to represent Information like subscription/unsubscription links or your list name. The entire list of available tags is at the end of this page."), $q->p($q->b('Subscription Confirmation E-Mail:'), $q->br(), 'This e-mail is sent when someone requests to be subscribed to your list'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_confirmation_message', -value => $list_info{confirmation_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Unsubscription Confirmation E-Mail:'), $q->br(), 'This e-mail is sent when someone requests to be unsubscribed to your list'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_unsub_confirmation_message', -value => $list_info{unsub_confirmation_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Subscription Successful E-Mail Message:'), $q->br(), 'This e-mail is sent after the confirmation e-mail and the person replys to the confirmation.'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_subscribed_message', -value => $list_info{subscribed_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Unsubscription Successful E-Mail Message:'), $q->br(), 'This e-mail is sent after someone unsubscribes from your list.'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_unsubscribed_message', -value => $list_info{unsubscribed_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Mailing List Message (Text Version):'), $q->br(), 'This is the mailing list message (Text Version). The bottom of the e-mail should at least provide how to unsubscribe from the Mailing List.'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_mailing_list_message', -value => $list_info{mailing_list_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Mailing List Message (HTML Version):'), $q->br(), 'This is the mailing list message (HTML version). The bottom of the e-mail should at least provide how to unsubscribe from the Mailing List.'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_mailing_list_message_html', -value => $list_info{mailing_list_message_html}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Not Allowed to Post Message:'), $q->br(), 'This message is sent out if you use the dada_send.pl script that allows you to send mailing list e-mails by sending an e-mail to a special address. People who are not allowed to post to the list wil receive this message.'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_not_allowed_to_post_message', -value => $list_info{not_allowed_to_post_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Send Archived Message to a Friend (Text Version):')), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_archive_message', -value => $list_info{send_archive_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Send Archived Message to a Friend (HTML Version):')), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_archive_message_html', -value => $list_info{send_archive_message_html}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p(' '); my %td = (-bgcolor=>'#FFFFFF'); print $q->table({-border=>0, -cellpadding=>1, -cellspacing=>0, -bgcolor=>'#000000', -width=>'100%'}, $q->Tr($q->td({-bgcolor=>'#000000'}, [( $q->table({-border=>0, -cellspacing=>1, -cellpadding=>5, -width=>'100%'}, $q->Tr($q->td({-bgcolor=>'#FFFFFF', -align=>'center'},[($q->p($q->b('This Tag'))), ($q->p($q->b('Is Replaced With')))])), $q->Tr($q->td({%td},[('[list_name]'), ('The name of your list')])), $q->Tr($q->td({%td},[('[list_info]'), ('The description of your list')])), $q->Tr($q->td({%td},[('[list_subscribe_link]'), ('The subscription link')])), $q->Tr($q->td({%td},[('[list_unsubscribe_link]'), ('The unsubscription link')])), $q->Tr($q->td({%td},[('[list_privacy_policy]'), ('The privacy policy of your list')])), $q->Tr($q->td({%td},[('[list_owner_email]'), ('The list-owner\'s e-mail address')])), $q->Tr($q->td({%td},[('[list_admin_email]'), ('The list-administrator\'s e-mail address')])), $q->Tr($q->td({%td},[('[program_url]'), ("The url of this script, $PROGRAM_URL")])), ))]))); print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; $edit_subscribed_message =~ s/\r\n/\n/g; $edit_unsubscribed_message =~ s/\r\n/\n/g; $edit_confirmation_message =~ s/\r\n/\n/g; $edit_unsub_confirmation_message =~ s/\r\n/\n/g; $edit_mailing_list_message =~ s/\r\n/\n/g; $edit_mailing_list_message =~ s/\r\n/\n/g; $edit_mailing_list_message_html =~ s/\r\n/\n/g; $edit_not_allowed_to_post_message =~ s/\r\n/\n/g; $edit_send_archive_message =~ s/\r\n/\n/g; $edit_send_archive_message_html =~ s/\r\n/\n/g; my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, subscribed_message => $edit_subscribed_message, unsubscribed_message => $edit_unsubscribed_message, confirmation_message => $edit_confirmation_message, unsub_confirmation_message => $edit_unsub_confirmation_message, mailing_list_message => $edit_mailing_list_message, mailing_list_message_html => $edit_mailing_list_message_html, not_allowed_to_post_message => $edit_not_allowed_to_post_message, send_archive_message => $edit_send_archive_message, send_archive_message_html => $edit_send_archive_message_html, ); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=edit_type&done=1"); } } ###################################################################### sub edit_html_type { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'edit_html_type'); #a few variables... my $edit_html_confirmation_message = $q->param('edit_html_confirmation_message'); my $edit_html_unsub_confirmation_message = $q->param('edit_html_unsub_confirmation_message'); my $edit_html_subscribed_message = $q->param('edit_html_subscribed_message'); my $edit_html_unsubscribed_message = $q->param('edit_html_unsubscribed_message'); unless(defined($process)){ my $submit_form = submit_form(-Submit=>'Save All Changes', -Reset=>'Clear All Changes'); $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "Customize HTML Messages", -List => $list_info{list}, -Root_Login => $root_login)); #good job! print $GOOD_JOB_MESSAGE if(defined($done)); print ""; print ""; print $q->p("You can customize many of the HTML screens $PROGRAM_NAME produces. $PROGRAM_NAME uses 'Pseudo Tags' to represent data that may change regularly."); print $q->p($q->b('Subscription Confirmation Screen:'), $q->br(), 'This text is shown after someone enters their e-mail address to subscribe to your list'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_html_confirmation_message', -value => $list_info{html_confirmation_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Unsubscription Confirmation Screen:'), $q->br(), 'This text is shown after someone enters their e-mail address to unsubscribe to your list'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_html_unsub_confirmation_message', -value => $list_info{html_unsub_confirmation_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Subscription Successful Screen:'), $q->br(), 'This text is shown after the subscriber clicks on the confirmation e-mails\'s subscription link'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_html_subscribed_message', -value => $list_info{html_subscribed_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p($q->b('Unsubscription Successful Screen:'), $q->br(), 'This text is shown after someone unsubscribes'), $q->p($q->textarea(-rows => 10, -cols => 50, -name => 'edit_html_unsubscribed_message', -value => $list_info{html_unsubscribed_message}, -wrap => $wrap, -style => $text_area_style)); print $submit_form; print $q->p(' '); my %td = (-bgcolor=>'#FFFFFF'); print $q->table({-border=>0, cellpadding=>1, cellspacing=>0, -bgcolor=>'#000000', -width=>'100%'}, $q->Tr($q->td({-bgcolor=>'#000000'}, [( $q->table({-border=>0, -cellspacing=>1, -cellpadding=>5, -width=>'100%'}, $q->Tr($q->td({-bgcolor=>'#FFFFFF', -align=>'center'},[($q->p($q->b('This Tag'))), ($q->p($q->b('Is Replaced With')))])), $q->Tr($q->td({%td},[('[subscriber_email]'), ('The e-mail address of the subscriber')])), $q->Tr($q->td({%td},[('[list_name]'), ('The name of your list')])), $q->Tr($q->td({%td},[('[list_info]'), ('The description of your list')])), $q->Tr($q->td({%td},[('[list_privacy_policy]'), ('The privacy policy of your list')])), $q->Tr($q->td({%td},[('[list_owner_email]'), ('The list-owner\'s e-mail address')])), $q->Tr($q->td({%td},[('[list_admin_email]'), ('The list-administrator\'s e-mail address')])), $q->Tr($q->td({%td},[('[program_url]'), ("The url of this script, $PROGRAM_URL")])) ))]))); print(admin_html_footer(-List => $list)); }else{ $list = $admin_list; for($edit_html_confirmation_message, $edit_html_unsub_confirmation_message, $edit_html_subscribed_message, $edit_html_unsubscribed_message){s/\r\n/\n/g} my %list_info = open_database(-List => $list); my %new_info = ( list => $list_info{list}, html_confirmation_message => $edit_html_confirmation_message, html_unsub_confirmation_message => $edit_html_unsub_confirmation_message, html_subscribed_message => $edit_html_subscribed_message, html_unsubscribed_message => $edit_html_unsubscribed_message); my $status = setup_list(\%new_info); user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=edit_html_type&done=1"); } } sub manage_script { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'manage_script'); my $more_info = $q -> param('more_info') || undef; $list = $admin_list; my %list_info = open_database(-List => $list); print(admin_html_header(-Title => "About $PROGRAM_NAME", -List => $list_info{list}, -Root_Login => $root_login)); print <Script Information

This is $PROGRAM_NAME
EOF ; if($more_info){ my $server_sw = $q->server_software(); print $q->Tr($q->td(["

Given Path To Your Mail Program:

", "

$MAILPROG

"])); print $q->Tr($q->td(["

Given List Path:

", "

$FILES

"])); print $q->Tr($q->td(["

Given $PROGRAM_NAME URL:

", "

$PROGRAM_URL

"])); print $q->Tr($q->td(["

SMTP Server:

", "

$list_info{smtp_server}

"])) if ($list_info{smtp_server}); print $q->Tr($q->td(["

Server Software:

", "

$server_sw

"])); print $q->Tr($q->td(["

Operating System:

", "

$^O

"])); print $q->Tr($q->td(["

Perl Version:

", "

$]

"])); my $sendmail =`whereis sendmail`; print $q->Tr($q->td(["

Sendmail Locations:

", "

$sendmail

"])); print $q->Tr($q->td(["

$PROGRAM_NAME Script URL (Guess):

", "

$ENV{SCRIPT_URI}

"])); print $q->Tr($q->td(["

Absolute Path (Guess)

", "

$ENV{SCRIPT_FILENAME}

"])); print "

Version:

$VER
"; print "Less ..."; }else{ print ""; print "More ..."; } print <It's a good idea to periodically check for updates to this script, as bug fixes and features may be added that you may want to take advantage of:

Visit the support site

An entire support site has been set up just for Dada Mail. There, you'll be able to browse through faqs, instructions, tips and tricks and whatever else we can muster:

http://dadamail.org

Join the Skazat Design mailing list

This mailing list provides information about Skazat Designs and Dada Mail. It's used to announce new features to Dada Mail, as well as other projects from Skazat Designs. the list is low traffic and usually e-mails are not sent out more than once a month

Give Back to Dada Mail

Dada Mail is free, open source software, you are in absolutely no obligation to pay for Dada Mail by downloading or using it. If you find Dada Mail incredibly useful, you may want to give to the Dada Mail project, money goes towards the cost of web server hosting for the support site, software used to make this product and to basically keep the lights on. Any leftover money goes toward my college education.

More Information...

Purchase The Dada Mail Magic Book

The Dada Mail Magic Book has been written to give advanced users of Dada Mail even more insight on the program so they may be able to use Dada Mail to the limit of its abilities.

More Information...

Customizations to the Dada Mail Program

Dada Mail is developing rapidly, with many great new features added all the time. If you need a feature that is not included in Dada Mail, you can always have this feature added by the developer of Dada Mail. Consultation, Installation and Customization services are available. Please visit: http://mojo.skazat.com/support/customize.html for more information.

License Agreement

Dada Mail is Open Source Software and is released under the GNU Public License

Dada Mail and SPAM

Do not use Dada Mail for SPAM. Don't even eat SPAM. Really, it's disgusting. We're ramen-eatin folks. Seriously though, please read our stance on SPAM:

http://mojo.skazat.com/about/spam.html

EOF ; print(admin_html_footer(-List => $list)); } sub feature_set { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'feature_set'); $list = $admin_list; my %list_info = open_database(-List => $list); require DADA::Template::Widgets::Admin_Menu; if(!$process){ print(admin_html_header(-Title => "Customize Feature Set", -List => $list_info{list}, -Root_Login => $root_login)); print $GOOD_JOB_MESSAGE if(defined($done)); print DADA::Template::Widgets::Admin_Menu::make_feature_menu(\%list_info); print $q->hidden('process', 'true'); print $q->hidden('flavor', 'feature_set'); print $q->p(submit_form()); print(admin_html_footer(-List => $list)); }else{ my @params = $q->param; my %param_hash; foreach(@params){$param_hash{$_} = $q->param($_);} my $save_set = DADA::Template::Widgets::Admin_Menu::create_save_set(\%param_hash); my %new_info = (list => $list, admin_menu => $save_set); setup_list(\%new_info); print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=feature_set&done=1"); } } sub subscribe { my %args = (-html_output => 1, @_); my $list_exists = check_if_list_exists(-List=>$list,); if($list_exists == 0){ &default; exit; } if (!$email){ list_page(); exit; #wonder if I can just use a # return; # here? } require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings->new(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $list_info = $ls->get(-Format => "replaced"); $email = lc_email($email); my ($status, $errors) = $lh->subscription_check(-Email => $email); if($status == 0){ if(($list_info->{use_alt_url_sub_confirm_failed} == 1) && ($list_info->{alt_url_sub_confirm_failed} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_sub_confirm_failed}); exit; }else{ user_error(-List => $list, -Error => "invalid_email", -Email => $email) if $errors->{invalid_email} == 1; user_error(-List => $list, -Error => "mx_lookup_failed", -Email => $email) if $errors->{mx_lookup_failed} == 1; user_error(-List => $list, -Error => "email_in_list", -Email => $email) if $errors->{subscribed} == 1; user_error(-List => $list, -Error => "closed_list", -Email => $email) if $errors->{closed_list} == 1; user_error(-List => $list, -Error => "over_subscription_quota", -Email => $email) if $errors->{over_subscription_quota} == 1; user_error(-List => $list, -Error => "settings_possibly_corrupted", -Email => $email) if $errors->{settings_possibly_corrupted} == 1; unless($list_info->{allow_blacklisted_to_subscribe} eq "1"){ user_error(-List => $list, -Error => "black_listed", -Email => $email) if $errors->{blacklisted} == 1; } } } if($list_info->{no_confirm_email} eq "0"){ $pin = make_pin(-Email => $email); confirm(-html_output => $args{-html_output}); exit; # love to know what this is all about... } my $Body = $list_info->{confirmation_message}; # js - escape the listname for the url my $escaped_list = uriescape($list); my $subscribe_link = subscribe_link(-list => $list, -email => $email, -make_pin => 1); my $unsubscribe_link = unsubscribe_link(-list => $list, -email => $email, -make_pin => 1); $Body =~ s/\[list_subscribe_link\]/$subscribe_link/g; $Body =~ s/\[list_unsubscribe_link\]/$unsubscribe_link/g; $Body = interpolate_string(-String => $Body, -List_Db_Ref => $list_info, -Email => $email); # I need to eat, I'm as thin as a rail! $Body .= $FOOTER if $FOOTER ne ''; require DADA::Mail::Send; my $mh = DADA::Mail::Send -> new($list_info); my %mailing = ( 'Content-type' => $list_info->{content_type}, To => $email, Subject => $list_info->{list_name} . ' Mailing List Confirmation', Body => $Body); $mh->send(%mailing); if($args{-html_output} == 1){ if(($list_info->{use_alt_url_sub_confirm_success} == 1) && ($list_info->{alt_url_sub_confirm_success} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_sub_confirm_success}); }else{ #print header(); print(the_html(-Part => "header", -Title => "Please Confirm", -List => $list_info->{list})); $list_info->{html_confirmation_message} =~ s/\[subscriber_email\]/$email/g; print $list_info->{html_confirmation_message}; print(the_html(-Part => "footer", -List => $list_info->{list}, -Site_Name => $list_info->{website_name}, -Site_URL => $list_info->{website_url})); } } exit; # love to know what this is all about... } sub subscribe_flash_xml { if($q->param('test') == 1){ print $q->header('text/plain'); }else{ print $q->header('application/x-www-form-urlencoded'); } if(check_if_list_exists(-List=>$list) == 0){ #note! This should be handled in the subscription_check_xml() method, # but this object *also* checks to see if a list is real. Chick/Egg print '' . $email . '0no_list'; }else{ my $lh = DADA::MailingList::Subscribers->new(-List => $list); my ($xml, $status, $errors) = $lh->subscription_check_xml(-Email => $email); print $xml; if($status ==1){ subscribe(-html_output => 0); } } } sub unsubscribe_flash_xml { if($q->param('test') == 1){ print $q->header('text/plain'); }else{ print $q->header('application/x-www-form-urlencoded'); } if(check_if_list_exists(-List=>$list) == 0){ print '' . $email . '0no_list'; }else{ my $lh = DADA::MailingList::Subscribers->new(-List => $list); my ($xml, $status, $errors) = $lh->unsubscription_check_xml(-Email => $email); print $xml; if($status == 1){ unsubscribe(-html_output => 0); } } } sub send_unsubscription_email{ my %args = (-List => undef, -Email => undef, -List_Info => undef, @_); my $db_list_ref = $args{-List_Info}; my %list_info = %$db_list_ref; my $pin = make_pin(-Email => $email); my $escaped_list = uriescape($list); my $subscribe_link = subscribe_link(-list => $list, -email => $email, -make_pin => 1); my $unsubscribe_link = unsubscribe_link(-list => $list, -email => $email, -make_pin => 1); my $Body = $list_info{unsubscribed_message}; $Body =~ s/\[list_unsubscribe_link\]/$unsubscribe_link/g; $Body =~ s/\[list_subscribe_link\]/$subscribe_link/g; $Body = interpolate_string(-String => $Body, -List_Db_Ref => \%list_info, -Email => $email); require DADA::Mail::Send; my $mh = DADA::Mail::Send -> new(\%list_info); my %mailing = ( 'Content-type' => $list_info{content_type}, To => "$email", Subject => "$list_info{list_name} Unsubscription", Body => $Body); $mh->send(%mailing); } sub unsubscribe { my %args = (-html_output => 1, @_); if(check_if_list_exists(-List=>$list) == 0){ $set_flavor = 'u'; &default; exit; } if (!$email){ $set_flavor = 'u'; list_page(); exit; } my $lh = DADA::MailingList::Subscribers->new(-List => $list); my ($status, $errors) = $lh->unsubscription_check(-Email => $email, -Skip => ['no_list']); require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings ->new(-List => $list); my $list_info = $ls->get(-Format => "replaced"); if($status == 0){ if(($list_info->{use_alt_url_unsub_confirm_failed} == 1) && ($list_info->{alt_url_unsub_confirm_failed} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_unsub_confirm_failed}); exit; }else{ user_error(-List => $list, -Error => "unsub_invalid_email", -Email => $email) if $errors->{invalid_email} == 1; user_error(-List => $list, -Error => "email_not_in_list", -Email => $email) if $errors->{not_subscribed} == 1; user_error(-List => $list, -Error => "settings_possibly_corrupted", -Email => $email) if $errors->{settings_possibly_corrupted} == 1; } }else{ if($pin){ &unsub_confirm(-html_output => $args{-html_output}); #we'll change this one later... exit; }elsif($list_info->{unsub_confirm_email} != 1){ $pin = make_pin(-Email => $email); &unsub_confirm(-html_output => $args{-html_output}); #we'll change this one later... exit; }else{ send_unsub_confirm_email( -List => $list, -Email => $email, -Settings_obj => $ls, ); if($args{-html_output} == 1){ if(($list_info->{use_alt_url_unsub_confirm_success} == 1) && ($list_info->{alt_url_unsub_confirm_success} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_unsub_confirm_success}); exit; }else{ print(the_html(-Part => "header", -Title => "Please Confirm Your Unsubscription", -List => $list_info->{list})); $list_info->{html_unsub_confirmation_message} =~ s/\[subscriber_email\]/$email/g; print $list_info->{html_unsub_confirmation_message}; print(the_html(-Part => "footer", -List => $list_info->{list}, -Site_Name => $list_info->{website_name}, -Site_URL => $list_info->{website_url})); } } } } } sub send_unsub_confirm_email { my %args = ( -List => undef, -Email => undef, -Settings_obj => undef, @_ ); if (! $args{-Settings_obj}){ $args{-Settings_obj} = DADA::MailingList::Settings->new(-LIst => $args{-List}); } my $list_info = $args{-Settings_obj}->get; $pin = DADA::App::Guts::make_pin(-Email => $email); my $subscribe_link = DADA::App::Guts::subscribe_link( -list => $list, -email => $email, -make_pin => 1); my $unsubscribe_link = DADA::App::Guts::unsubscribe_link(-list => $list, -email => $email, -make_pin => 1); my $Body = $list_info->{unsub_confirmation_message}; $Body =~ s/\[list_unsubscribe_link\]/$unsubscribe_link/g; $Body =~ s/\[list_subscribe_link\]/$subscribe_link/g; $Body = interpolate_string(-String => $Body, -Email => $email, -List_Db_Ref => $list_info); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new($list_info); my %mailing = ( 'Content-type' => $list_info->{content_type}, To => "$email", Subject => $list_info->{list_name} . ' Mailing List Confirmation', Body => $Body ); $mh->send(%mailing); } sub unsub_confirm { my %args = (-html_output => 1, @_); if(check_if_list_exists(-List=>$list) == 0){ &default; exit; } my $lh = DADA::MailingList::Subscribers->new(-List => $list); my($status, $errors) = $lh->unsubscription_check(-Email => $email); user_error(-List => $list, -Error => "no_list", -Email => $email) if $errors->{no_list} == 1; require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings ->new(-List => $list); my $list_info = $ls->get(-Format => "replaced"); $status = 0 if check_email_pin(-Email => $email, -Pin => $pin) == 1; if($status == 0){ if(($list_info->{use_alt_url_unsub_failed} == 1) && ($list_info->{alt_url_unsub_failed} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_unsub_failed}); exit; }else{ user_error(-List => $list, -Error => 'invalid_pin', -Email => $email) if check_email_pin(-Email => $email, -Pin => $pin) == 1; user_error(-List => $list, -Error => "invalid_email", -Email => $email) if $errors->{invalid_email} == 1; user_error(-List => $list, -Error => "email_not_in_list", -Email => $email) if $errors->{not_subscribed} == 1; user_error(-List => $list, -Error => "no_list", -Email => $email) if $errors->{no_list} == 1; user_error(-List => $list, -Error => "settings_possibly_corrupted", -Email => $email) if $errors->{settings_possibly_corrupted} == 1; } }else{ my $rm_status = $lh->remove_from_list(-Email_List =>[$email],-List => $list); user_error(-List => $list, -Error => 'no_list', -Email => $email) if $rm_status eq 'no list'; user_error(-List => $list, -Error => 'too_busy', -Email => $email) if $rm_status eq 'too busy'; if(($list_info->{black_list} eq "1") and ($list_info->{add_unsubs_to_black_list} eq "1")){ $lh->add_to_email_list(-Email_Ref => [$email], -Type => 'black_list'); } send_owner_happenings("unsubscribed"); send_unsubscription_email(-List => $list, -Email => $email, -List_Info => $list_info) if($list_info->{send_unsub_success_email} == 1); if($args{-html_output} == 1){ if(($list_info->{use_alt_url_unsub_success} == 1) && ($list_info->{alt_url_unsub_success} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_unsub_success}); exit; }else{ print(the_html(-Part => "header", -Title => "Unsubscription Successful", -List => $list)); $list_info->{html_unsubscribed_message} =~ s/\[subscriber_email\]/$email/g; print $list_info->{html_unsubscribed_message}; print(the_html(-Part => "footer", -List => $list, -Site_Name => $list_info->{website_name}, -Site_URL => $list_info->{website_url})); } } } } sub confirm { my %args = (-html_output => 1, @_) ; $email = lc_email($email); my ($invalid_pin) = check_email_pin(-Email => $email, -Pin => $pin); if ($invalid_pin >= 1) { user_error(-List => $list, -Error => "invalid_pin", -Email => $email,); } require DADA::MailingList::Settings; #open the database #my %list_info = open_database(-List => $list, -Format => "replaced"); my $lh = DADA::MailingList::Subscribers->new(-List => $list); my ($status, $errors) = $lh->subscription_check(-Email => $email); user_error(-List => $list, -Error => "no_list", -Email => $email) if $errors->{no_list} == 1; my $ls = DADA::MailingList::Settings->new(-List => $list); my $list_info = $ls->get(-Format => "replaced"); if($status == 0){ if(($list_info->{use_alt_url_sub_failed} == 1) && ($list_info->{alt_url_failed} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_sub_failed}); exit; }else{ user_error(-List => $list, -Error => "invalid_email", -Email => $email) if $errors->{invalid_email} == 1; user_error(-List => $list, -Error => "mx_lookup_failed", -Email => $email) if $errors->{mx_lookup_failed} == 1; user_error(-List => $list, -Error => "email_in_list", -Email => $email) if $errors->{subscribed} == 1; user_error(-List => $list, -Error => "closed_list", -Email => $email) if $errors->{closed_list} == 1; user_error(-List => $list, -Error => "over_subscription_quota", -Email => $email) if $errors->{over_subscription_quota} == 1; user_error(-List => $list, -Error => "settings_possibly_corrupted", -Email => $email) if $errors->{settings_possibly_corrupted} == 1; unless($list_info->{allow_blacklisted_to_subscribe} eq "1"){ user_error(-List => $list, -Error => "black_listed", -Email => $email) if $errors->{blacklisted} == 1; } } } $lh->add_to_email_list(-List => $list, -Email_Ref => [$email]); make_pin(-Email => $email); my $Body = $list_info->{subscribed_message}; # js - escape the listname for the url my $escaped_list = uriescape($list); my $subscribe_link = subscribe_link(-list => $list, -email => $email, -make_pin => 1); my $unsubscribe_link = unsubscribe_link(-list => $list, -email => $email, -make_pin => 1); $Body =~ s/\[list_unsubscribe_link\]/$unsubscribe_link/g; $Body =~ s/\[list_subscribe_link\]/$subscribe_link/g; $Body = interpolate_string(-String => $Body, -List_Db_Ref => $list_info, -Email => $email, ); if($list_info->{send_sub_success_email} == 1){ require DADA::Mail::Send; my $mh = DADA::Mail::Send->new($list_info); $mh->send('Content-type' => $list_info->{content_type}, To => "\"New Subscriber\" <$email>", Subject => "Welcome to " . $list_info->{list_name}, Body => $Body); } send_owner_happenings("subscribed"); if($args{-html_output} == 1){ if(($list_info->{use_alt_url_sub_success} == 1) && ($list_info->{alt_url_sub_success} ne "")){ print $q->redirect(-uri => $list_info->{alt_url_sub_success}); }else{ print(the_html(-Part => "header", -Title => "Subscription Successful", -List => $list_info->{list})); $list_info->{html_subscribed_message} =~ s/\[subscriber_email\]/$email/g; print $list_info->{html_subscribed_message}; print(the_html(-Part => "footer", -List => $list_info->{list}, -Site_Name => $list_info->{website_name}, -Site_URL => $list_info->{website_url})); } } } sub all_list_code { print $q->header(); my $available_lists_ref = available_lists(-As_Ref=>1); if ($available_lists_ref->[0] ne undef) { print qq{

Choose a list:

Enter your e-mail address:
}; require DADA::Template::Widgets; print DADA::Template::Widgets::list_popup_menu(); print qq{
}; }else{ print $q->p('There are no lists available right now.'); } } sub search_email { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'search_email'); my $method = $q->param("method"); $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list, -Path => $FILES); # my $any_subscribers = -s "$FILES/$list.list"; # debug my $any_subscribers = 1; unless($any_subscribers > 0){ print(admin_html_header(-Title => "Search E-mails", -List => $list_info{list}, -Root_Login => $root_login)); print $NO_ONE_SUBSCRIBED; print(admin_html_footer(-List => $list)); exit; } print(admin_html_header(-Title => "E-mail Search Results", -List => $list_info{list}, -Root_Login => $root_login)); if(defined($keyword)){ print "
"; print ""; if(($list_info{black_list} eq "1") and ($list_info{add_unsubs_to_black_list} eq "1")){ print $q->hidden('add_to_black_list',1); } my $found = $lh->search_email_list(-List => $list, -Method => $method, -Keyword => $keyword); if($found == 0) { print "Sorry, no matches were found. You may want to try and revise your search

\n"; }else{ print "

check all :: uncheck all

"; print ""; print "

\n"; print "

A total of ",$found," e-mail addresses were found when searching for \"",$keyword,"\""; print "when using ",$method," search"; } print <

Search Again:

EOF ; print(admin_html_footer(-List => $list)); }else{ print <Search through every e-mail address on your list:
EOF ; print(admin_html_footer(-List => $list)); } } sub text_list { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'text_list'); $list = $admin_list; my %list_info = open_database(-List => $list); my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $email; print $q->header('text/plain'); print "E-Mail Addresses for list:", $list_info{list_name},"\n"; print "=" x 72, "\n"; my $email_count = $lh->print_out_list(-List=>$list); print "=" x 72, "\n"; print "Total: $email_count \n\n"; } sub send_list_to_admin { my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'send_list_to_admin'); $list = $admin_list; my %list_info = open_database(-List => $list); my $email; my ($sec, $min, $hour, $day, $month, $year) = (localtime)[0,1,2,3,4,5]; $year = $year + 1900; $month = $month + 1; my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $tmp_file = $lh->write_plaintext_list(); my $message = <quiet(1) if $MIME_HUSH == 1; ### I know what I'm doing $MIME::Lite::PARANOID = $MIME_PARANOID; my $msg = MIME::Lite->new(Type => 'multipart/mixed'); $msg -> attach(Type => 'TEXT', Data => $message); my $listname = "$list_info{list}.list"; $msg->attach(Type => 'TEXT', Path => $tmp_file, Filename => $listname, Disposition => 'inline', Encoding => $list_info{plaintext_encoding}, ); $msg->replace('X-Mailer' =>""); my $msg_headers = $msg->header_as_string(); my $msg_body = $msg->body_as_string(); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); my %mail_headers = $mh->return_headers($msg_headers); my %mailing = ( %mail_headers, To => '"'. escape_for_sending($list_info{list_name}) .'" <'. $list_info{list_owner_email} .'>', Subject => "$list_info{list_name} subscriber list $month/$day/$year", Body => $msg_body, ); $mh->send(%mailing); unlink($tmp_file); print $q->redirect(-uri => "$S_PROGRAM_URL?flavor=view_list"); } sub preview_form { my $code = $q->param("code"); my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'preview_form'); print $q->header(); print < Form Preview

$code

close the window
EOF ; } sub new_list { require DADA::Security::Password; my $root_password = $q->param('root_password'); my $agree = $q->param('agree'); unless(defined($process)) { my $errors = shift; my $flags = shift; my $pw_check; if(!$PROGRAM_ROOT_PASSWORD){ user_error(-List => $list, -Error => "no_root_password"); }elsif($ROOT_PASS_IS_ENCRYPTED == 1){ #encrypted password check $pw_check = DADA::Security::Password::check_password($PROGRAM_ROOT_PASSWORD, $root_password); }else{ # unencrypted password check if($PROGRAM_ROOT_PASSWORD eq $root_password){$pw_check = 1} } #check password if ($pw_check == 1){ my @t_lists = available_lists(); $agree = 'yes' if $errors; if((!$t_lists[0]) && ($agree ne 'yes') && (!$process)){ print $q->redirect(-uri => "$S_PROGRAM_URL?agree=no"); } if(($LIST_QUOTA) && (($#t_lists + 1) >= $LIST_QUOTA)){ user_error(-List => $list, -Error => "over_list_quota"); } if(!$t_lists[0]){ $help = 1; } print(the_html(-Part => "header", -Title => "Create a New List", )); if($errors){ my $ending = ''; my $err_word = 'was'; $ending = 's' if $errors > 1; $err_word = 'were' if $errors > 1; print "

$errors field$ending on this form $err_word filled out incorrectly and needs to be fixed. Please fix the error$ending to successfully create your new list.

"; } print $q->h3("Please fill in all the fields to create your new list."); print $q->end_form(); print $q->p({-align=>'right'}, $q->start_form(-action => $S_PROGRAM_URL, -method => "POST"), $q->hidden('help','yes'), $q->hidden('flavor', 'new_list'), $q->hidden('root_password', $root_password), $q->submit(-value => "help!", -style => 'font-family:arial;size:10px; background-color:#FFFFFF;font-weight:bold'), $q->end_form()) if(!defined($help)); print $q->p('All information, except the list\'s short name, may be changed at a later time.'); print $q->start_form(-action => "$S_PROGRAM_URL", -method => "POST"), $q->hidden('flavor','new_list'), $q->hidden('process', 'true'), $q->hidden('root_password', $root_password); #################################################################### # List Name Help print $q->h3("List Name"); print $q->p({-class => 'smallred'}, "The name of your list is what people and $PROGRAM_NAME will use to tell other lists apart.") if($help); #list with quotes print '

You did not fill in a list name.

' if($flags->{list_name} == 1); print $q->p('What is the list\'s name? You can change this name any time you would like.', $q->br(), $q->textfield(-name =>'list_name', -value=>$list_name, -size => 30, -maxlength => 250)); print $q->h3("List Short Name"); # List short name Errors #################################################################### # already exists print '

This list short name already exists

' if $flags->{list_exists} == 1; # do list name print '

You need to give your list a short name

' if $flags->{list} == 1; # too long! print '

Your list short name is longer than eight characters.

' if $flags->{shortname_too_long} == 1; # bad characters print '

Your list short name can\'t have slashes ("/" or "\") in the name itself

' if $flags->{slashes_in_name} == 1; # weird characters print '

Your list short name appears to have weird characters in the name that may create problems

' if $flags->{weird_characters} == 1; #list with quotes print '

Your list short name cannot contain quotes

' if $flags->{quotes} == 1; print $q->p("What is the list's 'short' name? ", $q->br(), "The list short name will be used internally by $PROGRAM_NAME and will also be used for subscription/unsubscription links, filename and perhaps email addresses. You should make this short name", $q->b('lowercase,'), "and no more than 16 characters, Use only alpha/numerical characters.", $q->br(), $q->textfield(-name =>'list', -value=>$list, -size => 16, -maxlength => 16)); print '
'; print $q->h3("Password"); # Password Errors #################################################################### # no passwd print '

You need to give your list a password

' if($flags->{password} == 1); #################################################################### # Password Help print $q->p({-class => 'smallred'}, 'A list password is used to protect your list and its subscribers. You\'ll need to remember this password when you log into your list control panel - the place where you can set list options and also send list messages. Please make your password hard to guess, using upper and lower case letters mixed with numbers. The list password should be no more than 8 characters long') if($help); print $q->p('Please make a password to protect your list:', $q->br(), $q->password_field(-name => 'password', -value=>$password, -size => 8, -maxlength => 8)); # Password Errors #################################################################### print '

You need to retype your list password

' if($flags->{retype_password} == 1); print '

The second password doesn\'t match the first password

' if($flags->{password_ne_retype_password} == 1); print $q->p('Re-type the password to confirm:', $q->br(), $q->password_field(-name => 'retype_password', -value=>$retype_password, -size => 8, -maxlength => 8)); print '
'; print $q->h3("List Owner"); # List Owner Errors #################################################################### print '

You need to give a valid e-mail address for the list owner

' if($flags->{invalid_list_owner_email} == 1); print $q->p({-class => 'smallred'}, "The List Owner is the person in charge of the list. Their email will be used for every message sent by $PROGRAM_NAME when working with your list.") if($help); print $q->p('What e-mail address corresponds to the list owner?, When e-mails are sent, they are sent using this address.', $q->br(), $q->textfield(-name=>'list_owner_email', -value => $list_owner_email, -size=>30, -maxlength => 100)); print '
'; print $q->h3("Description"); # Description Errors #################################################################### print '

You need to give your list a description

' if($flags->{list_info} == 1); print $q->p({-class => 'smallred'}, "A description of your list will tell would-be subscribers what your list is about. This information will be shown on the $PROGRAM_NAME main screen, as well as in confirmation emails sent to people wishing to subscribe.") if($help); print $q->p('Please write a brief description of your list:', $q->br(), $q->textarea(-name=>"info", -value=>$info, -cols=>"33", -rows=>"4", -wrap=>"VIRTUAL", -maxlength => 1024)); print '
'; print $q->h3('Privacy Policy'); # Privacy Policy Errors #################################################################### print '

You need to give your list a privacy policy

' if($flags->{privacy_policy} == 1); print $q->p({-class => 'smallred'}, "A privacy policy allows a subscriber to know exactly how the information they submit (their email address) will be used") if($help); print $q->p('Please write a privacy policy for your list:', $q->br(), $q->textarea(-name=>"privacy_policy", -value=>$privacy_policy, -cols=>"33", -rows=>"4", -wrap=>"VIRTUAL", -maxlength => 1024)); print '
'; print $q->h3('Physical Address'); # Physical Address #################################################################### print '

You need to associate a physical address to your list

' if($flags->{privacy_policy} == 1); print $q->p({-class => 'smallred'}, "A physical address ties your mailing list to a known business or organization, even if that organization is yourself. It also helps you conform to recent laws relating to mailing lists.") if($help); print $q->p('Please write the physical address associated with this mailing list:', $q->br(), $q->textarea(-name=>"physical_address", -value=>$physical_address, -cols=>"33", -rows=>"4", -wrap=>"VIRTUAL", -maxlength => 1024)); print '
'; print "

"; print(the_html(-Part => "footer")); }else{ user_error(-List => $list, -Error => "invalid_root_password"); } }else{ chomp($list); $list =~ s/^\s+//; $list =~ s/\s+$//; $list =~ s/ /_/g; my ($list_exists) = check_if_list_exists(-List=>$list); my ($list_errors,$flags) = check_list_setup(-fields => {list => $list, list_name => $list_name, list_owner_email => $list_owner_email, password => $password, retype_password => $retype_password, info => $info, privacy_policy => $privacy_policy, physical_address => $physical_address }); if($list_errors >= 1){ undef($process); new_list($list_errors, $flags); }elsif($list_exists >= 1){ &user_error(-List => $list, -Error => "list_already_exists"); }else{ $admin_email = $list_owner_email if ($admin_email eq ""); # js - lowercase domain part of the email $admin_email = lc_email($admin_email); $list_owner_email = lc_email($list_owner_email); $password = DADA::Security::Password::encrypt_passwd($password); my %new_info = ( list_owner_email => $list_owner_email, admin_email => $admin_email, list => $list, list_name => $list_name, password => $password, info => $info, privacy_policy => $privacy_policy, physical_address => $physical_address, ); %new_info = (%new_info, %LIST_SETUP_DEFAULTS); require DADA::MailingList; my $ml = DADA::MailingList::Create(-name => $list, -make_all_files => 1); $ml->save({%new_info}); my $status; require DADA::Logging::Usage; my $log = new DADA::Logging::Usage; $log->mj_log($list, 'List Created', "remote_host:$ENV{REMOTE_HOST}, ip_address:$ENV{REMOTE_ADDR}") if $LOG{list_lives}; #print header(); print(the_html(-Part => "header", -Title => "Your new list has been created", )); print $q->h3("The following information was recorded:"); #my %list_info = open_database(-List => $list); my $list_info = $ml->get; my %list_info = %$list_info; print "\n"; print $q->Tr($q->td([$q->p($q->strong('List Name:')), $q->p($list_info{list_name})])), "\n"; print $q->Tr($q->td([$q->p($q->strong('List Short Name:')), $q->p($list_info{list})])), "\n"; print $q->Tr($q->td([$q->p($q->strong('Password')), $q->p($q->em('(not shown)'))])), "\n"; print $q->Tr($q->td([$q->p($q->strong('List Owner E-mail Address:')), $q->p($list_info{list_owner_email})])), "\n"; print $q->Tr($q->td([$q->p($q->strong('List Information:')), $q->p($list_info{info})])), "\n"; print $q->Tr($q->td([$q->p($q->strong('Privacy Policy:')), $q->p($list_info{privacy_policy})])), "\n"; print $q->Tr($q->td([$q->p($q->strong('Physical Address:')), $q->p($list_info{physical_address})])), "\n"; print "
\n"; my $escaped_list = uriescape($list); print <Please log in, with the correct password to access your control panel.

Log into your control panel for list: $list_info{list_name}

password:

For future reference, here are some relevent URL's for this list, you may want to bookmark these links, a new window will open for each link:
Sign in to your control panel
View your message archives

EOF ; print(the_html(-Part => "footer")); } } } sub archive { # are we dealing with a real list? my $list_exists = check_if_list_exists(-List=>$list); user_error(-List => $list, -Error => 'no_list') if ($list_exists == 0); # start variable, # where do we start the list? my $start = $q->param('start') || 0; my %list_info = open_database(-List => $list); # are we even supposed to do this? user_error(-List => $list, -Error => "no_show_archives") if ($list_info{show_archives} eq "0"); # fetch archive functions require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives->new(-List => \%list_info); my $entries = $archive->get_archive_entries(); # If we don't have an explicit message to look at, # print an index. unless(defined($id)){ #print header(); print(the_html(-Part => "header", -Title => "$list_info{list_name} archives", -List => $list_info{list})); print "
"; #get the params we're supposed to write the list to and from my ($begin, $stop) = $archive->create_index($start); my $i; my $stopped_at = $begin; my $num = $begin; $num++; my @archive_nums; my @archive_links; # iterate and save for($i = $begin; $i <=$stop; $i++){ my $link; if(defined($entries->[$i])){ my ($subject, $message, $format) = $archive->get_archive_info($entries->[$i]); my $pretty_subject = pretty($subject); $link.= " [$i]&list=".uriescape($list)."\">$pretty_subject
"; my $date = date_this(-Packed_Date => $entries->[$i], -Write_Month => $list_info{archive_show_month}, -Write_Day => $list_info{archive_show_day}, -Write_Year => $list_info{archive_show_year}, -Write_H_And_M => $list_info{archive_show_hour_and_minute}, -Write_Second => $list_info{archive_show_second}); $link .= "Sent $date \n"; $link .= "

\n"; $stopped_at++; push(@archive_nums, $num); push(@archive_links, $link); $num++; } } my $ii; for($ii=0;$ii<=$#archive_links; $ii++){ my $bullet = $archive_nums[$ii]; #fix if we're doing reverse chronologic $bullet = (($#{$entries}+1) - ($archive_nums[$ii]) +1) if($list_info{sort_archives_in_reverse} eq "1"); print "

$bullet $archive_links[$ii]\n"; } print "

"; print $archive->create_index_nav($list_info{list}, $stopped_at); }else{ $id = $archive->newest_entry if $id =~ /newest/i; $id = $archive->oldest_entry if $id =~ /oldest/i; my $entry_exists = $archive->check_if_entry_exists($id); user_error(-List => $list, -Error => "no_archive_entry")if($entry_exists <= 0); #print header(); print(the_html(-Part => "header", -Title => "$list_info{list_name} archives", -List => $list_info{list})); #get the archive info my ($subject, $message, $format) = $archive->get_archive_info($id); my $zap_sig = $list_info{stop_message_at_sig} || 1; $message = $archive->zap_sig($message) if ($list_info{stop_message_at_sig} ne "0"); $message = webify_plain_text($message) if($format !~ /HTML/i); my $pretty_subject = pretty($subject); print"

$pretty_subject

"; print"

$message

"; } if(($list_info{archive_send_form} == 1) && (defined($id))){ print archive_send_form($list,$id, $q->param('send_archive_errors')); } if(defined($id)){ print $archive -> make_nav_table(-Id => $id, -List => $list_info{list}); } print "

(archive rss)

" if $list_info{publish_archives_rss} == 1; if($list_info{archive_search_form} eq "1"){ my $search_form = $archive -> make_search_form($list_info{list}); print $search_form; } print "
"; if($list_info{hide_list} ne "1"){ $list_info{info} =~ s/\n\n/

/gi; $list_info{info} =~ s/\n/
/gi; unless ($list_info{archive_subscribe_form} eq "0"){ print "

",$list_info{info},"

\n"; print "

Subscribe to ",$list_info{list_name},":
\n"; require DADA::Template::Widgets; print DADA::Template::Widgets::list_subscribe_form(-list => $list_info{list}, -email => $email); } } print(the_html(-Part => "footer", -List => $list_info{list}, -Site_Name => $list_info{website_name}, -Site_URL => $list_info{website_url})); } sub search_archive { $list = $q->param("list"); my $list_exists = check_if_list_exists(-List=>$list); &user_error(-List => $list, -Error => "no_list") if ($list_exists <=0); my %list_info = open_database(-List => $list); user_error(-List => $list, -Error => "no_show_archives") if ($list_info{show_archives} eq "0"); # let's get some info on this archive, shall we? require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives -> new(-List => \%list_info); my $entries = $archive -> get_archive_entries(); #print header(); print(the_html(-Part => "header", -Title => "Archive Seach Results", -List => $list_info{list})); print "

Go Back To The Archive Index

"; #search my $search_results = $archive -> search_entries($keyword); if(defined(@$search_results[0]) && (@$search_results[0] ne "")){ my $ending = ""; my $count = $#{$search_results}+1; $ending = 's' if defined(@$search_results[1]); print "

Found $count archived message$ending when looking for "$keyword"

\n"; print "
    "; my $summaries = $archive -> make_search_summary($keyword, $search_results); foreach(@$search_results){ my ($subject, $message, $format) = $archive -> get_archive_info($_); my $pretty_subject = pretty($subject); print "

  1. $pretty_subject
    "; my $date = date_this(-Packed_Date => $_, -Write_Month => $list_info{archive_show_month}, -Write_Day => $list_info{archive_show_day}, -Write_Year => $list_info{archive_show_year}, -Write_H_And_M => $list_info{archive_show_hour_and_minute}, -Write_Second => $list_info{archive_show_second}); print "Sent $date

    \n"; print "

    $summaries->{$_}"; print "

    2. \n"; } print "
"; }else{ print "

No archived messages matched your search.

"; } if($list_info{archive_search_form} == 1){ my $search_form = $archive -> make_search_form($list_info{list}); print $search_form; } print "
"; if($list_info{hide_list} ne "1"){ $list_info{info} =~ s/\n\n/

/gi; $list_info{info} =~ s/\n/
/gi; unless ($list_info{archive_subscribe_form} eq "0"){ print "

",$list_info{info},"

\n"; print "

Subscribe to ",$list_info{list_name},":
\n"; print subscribe_form($list_info{list}); } } print(the_html(-Part => "footer", -List => $list_info{list}, -Site_Name => $list_info{website_name}, -Site_URL => $list_info{website_url})); } sub send_archive { my $entry = $q->param('entry'); my $sender_email = $q->param('sender_email'); my $note = $q->param('note'); my $errors = 0; my $list_exists = check_if_list_exists(-List=>$list); user_error(-List => $list, -Error => "no_list") if ($list_exists <=0); $errors++ if(check_for_valid_email($email) == 1); $errors++ if(check_for_valid_email($sender_email) == 1); #if($REFERER_CHECK == 1){ $errors++ if(check_referer($q->referer())) != 1; #} my %list_info = open_database(-List => $list); $errors++ if $list_info{archive_send_form} != 1; if($errors > 0){ print $q->redirect(-uri => $PROGRAM_URL . '?f=archive&l=' . $list . '&id=' . $entry . '&send_archive_errors=' . $errors); }else{ require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives->new(-List => \%list_info); my ($subject, $message, $format) = $archive->get_archive_info($entry); my $plaintext_version; my $html_version; if($format =~ m/HTML/i){ $plaintext_version = convert_to_ascii($message); $html_version = $message; }else{ $message = $archive->zap_sig($message) if ($list_info{stop_message_at_sig} ne "0"); $plaintext_version = $message; require HTML::FromText; $html_version = webify_plain_text($message); } my $pin = make_pin(-Email => $email); my $plaintext_mailing = $list_info{send_archive_message}; $plaintext_mailing =~ s/\[archived_message\]/$plaintext_version/g; my $html_mailing = $list_info{send_archive_message_html}; $html_mailing =~ s/\[archived_message\]/$html_version/g; $plaintext_version = interpolate_string( -String => $plaintext_mailing, -List_Db_Ref => \%list_info, -Email => $email,); $plaintext_version =~ s/\[list_subscribe_link\]/$PROGRAM_URL\?f\=s\&l\=$list\&e\=\[email\]\&p\=\[pin\]/g; $plaintext_version =~ s/\[sender_email\]/$sender_email/g; $plaintext_version =~ s/\[email\]/$email/g; $plaintext_version =~ s/\[note\]/$note/g; $plaintext_version =~ s/\[pin\]/$pin/g; $html_version= interpolate_string(-String => $html_mailing, -List_Db_Ref => \%list_info, -Email => $email,); $html_version =~ s/\[sender_email\]/$sender_email/g; $html_version =~ s/\[email\]/$email/g; $html_version =~ s/\[note\]/$note/g; $html_version =~ s/\[pin\]/$pin/g; require MIME::Lite; my $msg = MIME::Lite->new(Type => 'multipart/alternative'); $msg->attach(Type => 'text/plain', Data => $plaintext_version, Encoding => $list_info{plaintext_encoding}, ); $msg->attach(Type => 'text/html', Data => $html_version, Encoding => $list_info{html_encoding} ); $msg->replace('X-Mailer' =>""); my $header_glob = $msg->header_as_string(); my $message_string = $msg->body_as_string(); require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); my %headers = $mh->return_headers($header_glob); my %mailing = ( From => $sender_email, To => $email, Subject => $subject . ' (Archive)', %headers, Body => $message_string, ); $mh->send(%mailing); print $q->redirect(-uri => $PROGRAM_URL . '?f=archive&l=' . $list . '&id=' . $entry . '&send_archive_success=1'); } } sub archive_rss { my $list_exists = check_if_list_exists(-List=>$list); print $q->header('application/xml'); if ($list_exists == 0){ }else{ my %list_info = open_database(-List => $list); if ($list_info{show_archives} eq "0"){ }else{ if($list_info{publish_archives_rss} eq "0"){ }else{ require DADA::MailingList::Archives; my $archive = DADA::MailingList::Archives->new(-List => \%list_info); print $archive->rss_index(); } } } } sub email_password { require DADA::MailingList::Settings; my $ls = DADA::MailingList::Settings->new(-List => $list); my $list_info = $ls->get; require DADA::Security::Password; if(( $list_info->{pass_auth_id} ne "") && ( defined($list_info->{pass_auth_id})) && ( $q->param('pass_auth_id') eq $list_info->{pass_auth_id})){ my $new_passwd = DADA::Security::Password::generate_password(); my $new_encrypt = DADA::Security::Password::encrypt_passwd($new_passwd); my %new_info = (password => $new_encrypt, pass_auth_id => ''); $ls->save({%new_info}); #my $status = setup_list(\%new_info); #user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; require DADA::Mail::Send; my $mh = DADA::Mail::Send->new($list_info); my $Body = <{list_name} to be emailed to this address. Since you are the list owner, the password is: $new_passwd Notice, you probably didn't use this password to begin with, $PROGRAM_NAME stores passwords that are encrypted and no password it stores can be "unencrypted" So, a new, random password is generated. You may reset the password to anything you want in the list control panel. Please be sure to delete this email for security reasons. -$PROGRAM_NAME EOF ; my %mailing = ( From => $list_info->{list_owner_email}, List => $list, To => '"List Owner for: '. escape_for_sending($list_info->{list_name}) .'" <'. $list_info->{list_owner_email} .'>', Subject => "List Password", Body => $Body, ); $mh->send(%mailing); print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=sign_in&list=$list"); }else{ require DADA::Mail::Send; my $mh = DADA::Mail::Send->new($list_info); my $rand_str = DADA::Security::Password::generate_rand_string(); $ls->save({pass_auth_id => $rand_str}); #user_error(-List => $list, -Error => "no_permissions_to_write") if $status == 0; my $Body = qq{ Hello, Someone asked for the $PROGRAM_NAME List Password password for: $list_info->{list_name} to be emailed to this address. Before this can be done, it has to be confirmed that the list owner (meaning you) actually wants a new password to be set for this list and mailed to you. To confirm this, visit this URL: $S_PROGRAM_URL?f=email_password&l=$list&pass_auth_id=$rand_str By visiting this URL, you will reset the list password. This new password will then be emailed to you. You will then be redirected to the admin login screen. If you do not know why you were sent this email, ignore it and your password will not be changed. -$PROGRAM_NAME }; my %mailing = ( From => $list_info->{list_owner_email}, List => $list, To => '"List Owner for: '. escape_for_sending($list_info->{list_name}) .'" <'. $list_info->{list_owner_email} .'>', Subject => "Confirm List Password Change", Body => $Body, ); $mh->send(%mailing); print(the_html(-Part => "header", -Title => "Confirm Password Change", -List => $list)); print '

A confirmation email has been sent to the list owner of ' . $list_info->{list_name} . 'to confirm the password change.

'; print(the_html(-Part => "footer", -List => $list)); } } sub login { my $location = $q->param('referer') || $DEFAULT_ADMIN_SCREEN; $location = $DEFAULT_ADMIN_SCREEN if $location eq $PROGRAM_URL; my $admin_password = $q->param('admin_password') || ""; my $admin_list = $q->param('admin_list') || ""; $list = $admin_list; if(check_if_list_exists(-List=>$list) >= 1){ my %list_info = open_database(-List => $list); # this is a small (please see that this is a VERY small) security measure. require DADA::Security::Password; my $cipher_pass = DADA::Security::Password::cipher_encrypt($list_info{cipher_key}, $admin_password); # this is here, because in my experience, # the real cookie doesn't get set correctly, and I'm # still trying to figure out why. my $dumb_cookie = $q->cookie( -name => 'blankpadding', -value => 'blank', %COOKIE_PARAMS, ); my $cookie = $q->cookie( -name => $LOGIN_COOKIE_NAME, -value => { admin_list => $admin_list, admin_password => $cipher_pass }, %COOKIE_PARAMS ); if($LOG{logins} != 0){ require DADA::Logging::Usage; my $log = new DADA::Logging::Usage; $log->mj_log($admin_list, 'login', 'remote_host:' . $ENV{REMOTE_HOST} . ', ip_address:' . $ENV{REMOTE_ADDR}); } print $q->header( -cookie => [$dumb_cookie, $cookie], -nph => $NPH, -Refresh =>'0; URL=' . $location, ), $q->start_html( -title=>'Logging On...', -BGCOLOR=>'#FFFFFF' ), $q->p($q->a({-href => $location}, 'Logging On...') ), $q->end_html(); }else{ user_error( -List => $list, -Error => "no_list", ); } } sub logout{ my $location = $PROGRAM_URL; my %login = (); my $l_list = $admin_list; my $cookie = $q->cookie(-name => $LOGIN_COOKIE_NAME, -value => {admin_list => '', admin_password => ''}, -path => '/'); if ($LOG{logins} != 0){ require DADA::Logging::Usage; my $log = new DADA::Logging::Usage; $log->mj_log($l_list, 'logout', "remote_host:$ENV{REMOTE_HOST}, ip_address:$ENV{REMOTE_ADDR}"); } print $q->header( -COOKIE => $cookie, -nph => $NPH, -Refresh =>'0; URL=' . $location, ), $q->start_html( -title=>'Logging Out...', -BGCOLOR=>'#FFFFFF' ), $q->p($q->a( {-href => $location}, 'Logging Out...')), $q->end_html(); } sub send_owner_happenings { my $send_it = 1; my %list_info = open_database(-List => $list); my $status = shift; if($status eq "subscribed"){ if(exists($list_info{get_sub_notice})){ if($list_info{get_sub_notice} eq "0"){ $send_it = 0; } } }elsif($status eq "unsubscribed"){ if(exists($list_info{get_unsub_notice})){ if($list_info{get_unsub_notice} eq "0"){ $send_it = 0; } } } if($send_it == 1){ my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $num_subscribers = $lh->num_subscribers; my $localtime = scalar(localtime()); my $Body = qq{ Hello, This is a quick note to say that $email has $status on list: $list_info{list_name} Server Time: $localtime IP Logged: $ENV{'REMOTE_ADDR'} There are now a total of: $num_subscribers subscribers. -$PROGRAM_NAME }; require DADA::Mail::Send; my $mh = DADA::Mail::Send->new(\%list_info); my %mailing = ( 'Reply-To' => $email, To => '"List Owner for: '. escape_for_sending($list_info{list_name}) .'" <'. $list_info{list_owner_email} .'>', Subject => "$status $email", Body => $Body, ); $mh->send(%mailing); } } sub checker { # I really don't understant how this subroutine got.. invented. my $root_login = check_list_security(-Admin_List => $admin_list, -Admin_Password => $admin_password, -IP_Address => $ENV{REMOTE_ADDR}, -Function => 'checker'); $list = $admin_list; my $add_to_black_list = $q->param('add_to_black_list') || 0; my $lh = DADA::MailingList::Subscribers->new(-List => $list); my $email_count = $lh->remove_from_list(-List => $list, -Email_List => \@address); user_error(-List => $list, -Error => 'no_list') if $email_count eq 'no list'; user_error(-List => $list, -Error => 'too_busy') if $email_count eq 'too busy'; if($add_to_black_list == 1){ $lh->add_to_email_list(-Email_Ref => \@address, -List => $list, -Type => 'black_list'); } print $q->redirect(-uri=>"$S_PROGRAM_URL?flavor=view_list&delete_email_count=$email_count"); } sub file_upload { no strict 'refs'; my @new_names; my $upload_file = shift; my $fu = CGI->new(); my $file = $fu->param($upload_file); if ($file ne "") { my $fileName = $file; $fileName =~ s!^.*(\\|\/)!!; eval {require URI::Escape}; if(!$@){ $fileName = URI::Escape::uri_escape($fileName, "\200-\377"); }else{ warn('no URI::Escape is installed!'); } $fileName =~ s/\s/%20/g; my $outfile = make_safer($TMP . '/' . $fileName); open (OUTFILE, '>' . $outfile) or warn("can't write to " . $outfile . ": $!"); while (my $bytesread = read($file, my $buffer, 1024)) { print OUTFILE $buffer; } close (OUTFILE); chmod($FILE_CHMOD, $outfile); return $outfile; } } sub pass_gen { my $pw = $q->param('pw'); #print header(); print(the_html(-Part => "header", -Title => "Password Encryption")); if(!$pw){ print $q->p("Enter a password that you would like to encrypt.", $q->hidden('f', 'pass_gen'), $q->password_field(-name=>'pw', -size=>8), $q->submit(-value=>'encrypt password')); }else{ require DADA::Security::Password; my $en_pw = DADA::Security::Password::encrypt_passwd($pw); print $q->p('Your encrypted password is:'), $q->p($en_pw), $q->p('Use this password as your ', $q->b('$PROGRAM_ROOT_PASSWORD'), 'and set ', $q->b('$ROOT_PASS_IS_ENCRYPTED'), 'to 1'), $q->p("When asked for your $PROGRAM_NAME Root Password, you will still need to type in the unencrypted pasword, not this gobble-dee-gook."); } print(the_html(-Part => "footer")); } sub setup_info { my $root_password = $q->param('root_password'); my $root_pass_check = root_password_verification($root_password); if($root_pass_check == 1){ #print header(); print(the_html(-Part => "header", -Title => "Setup Information")); print $q->p('The $FILES variable has been set to:', $q->br(), $q->b($FILES)); unless(-e $FILES){ print $q->p($q->b('Warning!'), 'It does not seem that this directory exists.'); if($FILES !~ m/^\//){ print $q->p('Make sure that $FILES is an absolute path to a directory, this usually means starting the path with a "/"'); } if($FILES =~ m/\/$/){ print $q->p('Make sure that $FILES does not end with a "/"'); } if($ENV{DOCUMENT_ROOT}){ my $home_guess = $ENV{DOCUMENT_ROOT}; my $pub_html_dir = $home_guess; $pub_html_dir =~ s(^.*/)(); $home_guess =~ s/\/$pub_html_dir$//g; print $q->p('You\'re Public HTML directory is:', $q->br(), $q->b($ENV{DOCUMENT_ROOT}), $q->br(), 'Usually, this directory is below your home directory. A good guess on where your home directory would be located is:', $q->br(), $q->b($home_guess), $q->br(), 'It is suggested that you set the $FILES variable to be a directory that\'s in your home directory.'); } } print $q->hr(); print $q->p('The $MAILPROG variable has been set to:', $q->br(), $q->b($MAILPROG)); my $sendmail; $sendmail =`whereis sendmail` if ($OS !~ /^Win|^MSWin/i); my @sendmails = split(" ", $sendmail); print $q->p("Paths to sendmail have been found in these locations:"); print $q->p($_) foreach(@sendmails); print $q->p("Not all these paths are locations to sendmail, but should be included within them."); print(the_html(-Part => "footer")); }else{ #print header(); print(the_html(-Part => "header", -Title => "Setup Information")); print $q->end_form(); if(($PROGRAM_URL eq "") || ($PROGRAM_URL eq 'http://www.changetoyoursite.com/cgi-bin/dada/mail.cgi')){ $PROGRAM_URL = $q->script_name(); } print $q->start_form(-method => 'Post', -action => $PROGRAM_URL); print $q->p("Please enter the correct Dada Mail Root Password to continue:", $q->br(), $q->hidden('flavor', 'setup_info') , $q->password_field('root_password', ''), $q->submit('Continue')); print(the_html(-Part => "footer")); } } sub reset_cipher_keys { my $root_password = $q->param('root_password'); my $root_pass_check = root_password_verification($root_password); if($root_pass_check == 1){ require DADA::Security::Password; my @lists = available_lists(); foreach(@lists){ setup_list({list=> $_, cipher_key => DADA::Security::Password::make_cipher_key()}); } print(the_html(-Part => "header", -Title => "Reset Cipher Keys")); print $q->p("Cipher keys have been reset."); print(the_html(-Part => "footer")); }else{ print(the_html(-Part => "header", -Title => "Reset Cipher Keys")); print $q->p("Please enter the correct $PROGRAM_NAME Root Password to continue, every list cipher key will be reset:", $q->br(), $q->hidden('flavor', 'reset_cipher_keys') , $q->password_field('root_password', ''), $q->submit('Continue')), $q->p('Why would you want to do this? If you are upgrading Dada Mail from any version under 2.7.1, your list needs a cipher key to encrypt sensitive information.'); print(the_html(-Part => "footer")); } } sub restore_lists { if(root_password_verification($q->param('root_password'))){ require DADA::MailingList::Settings; require DADA::MailingList::Archives; my @lists = available_lists(); if($process eq 'true'){ my %restored; foreach my $r_list(@lists){ if($q->param('restore_'.$r_list.'_settings') && $q->param('restore_'.$r_list.'_settings') == 1){ my $ls = DADA::MailingList::Settings->new(-List => $r_list); $ls->{ignore_open_db_error} = 1; $ls->restoreFromFile($q->param('settings_'.$r_list.'_version')); } } foreach my $r_list(@lists){ if($q->param('restore_'.$r_list.'_archives') && $q->param('restore_'.$r_list.'_archives') == 1){ my $ls = DADA::MailingList::Settings->new(-List => $r_list); $ls->{ignore_open_db_error} = 1; my $la = DADA::MailingList::Archives->new(-List => {list => $r_list}); $la->{ignore_open_db_error} = 1; $la->restoreFromFile($q->param('archives_'.$r_list.'_version')); } } print(the_html(-Part => "header", -Title => "Restore List Information - Complete.")); print $q->p("List Information restored."); print $q->p("Return to the $PROGRAM_NAME main page."); print(the_html(-Part => "footer")); }else{ my $backup_hist = {}; foreach(@lists){ my $ls = DADA::MailingList::Settings->new(-List => $_); $ls->{ignore_open_db_error} = 1; my $la = DADA::MailingList::Archives->new(-List => {list => $_}); #yeah, it's diff from MailingList::Settings - I'm stupid. $la->{ignore_open_db_error} = 1; $backup_hist->{$_}->{settings} = $ls->backupDirs; $backup_hist->{$_}->{archives} = $la->backupDirs; } print(the_html(-Part => "header", -Title => "Restore List Information")); print $q->p($q->strong("Before restoring ANY of your list settings, please make on server and remote backups of all your $PROGRAM_NAME list files, no matter what facility they are in.")); print $q->p("Please also make sure your list settings are indeed corrupted and not just unreadable because of insufficient file permissions or wrong \@AnyDBM_File Config.pm settings."); # labels are for the popup menus, that's it # my %labels; foreach (sort keys %$backup_hist){ foreach(@{$backup_hist->{$_}->{settings}}){ $labels{$_} = scalar(localtime($_)); } foreach(@{$backup_hist->{$_}->{archives}}){ $labels{$_} = scalar(localtime($_)); } } # # foreach my $f_list(keys %$backup_hist){ print $q->start_table({-cellpadding => 5}); print $q->h3($f_list); print $q->Tr( $q->td({-valign => 'top'}, [ ($q->p($q->strong('Restore?'))), ($q->p($q->strong('Backup Version*:'))), ])); foreach ('settings', 'archives'){ if (scalar @{$backup_hist->{$f_list}->{$_}}){ print $q->Tr( $q->td([ ($q->p($q->checkbox( -name => 'restore_'.$f_list.'_'.$_, -value => 1, -label => ' ', ), $q->strong($_))), ($q->p($q->popup_menu( -name => $_ . '_' . $f_list . '_version', '-values' => $backup_hist->{$f_list}->{$_}, -labels => {%labels}))), ])); }else{ print $q->Tr( $q->td([ (' '), ($q->p({-class => 'smallred'}, '-- No Backup Information Found --')), ])); } } print ''; } print $q->p($q->em('*The most recent backup is usually the best')); print $q->hidden('flavor', 'restore_lists'); print $q->hidden('root_password', $q->param('root_password')); print $q->hidden('process', 'true'); #print $q->submit( -value => "Restore Checked List's Settings"); print submit_form(-Submit=>'Restore Checked List\'s Data'); print(the_html(-Part => "footer")); } }else{ print(the_html(-Part => "header", -Title => "Restore List Information")); print $q->p("Please enter the correct $PROGRAM_NAME Root Password to begin restoring list settings:", $q->br(), $q->hidden('flavor', 'restore_lists') , $q->password_field('root_password', ''), $q->submit('Continue...')); print(the_html(-Part => "footer")); } } sub redirection { require DADA::Logging::Clickthrough; my $r = DADA::Logging::Clickthrough->new($q->param('l')); $r->r_log($q->param('mid'), $q->param('url')); if($q->param('url')){ print $q->redirect(-uri => $q->param('url')); }else{ print $q->redirect(-uri => $PROGRAM_URL); } } sub author { print $q->header(); print "Dada Mail is originally written by Justin Simoni"; } sub smtm { # SHOW ME THE MONEY! print $q->redirect(-uri => 'http://mojo.skazat.com'); } sub chocolate {print $q->header();print $q->h1('chocolate? don\'t make me run! i\'m full of chocolate!');} sub _chk_env_sys_blk { if($ENV{QUERY_STRING} =~ /^\x61\x72\x74/){ eval {require DADA::Template::Widgets::janizariat::tatterdemalion::jibberjabber}; if(!$@){ DADA::Template::Widgets::janizariat::tatterdemalion::jibberjabber::thimblerig($ENV{QUERY_STRING}); exit; } } } __END__ =pod =head1 COPYRIGHT Copyright (c) 1999 - 2004 Justin Simoni me@justinsimoni.com http://justinsimoni.com All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. =cut