=pod

=head1 NAME


MOJO::Guts

=head1 SYNOPSIS 

	use MOJO::Guts; 
	

This is the belly of the beast. Many functions of Mojo Mail are in here and 
they deal with all sorts of things that are above the breath of this synopsis. 


=head1 DESCRIPTION

This module will soon fade away and be cut up into a few other modules, 
hopefully sooner than later

All functions that delt with subscription/unsubscription from lists have been moved
into the MOJO::List::* namespace

B<In the Future> This module will be tentitively cut up into

	MOJO::CGI_Security 
	MOJO::Settings or MOJO::List::Settings 
	MOJO::Templates 

plus a few other surprises

=head1 SUBROUTINES

=cut




package MOJO::Guts;
use lib qw(./ ../); 


use Fcntl qw(
O_WRONLY 
O_TRUNC 
O_CREAT 
O_CREAT 
O_RDWR
O_RDONLY
LOCK_EX
LOCK_SH 
LOCK_NB); 

use AnyDBM_File; 

use MOJO::Log;
my $log =  new MOJO::Log;

use MOJO::Config; 

require Exporter; 
@ISA = qw(Exporter); 

@EXPORT = qw(
check_for_valid_email
strip 
pretty 
make_pin
check_email_pin
available_archives 
make_template
delete_list_template
delete_list_archive
delete_list_info
delete_email_list
check_if_list_exists
available_lists
archive_message
open_database
setup_list
date_this
convert_to_ascii
uriescape
lc_email
subscribe_form
make_safer
urlify
interpolate_string
webify_plain_text
check_list_setup
make_all_list_files
check_admin_cgi_security
enforce_admin_cgi_security
message_id
subscribe_link
unsubscribe_link

check_list_security
user_error
check_setup

cased
root_password_verification
xss_filter
);



use strict; 
use vars qw(@EXPORT); 


=pod

=over

=item check_for_valid_email

	$e_test = check_for_valid_email($email_address); 

returns 1 if the email is invalid. 

But will return 0 if an email is invalid if you
specify that addres in the B<@EMAIL_EXCEPTIONS> array in the Config file. Good for testing. 


=cut


sub check_for_valid_email { 

# This subroutine is modified out of BulkMail 2.0 by
# James A Thomason III (jim3@psynet.net)
# Thanks James
    
	my $email = shift or undef;
	my $email_check = 0; 
	
	my $atom = q<[!#$%&'*+\-/=?^`{|}~\w]>;
	my $qstring = q/"(?:[^"\\\\\015]|\\\.)+"/;
	my $word = "($atom+|$qstring)";
	$email =~ m/^$word\s*\<\s*(.+)\s*\>\s*$/;			#match beginning phrases
	
	$email = $2 if $2;									#if we've got a phrase, we've extracted the e-mail address
														#and stuck it in $2, so set $email to it.
														#if we didn't have a phrase, the whole thing is the e-mail address
	
unless($email =~ m<
							^\s*($word					#any word (see above)
							(?:\.$word)*				#optionally followed by a dot, and more words, as many times as we'd like
							@							#and an at symbol
							$atom+						#followed by as many atoms as we want
							(?:\.$atom+)*				#optionally followed by a dot, and more atoms, as many times as we'd like
							\.[a-zA-Z]{2,4})\s*$		#followed by 2 or 4 letters
							>xo){ 
		 $email_check =  1; 
							
}

	my %exceptions; 
	foreach(@EMAIL_EXCEPTIONS){$exceptions{$_}++} 
	$email_check = 0 if exists($exceptions{$email}); 	
	return $email_check; 

}
							
							
							
							
=pod

=item strip

	my $str = strip($str);  
   
a simple subroutine to take off leading and trailing white spaces

=cut

sub strip { 
my $string = shift || undef; 
	if($string){ 
		$string =~ s/^\s+//o;
		$string =~ s/\s+$//o;
		return $string;
	}else{ 
		return undef; 
	}
}


=pod

=item pretty

	$str = pretty($str); 

a simple subroutine to turn underscores to whitespace

=cut

sub pretty { 
	my $string = shift ||undef; 

	if($string){ 
		$string =~ s/_/ /gio; 
		return $string; 
	}else{ 
		return undef;
	}

}

=pod

=item make_pin 

	$pin = make_pin(-Email => $email); 

Returns a pin number to validate subscriptions 

You can change how the pin number is generated a few ways;

There are two variables in the Config.pm file called the $PIN_WORD and the $PIN_NUM, 
they'll change the outcome of $pin, The algorithym to make a pin number isn't 
that sophisticated, I'm not trying to keep a nuclear submarine from launching its missles, 
although if you create your own $PIN_NUM and $PIN_WORD, it'll be pretty hard to decipher 
6230 from justin@skazat.com 

=cut


sub make_pin {
my %args = ( 
-Email      => undef, 
@_
); 


my $email = $args{-Email} || undef;
my $pin = 0; 

if($email){ 

# theres probably a better way to do this, but a mathematician 
# I am not. 

# make a pin by getting the ASCII values of the string? 
# I forget exactly how this works, and I'm sick, but 
# It gives me a bunch of numbers and does it the same each time, 
# Like Isaid, I aint no mathemagician. 
$pin = unpack("%32C*", $email);

# do the same with some word you pick 
my $pin_helper = unpack("%32C*", $PIN_WORD);
 
# make the pin by adding the $pin and $PIN_NUMber together, 
# multiplying by a number you can pick 
# and subtract that number by the $pin helper. 

$pin = ((($pin + $pin_helper) * $PIN_NUM) - $pin_helper); 

# give it back. 
return $pin; 

}else{ 

return undef;

}
}

=pod

=item check_email_pin

	my $check = check_email_pin(-Email=>$email, -Pin=> $pin);  

checks a given e-mail with the given pin, 
returns 1 on success, 0 on failure.

=cut

sub check_email_pin { 

my %args = ( 
-Email      => undef, 
-Pin        => undef, 
@_
); 



my $email = $args{-Email} || undef;
my $pin   = $args{-Pin}   || undef; 

if($pin and $email){ 
#see how we make a pin, just do the reverse. 
my $invalid_pin = 0; 
my $check_pin = unpack("%32C*", $email);
my $pin_helper = unpack("%32C*", $PIN_WORD);
$check_pin = ((($check_pin + $pin_helper) * $PIN_NUM) - $pin_helper);


  if ($check_pin != $pin){
      $invalid_pin++;
      }
return  $invalid_pin; 
}else{ 

return 1; 
}
}


=pod

=item available_archives

	my @archives = available_archives();

s
Pleae don't use this if you can help it 


=cut

sub available_archives { 

my %args = ( 
-Path      => $ARCHIVES, 
@_); 



my @all_dbs = ();
my @available_lists = (); 
my @available_archives = ();
my $path = $args{-Path};

 
 
my $present_list;
opendir(LISTS, $path) or die "$PROGRAM_NAME $VER error, can't open $path to read: $!"; 
while(defined($present_list = readdir LISTS) ) { 

#don't read '.' or '..'
next if $present_list =~ /^\.\.?$/;


# this reg/ex takes all file directory info off, so all we get is a
# list of all the files.  
# this is also somewhat a security feature, we don't 
#people to know the path to the script now do we? 

 $present_list =~ s(^.*/)();
 
  
#don't read anything that doesn't have an 'mj' in its filename at the beginning.  
next if $present_list !~ /^mj-.*$/; 

 $present_list =~ s/mj-//;

 $present_list =~ s/(\.dir|\.pag|\.db)$//;
 
  push(@all_dbs, $present_list);                             
     
}

closedir(LISTS);
     
     foreach my $all_those(@all_dbs) { 
	     if($all_those =~ m/.*-archive/) { 
		      push( @available_archives, $all_those)
	     }
     }    
     
     
@available_archives = sort(@available_archives); 
my %seen = (); 
my @unique = grep {! $seen{$_} ++ }  @available_archives; 
return @unique; 

} 


=pod

=item make_template


	make_template(-Path     => $path, 
	              -List     => $list, 
	              -Template => $template);

takes where you want the template to be saved, 
the list that this template belongs to and the actual data to be saved in the 
template and saved this to a file. Usually, a template file is made when a 
list is created, using either the default Mojo Mail template, or if you 
specified a $DEFAULT_LIST in the Config.pm file, it'll use that template. 

Templates are stored in the $TEMPLATES directory (which is usually set the same as $FILES)
under the name $listname.template, where $listname is the List's shortname.

=cut

sub make_template { 

my %args = ( 
-Path      => $TEMPLATES, 
-List      => undef, 
-Template  => undef,
@_
); 




#get the variable
my $print_template = $args{-Template};
my $list_path = $args{-Path};
my $list_template = $args{-List} || undef; 


if($list_template){ 
	#untaint 
	$list_template = make_safer($list_template); 
	$list_template =~ /(.*)/; 
	$list_template = $1; 


	sysopen(TEMPLATE, "$list_path/$list_template.template",  O_WRONLY|O_TRUNC|O_CREAT,  $FILE_CHMOD) or 
		die "$PROGRAM_NAME $VER Error: can't write new template at '$list_path/$list_template.template': $!"; 

	flock(TEMPLATE, LOCK_EX) or 
		die "$PROGRAM_NAME $VER Error: can't lock to write new template at '$list_path/$list_template.template': $!" ; 
	
	print TEMPLATE $print_template;
	
	close(TEMPLATE); 

	}else{ 

	warn('$PROGRAM_NAME Error: no list name was given to save new template');
	return undef;
	
	}
}



=pod

=item delete_list_template

	delete_list_template(-Path => $path, -List => $list); 


deletes a template file for a list. 

=cut

sub delete_list_template { 

my %args = ( 
-Path      => $TEMPLATES, 
-List      => undef, 
@_
);


my $FILES = $args{-Path};
my $list = $args{-List} || undef; 

if($list){
my $deep_six = "$FILES/$list.template";
unlink($deep_six);

}else{ 

warn('$PROGRAM_NAME Error: No list name given to delete list template');
return undef;
}

}

=pod

=item delete_list_archive

	delete_list_archive(-Path => $path, -List => $list); 
 
deletes the archive  file for a list. 

=cut

sub delete_list_archive { 
	my %args = (-Path => $ARCHIVES, 
				-List => undef, 
				@_);
				
	my $FILES = $args{-Path};
	my $list  = $args{-List} || undef; 
	
	if($list){ 
		my $deep_six;
		while (defined($deep_six = <$FILES/mj-archive*>)){
			if(($deep_six =~ m/mj-archive-$list\.(.*)/) || ($deep_six =~ m/(mj-archive-$list)$/))  { 
		  		unlink($deep_six); 
		  	}		 
		}
	}else{ 
		warn('$PROGRAM_NAME Error: No list name given to delete archive database');
		return undef;
	}     	 
}

=pod

=item delete_list_info

	delete_list_info(-Path => $path, -List => $list); 

deletes the db file for a list. 

=cut

sub delete_list_info { 

	my %args = ( 
	-Path      => $FILES, 
	-List      => undef, 
	@_);
	
	my $FILES = $args{-Path};
	my $list  = $args{-List} || undef; 
	
	if($list){ 
		my $deep_six;
	
	
		opendir(LISTS, $FILES) or die "can't open '$FILES' to read: $!";
		while(defined($deep_six = readdir LISTS)) {
			#don't read '.' or '..'
			next if $deep_six =~ /^\.\.?$/; 
			if(($deep_six =~ m/mj-$list\.(.*)/) || ($deep_six =~ m/(mj-$list)$/)) { 
				 unlink("$FILES/$deep_six"); 
			} 
		 }
	}else{ 
		warn('$PROGRAM_NAME Error: No list name given to delete list database');
		return undef;
	}

}

=pod

=item delete_email_list

	delete_email_list(-Path => $path, -List => $list); 

deletes the email list for a list. 

=cut

sub delete_email_list { 

my %args = ( 
-Path      => $FILES, 
-List      => undef, 
@_
);

my $FILES = $args{-Path}  || undef;
my $list  = $args{-List}  || undef; 

if($FILES and $list){


my $deep_six = "$FILES/$list.list";

unlink($deep_six);
}else{ 
warn('$PROGRAM_NAME Error: No list name given to delete e-mail list');
return undef;
}
}

=pod

=item check_if_list_exists

	check_if_list_exists(-List => $list, -Path => $path); 

checks to see if theres a filename called $list
returns 1 for success, 0 for failure. 

=cut
sub check_if_list_exists { 
	
	my %args = (-List => undef, 
				-Path => $FILES, 
				@_); 
	
	if($args{-List}){ 
	
		my (@available_lists) = available_lists(-Path => $args{-Path});
		my $list_exists = 0;
	
		my $might_be;
		foreach $might_be(@available_lists) {
			if ($args{-List} ne ""){  
				if ($might_be eq $args{-List}) { 
				  $list_exists++;
				}
			}    
	 	}
	 	return $list_exists; 
	}
}

=pod

=item available_lists

	available_lists(-Path => $path);

returns a @list of all Mojo lists available at $path

=cut

sub available_lists { 

my %args = ( 
-Path     => $FILES, 
-As_Ref   => 0,
-In_Order => 0,
@_
); 

my @dbs = ();
my @available_lists = (); 
my $present_list;
my $path = $args{-Path};
my $want_ref = $args{-As_Ref};


# this is the old school way of doing it i suppose.. 
#while (defined($present_list = <$path/mj-*>)){

 
 
 #untaint 
$path = make_safer($path); 
$path =~ /(.*)/; 
$path = $1; 


opendir(LISTS, $path) 
	or die "$PROGRAM_NAME $VER error, please MAKE SURE that '$path' is a directory (NOT a file) and that Mojo Mail has enough permissions to write into this directory: $!"; 
while(defined($present_list = readdir LISTS) ) { 

#don't read '.' or '..'
next if $present_list =~ /^\.\.?$/;


# this reg/ex takes all file directory info off, so all we get is a
# list of all the files.  
# this is also somewhat a security feature, we don't 
#people to know the path to the script now do we? 

 $present_list =~ s(^.*/)();
 
  
#don't read anything that doesn't have an 'mj' in its filename at the beginning.  
next if $present_list !~ /^mj-.*$/; 


 
#db files have a "mj-" beginning, just to keep them apart
#we'll take that off. 

 $present_list =~ s/mj-//;

# alright, this is the dot in the name reg/ex, this 
# won't strip the string of a dot in the name, but will 
# take off any known file endings. 
# hopefully, there won't be people that have a list name 
# that has .dir, .pag or .db as the end of the list name. 
# its that .01% that gets me!
 $present_list =~ s/(\.dir|\.pag|\.db)$//;

#now, we'll take off the ".list" and ".template" endings
# if for some reason, they sneaked through
$present_list =~ s/(\.list|\.template)$//;
 
next if $present_list eq ""; # hey, you never know.

# ok, if we haven't blown the string to smitherines, put it 
# in the list of hopefuls
    if(defined($present_list) && $present_list ne "" && $present_list !~ m/^\s+$/) 
        {push(@dbs, $present_list); }                            
    
    
 }
     foreach my $all_those(@dbs) {   
       
       # we don't want the archive db's for our count.  
      if($all_those !~ m/-archive.*/) { 
        push( @available_lists, $all_those)
      }
}    



#give me just one occurence of each name
my %seen = (); 
my @unique = grep {! $seen{$_} ++ }  @available_lists; 

my @clean_unique; 

foreach(@unique){ 
	if(defined($_) && $_ ne "" && $_ !~ m/^\s+$/){ 
		push(@clean_unique, $_);
	}
}

if($args{-In_Order} == 1){ 

	my $labels = {}; 
	foreach my $l( @clean_unique){
		my %li = open_database(-List => $l);
		#next if $args{-show_hidden} == 0 && $li{hide_list} eq '1'; 
		$labels->{$l} = $li{list_name};
	}
			
	@clean_unique = sort { uc($labels->{$a}) cmp uc($labels->{$b}) } keys %$labels;
				
				          
}



#and give it back to me!

if($want_ref == "1"){ 
return \@clean_unique;
}else{
return @clean_unique; 
}

} 

=pod

=item open_database

	my %list_info = open_database(-List => $list, 
	                              -Path => $path, 
	                              -Format=> $format); 

returns a hash that has all the saved list information, such as the list name, 
description, private policy statement, list administrator, list owner, various 
cusomizations

the -Format flag is used to control how the information is given in the hash, 
you can set this to "replaced" and any psuendo tags that look like [this] 
will be changed to what the really are, example: 

[list_info] in the 'mailing_list_message' value will be changed to the description value. 
this is mostly for email message customization. 


=cut

sub open_database { 
	my %args = ( 
	-List => undef, 
	-Path => $FILES, 
	-Format => "raw", 
	@_); 

	my $db = $args{-List} || undef;
	$db = strip($db);
	if($db){  
		my $FILES = $args{-Path};
		my %list_info; 
		if ($db ne ""){ 
	   		if(check_if_list_exists(-List => $db) == 0){ 
		 		warn "$PROGRAM_NAME ERROR = no such list ($db)!";
				return ();
			}
		
			$db =~ s/ /_/g; 
			$db = "$FILES/mj-$db";  
			#untaint 
			$db = make_safer($db); 
			$db =~ /(.*)/; 
			$db = $1;
	
	 
			my %INFO;
			tie %INFO, "AnyDBM_File", $db,  O_RDWR|O_CREAT, $FILE_CHMOD  or die "couldn't tie $db for reading: $!"; 
			%list_info = %INFO;
			untie %INFO;
	
			#if we don't have a list administrator, use the list owner, 
				 
			$list_info{admin_email} ||= $list_info{mojo_email}; 
			######################################################
			#use default values if we don't have any saved ones. #
	
			$list_info{subscribed_message}              ||=   $SUBSCRIBED_MESSAGE; 
			$list_info{unsubscribed_message}            ||=   $UNSUBSCRIBED_MESSAGE; 
			$list_info{confirmation_message}            ||=   $CONFIRMATION_MESSAGE;
			$list_info{unsub_confirmation_message}      ||=   $UNSUB_CONFIRMATION_MESSAGE;
			$list_info{mailing_list_message}            ||=   $MAILlING_LIST_MESSAGE;
			$list_info{mailing_list_message_html}       ||=   $MAILlING_LIST_MESSAGE_HTML;
			$list_info{not_allowed_to_post_message}     ||=   $NOT_ALLOWED_TO_POST_MESSAGE; 
			$list_info{html_confirmation_message}       ||=   $HTML_CONFIRMATION_MESSAGE;
			$list_info{html_unsub_confirmation_message} ||=   $HTML_UNSUB_CONFIRMATION_MESSAGE;
			$list_info{html_subscribed_message}         ||=   $HTML_SUBSCRIBED_MESSAGE;
			$list_info{html_unsubscribed_message}       ||=   $HTML_UNSUBSCRIBED_MESSAGE;
	
			# wish i remember what this did...
			my $charset_info = $list_info{charset};
			my (@foo) = split(/\s/, $list_info{charset}); 
			$list_info{charset_value} = $foo[$#foo];                    
		
			#listname is usually saved Like_this this gets the spaced out. 
			if(!exists($list_info{list_name})){ 
				$list_info{list_name} = $list_info{list}; 
				$list_info{list_name} =~ s/_/ /g;
			}
		}

		%list_info = (%LIST_SETUP_DEFAULTS, %list_info);
		# special case 
		#$list_info{smtp_server} = $LIST_SETUP_DEFAULTS{smtp_server} if ($list_info{smtp_server} eq '') && ($LIST_SETUP_DEFAULTS{smtp_server} ne undef);
		
		
		%list_info = (%list_info, %LIST_SETUP_OVERRIDES);
		
		
	   if($args{-Format} eq "replaced"){ 
	 	  my $pretty_list = pretty($list_info{list}); 
		  for(   $list_info{subscribed_message},
				  $list_info{unsubscribed_message},
				  $list_info{confirmation_message},
				  $list_info{mailing_list_message},
				  $list_info{not_allowed_to_post_message},
				  $list_info{html_confirmation_message},
				  $list_info{html_unsub_confirmation_message},
				  $list_info{html_subscribed_message},
				  $list_info{html_unsubscribed_message},
				  $list_info{unsub_confirmation_message}, 
				  
				  ){ 
				#change the [template] tags to $real variables... 
				$_ =~ s/\[list_name\]/$list_info{list_name}/g;
				$_ =~ s/\[list_info\]/$list_info{info}/g;
				$_ =~ s/\[list_privacy_policy\]/$list_info{private_policy}/g;
				$_ =~ s/\[list_owner_email\]/$list_info{mojo_email}/g;
				$_ =~ s/\[list_admin_email\]/$list_info{admin_email}/g; 
				$_ =~ s/\[mojo_url\]/$MOJO_URL/g; 
			}
		} 
		return %list_info;
	}else{ 
		warn "$PROGRAM_NAME error, no list name ($db) provided!";
		return ();
	}
}

=pod

=item archive_message

	archive_message(
	-List    =>  $list,
	-Subject =>  $message_subject, 
	-Body    =>  $message_body, 
	-Id      =>  $message_id, 
	-Format  =>  $archive_format
	); 
	

saves mass mailing messages in a db file 
the -Id flag should be made from the date, so when you go and make an index of all of em, 
they'll be in order. 

Again, don't use this, use Archive.pm, this is just hanging around for no real reason

=cut
 
sub archive_message{ 

my %args = (
-List    =>  undef, 
-Subject =>  undef, 
-Body    =>  undef, 
-Id      =>  undef, 
-Format  =>  undef,
@_
); 


my $list_archive    = $args{-List}    || undef;


if($list_archive){ 
my $message_subject = $args{-Subject} || " "; 
my $message_body    = $args{-Body}    || " "; 
my $message_id      = $args{-Id}      || " "; 
my $archive_format  = $args{-Format}  || " "; 
#archives the message when mass mailed. 

my $archive_db = "$list_archive-archive";
my $archive_subject = $message_subject; 

my $archive_message = "$archive_subject\[::\]$message_body\[::\]$archive_format";



#untaint 
$archive_db = make_safer($archive_db); 
$archive_db =~ /(.*)/; 
$archive_db = $1; 


#open the archive and save it. 
my %Archive; 
tie %Archive, 'AnyDBM_File', "$FILES/mj-$archive_db", O_RDWR|O_CREAT, $FILE_CHMOD or die "couldn't tie $FILES/$archive_db for reading"; 
$Archive{$message_id} = $archive_message;
untie %Archive;
}
}




=pod

=item setup_list

	setup_list(\%list_hash_ref);

tTkes a hashref and changes information in the db file. 
this db file holds maost of the config information abut the list, 
such as the name of the list, the description, private policy, 
any mail messages cutomizations, email address, and even the password (in an encrypted form) 
returns 1 on sucess, 0 on failure, the failure could because the db file isn't writable, the directory is wrong,
or who knows. Usually you just need to chmod 777 the directory your trying to write to or be sure its a directory that exists. 

the list_name is sent within the hashref, kinda like this: 

	my %new_info = ( 
	list     => $list,  
	password => $new_encrypt
	); 
	
	my $status = setup_list(\%new_info);
	user_error("no_permissions_to_write") if $status == 0; 

=cut


sub setup_list { 

	my $fault = 1; 
	my $new_info_ref = shift || undef;
	if($new_info_ref){ 
 		my %new_info = %$new_info_ref; 
		my $db = "$new_info{list}";
		   $db = "mj-$db"; 
 	    my %merge_info;  
        my %INFO;

		#untaint 
		$db = make_safer($db); 
		$db =~ /(.*)/; 
        $db = $1;
		tie %INFO, "AnyDBM_File", "$FILES/$db",  O_RDWR|O_CREAT, $FILE_CHMOD  or $fault = 0;  
		my %old_info = %INFO; 
		%merge_info  = (%old_info, %new_info); 
		%INFO        = %merge_info;  
		unless(defined($INFO{admin_menu})){ 
			require MOJO::Widgets::Admin_Menu; 
			$INFO{admin_menu} = MOJO::Widgets::Admin_Menu::create_save_set();
		}
		unless(defined($INFO{cipher_key})){ 
			require MOJO::Password; 
			$INFO{cipher_key} = MOJO::Password::make_cipher_key();
		}
		
		untie %INFO; 
		return $fault; 
     }
 }    
     

=pod

=item date_this

	my $readable_date =	date_this($packed_date)


this takes a packed date, say, the key of an archive 
entry and transforms it into an html data. 
the date is packed as

yyyymmdd

where, yyyy is the year in this form: 2000 
       mm   is the month in this form: 01 
       dd is the day in this for       31

it returns something that looks like this:

	<i>Sent January 1st, 2001</i>



=cut


sub date_this { 

# dates look ike this: 
# 20001209154914
# 2000#12#09#15#49#14


my %args = (
 -Packed_Date   => undef,
 -Write_Month   => 1,
 -Write_Day     => 1,
 -Write_Year    => 1,
 -Write_H_And_M => 0,
 -Write_Second  => 0,
 -All           => 0,
@_,
); 

if($args{-All} == 1){ 
$args{-Write_Month}   = 1, 
$args{-Write_Day}     = 1,
$args{-Write_Yearl}   = 1, 
$args{-Write_H_And_M} = 1,
$args{-Write_Second}  = 1;
} 




my $packed_date = $args{-Packed_Date} || undef; 

if($packed_date) { 


my $year      = substr($packed_date, 0,  4)   || "";
my $num_month = substr($packed_date, 4,  2)   || ""; 
my $day       = substr($packed_date, 6,  2)   || "";
my $hour      = substr($packed_date, 8,  2)   || "";
my $minute    = substr($packed_date, 10, 2)   || ""; 
my $second    = substr($packed_date, 12, 2)   || "";
my $ending    = "am"; 


if($hour < 10){ 
$hour = $hour/1; 
}
if($hour > 12){ 
$hour = $hour - 12; 
$ending = "pm";
}




my %months = (
'01'   => "January",
'02'   => 	"February",
'03'   => 	"March",
'04'   => 	"April",
'05'   =>	"May",
'06'   =>	"June",
'07'   =>	"July",
'08'   =>	"August",
'09'   =>	 "September",
'10'   => 	"October",
'11'   => 	"November",
'12'   => 	"December"
);


my %end = (
'01'   => "1st",
'02'   => 	"2nd",
'03'   => 	"3rd",
'04'   => 	"4th",
'05'   =>	"5th",
'06'   =>	"6th",
'07'   =>	"7th",
'08'   =>	"8th",
'09'   =>	"9th",
'10'   => 	"10th",
'11'   => 	"11th",
'12'   => 	"12th",
'13'   =>   "13th",
'14'   =>   "14th", 
'15'   =>   "15th", 
'16'   =>   "16th", 
'17'   =>   "17th",
'18'   =>   "18th", 
'19'   =>   "19th", 
'20'   =>   "20th", 
'21'   =>   "21st", 
'22'   =>   "22nd", 
'23'   =>   "23rd",
'24'   =>   "24th", 
'25'   =>   "25th", 
'26'   =>   "26th", 
'27'   =>   "27th", 
'28'   =>   "28th", 
'29'   =>   "29th", 
'30'   =>   "30th", 
'31'   =>   "31st", 
);

my $date = ""; 
   $date .= "$months{$num_month} "   if defined($args{-Write_Month})   == 1; 
   $date .= "$end{$day},  "          if defined($args{-Write_Day})     == 1; 		
   $date .= "$year "                 if defined($args{-Write_Year})    == 1; 
   $date .= "$hour:$minute"          if defined($args{-Write_H_And_M}) == 1; 
   $date .= ":$second "              if defined($args{-Write_Second})  == 1; 
   $date .= "$ending  "              if defined($args{-Write_H_And_M}) == 1; 

return $date; 

}
}

=pod

=item convert_to_ascii

	$string = convert_to_ascii($string); 

takes a string and dumbly strips out HTML tags, 

=cut
 


sub convert_to_ascii { 



# #alternative code....
# my $message_body = $_[0];
# 
# 
# 
#     my %entity = (
# 
#         lt     => '<',     #a less-than
#         gt     => '>',     #a greater-than
#         amp    => '&',     #a nampersand
#         quot   => '"',     #a (verticle) double-quote
# 
#         nbsp   => chr 160, #no-break space
#         iexcl  => chr 161, #inverted exclamation mark
#         cent   => chr 162, #cent sign
#         pound  => chr 163, #pound sterling sign CURRENCY NOT WEIGHT
#         curren => chr 164, #general currency sign
#         yen    => chr 165, #yen sign
#         brvbar => chr 166, #broken (vertical) bar
#         sect   => chr 167, #section sign
#         uml    => chr 168, #umlaut (dieresis)
#         copy   => chr 169, #copyright sign
#         ordf   => chr 170, #ordinal indicator, feminine
#         laquo  => chr 171, #angle quotation mark, left
#         not    => chr 172, #not sign
#         shy    => chr 173, #soft hyphen
#         reg    => chr 174, #registered sign
#         macr   => chr 175, #macron
#         deg    => chr 176, #degree sign
#         plusmn => chr 177, #plus-or-minus sign
#         sup2   => chr 178, #superscript two
#         sup3   => chr 179, #superscript three
#         acute  => chr 180, #acute accent
#         micro  => chr 181, #micro sign
#         para   => chr 182, #pilcrow (paragraph sign)
#         middot => chr 183, #middle dot
#         cedil  => chr 184, #cedilla
#         sup1   => chr 185, #superscript one
#         ordm   => chr 186, #ordinal indicator, masculine
#         raquo  => chr 187, #angle quotation mark, right
#         frac14 => chr 188, #fraction one-quarter
#         frac12 => chr 189, #fraction one-half
#         frac34 => chr 190, #fraction three-quarters
#         iquest => chr 191, #inverted question mark
#         Agrave => chr 192, #capital A, grave accent
#         Aacute => chr 193, #capital A, acute accent
#         Acirc  => chr 194, #capital A, circumflex accent
#         Atilde => chr 195, #capital A, tilde
#         Auml   => chr 196, #capital A, dieresis or umlaut mark
#         Aring  => chr 197, #capital A, ring
#         AElig  => chr 198, #capital AE diphthong (ligature)
#         Ccedil => chr 199, #capital C, cedilla
#         Egrave => chr 200, #capital E, grave accent
#         Eacute => chr 201, #capital E, acute accent
#         Ecirc  => chr 202, #capital E, circumflex accent
#         Euml   => chr 203, #capital E, dieresis or umlaut mark
#         Igrave => chr 204, #capital I, grave accent
#         Iacute => chr 205, #capital I, acute accent
#         Icirc  => chr 206, #capital I, circumflex accent
#         Iuml   => chr 207, #capital I, dieresis or umlaut mark
#         ETH    => chr 208, #capital Eth, Icelandic
#         Ntilde => chr 209, #capital N, tilde
#         Ograve => chr 210, #capital O, grave accent
#         Oacute => chr 211, #capital O, acute accent
#         Ocirc  => chr 212, #capital O, circumflex accent
#         Otilde => chr 213, #capital O, tilde
#         Ouml   => chr 214, #capital O, dieresis or umlaut mark
#         times  => chr 215, #multiply sign
#         Oslash => chr 216, #capital O, slash
#         Ugrave => chr 217, #capital U, grave accent
#         Uacute => chr 218, #capital U, acute accent
#         Ucirc  => chr 219, #capital U, circumflex accent
#         Uuml   => chr 220, #capital U, dieresis or umlaut mark
#         Yacute => chr 221, #capital Y, acute accent
#         THORN  => chr 222, #capital THORN, Icelandic
#         szlig  => chr 223, #small sharp s, German (sz ligature)
#         agrave => chr 224, #small a, grave accent
#         aacute => chr 225, #small a, acute accent
#         acirc  => chr 226, #small a, circumflex accent
#         atilde => chr 227, #small a, tilde
#         auml   => chr 228, #small a, dieresis or umlaut mark
#         aring  => chr 229, #small a, ring
#         aelig  => chr 230, #small ae diphthong (ligature)
#         ccedil => chr 231, #small c, cedilla
#         egrave => chr 232, #small e, grave accent
#         eacute => chr 233, #small e, acute accent
#         ecirc  => chr 234, #small e, circumflex accent
#         euml   => chr 235, #small e, dieresis or umlaut mark
#         igrave => chr 236, #small i, grave accent
#         iacute => chr 237, #small i, acute accent
#         icirc  => chr 238, #small i, circumflex accent
#         iuml   => chr 239, #small i, dieresis or umlaut mark
#         eth    => chr 240, #small eth, Icelandic
#         ntilde => chr 241, #small n, tilde
#         ograve => chr 242, #small o, grave accent
#         oacute => chr 243, #small o, acute accent
#         ocirc  => chr 244, #small o, circumflex accent
#         otilde => chr 245, #small o, tilde
#         ouml   => chr 246, #small o, dieresis or umlaut mark
#         divide => chr 247, #divide sign
#         oslash => chr 248, #small o, slash
#         ugrave => chr 249, #small u, grave accent
#         uacute => chr 250, #small u, acute accent
#         ucirc  => chr 251, #small u, circumflex accent
#         uuml   => chr 252, #small u, dieresis or umlaut mark
#         yacute => chr 253, #small y, acute accent
#         thorn  => chr 254, #small thorn, Icelandic
#         yuml   => chr 255, #small y, dieresis or umlaut mark
#     );
#     
#     
# #change html tags to ascii art ;)
# #strip html tags
# 
# $message_body  =~ s/<title>/Title:/gi;
# $message_body  =~ s/<\/title>//gi;
# $message_body  =~ s/<b>|<\/b>/\*/gi;
# $message_body  =~ s/<i>|<\/i>/\//gi;
# $message_body  =~ s/<u>|<\/u>/_/gi;
# $message_body  =~ s/<li>/\[\*\]/g;
# $message_body  =~ s/<\/li>/\\n/g;
# 
# 
# 
# $message_body =~ s{ <!                   # comments begin with a `<!'
#                         # followed by 0 or more comments;
# 
#     (.*?)		# this is actually to eat up comments in non 
# 			# random places
# 
#      (                  # not suppose to have any white space here
# 
#                         # just a quick start;
#       --                # each comment starts with a `--'
#         .*?             # and includes all text up to and including
#       --                # the *next* occurrence of `--'
#         \s*             # and may have trailing while space
#                         #   (albeit not leading white space XXX)
#      )+                 # repetire ad libitum  XXX should be * not +
#     (.*?)		# trailing non comment text
#    > # up to a `>'
# }{
#     if ($1 || $3) {	# this silliness for embedded comments in tags
# 	"<!$1 $3>";
#     } 
# }gesx;                 # mutate into nada, nothing, and niente

# #########################################################
# # next we'll remove all the <tags> #########################################################
# 
# $message_body =~ s{ < # opening angle bracket
# 
#     (?:                 # Non-backreffing grouping paren
#          [^>'"] *       # 0 or more things that are neither > nor ' nor "
#             |           #    or else
#          ".*?"          # a section between double quotes (stingy match)
#             |           #    or else
#          '.*?'          # a section between single quotes (stingy match)
#     ) +                 # repetire ad libitum
#                         #  hm.... are null tags <> legal? XXX
#    > # closing angle bracket
# }{}gsx;                 # mutate into nada, nothing, and niente
# 
# 
# 
# $message_body =~ s{ (
#         & # an entity starts with a semicolon
#         ( 
# 	    \x23\d+    # and is either a pound (#) and numbers
# 	     |	       #   or else
# 	    \w+        # has alphanumunders up to a semi
# 	)         
#         ;?             # a semi terminates AS DOES ANYTHING ELSE (XXX)
#     )
# } {
# 
#     $entity{$2}        # if it's a known entity use that
#         ||             #   but otherwise
#         $1             # leave what we'd found; NO WARNINGS (XXX)
# 
# }gex;                  # execute replacement -- that's code not a string
#
# 
# 
#     ####################################################
#     # now fill in all the numbers to match themselves
#     ####################################################
#    
#    my $chr; 
#     for $chr ( 0 .. 255 ) { 
#         $entity{ '#' . $chr } = chr $chr;
#     }
# 
# 
# $message_body =~ s/\n(\s*)\n(\s*)\n/\n/gi;
# $message_body =~ s/^\s\s\s//mgi;
# return $message_body; 




 my $message_body = shift || undef; 

 if($message_body){ 
 
 $message_body  =~ s/<title>/Title:/gi;
 $message_body  =~ s/<\/title>//gi;
 $message_body  =~ s/<p>/\n/gi;
 $message_body  =~ s/<\/p>//gi;
 $message_body  =~ s///gi;
 $message_body  =~ s/<b>|<\/b>/\*/gi;
 $message_body  =~ s/<i>|<\/i>/\//gi;
 $message_body  =~ s/<u>|<\/u>/_/gi;
 $message_body  =~ s/<p>/\n/g;
 $message_body  =~ s/<li>/\[\*\]/g;
 $message_body  =~ s/<\/li>/\\n/g;
 $message_body  =~ s/\n\n\n//g; 
 $message_body  =~ s/\n\n//g; 
 {
   
     local $/;               
  
 $message_body =~ s/<[^>]*>//gs;
 }

$message_body =~ s/\n(\s*)\n(\s*)\n/\n/gi;
$message_body =~ s/^\s\s\s//gi;
 
 return $message_body;
}

}

=pod

=item uriescape

	$string = uriescape($string); 
 
use to escape strings to be used as url strings.

=cut

sub uriescape {

     my ($string) = @_;
     
     
     my ($out);
     foreach (split //,$string)
     {
       if ( $_ eq " ") {$out.="+";next};
       if(ord($_) < 0x41 || ord($_) > 0x7a)
       { $out.=sprintf("%%%02x",ord($_)) }
       else
       { $out.=$_ }
     }
    return  $out;
  
  } 
   
   
sub uriencode { 
my $string = shift; 
$string =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
}

   
=pod
               
=item lc_email

	$email = lc_email($email); 

used to lowercase the domain part of the email address 
the name part of the email address is case sensitive
although 99.99% its not thought of as. 

=cut 
   

sub lc_email { 

	#get the address 
	my $email = shift || undef;
   if($EMAIL_CASE eq 'lc_domain'){ 
		#js - 11/25/00 
		if($email){
			#split it into the name and domain 
			my ($name, $domain) = split('@', $email);
			#lowercase the domain 
			$domain = lc($domain);
			#stick it together again 
			$email = "$name\@$domain";
			return $email; 
		}
	}else{ 
		$email = lc($email);
	}
}


=pod

=item subscribe_form 

	$form = subscribe_form($list); 

returns a html form for subscribin'

B<Warning> Will be moved into Widgets::* soon

=cut


sub subscribe_form { 


	my $list = shift || undef; 
	
	if($list){ 
		my $form = qq{
		</form> 
		
		<form action=$MOJO_URL method=POST> 
		<p>
		<input type=radio name=flavor value="subscribe" checked="checked" /> Subscribe |  
		<input type=radio name=flavor value="u" /> Unsubscribe <br />
		<input type="text" name="email" /> 
		<input type="hidden" name="list" value="$list" />
		<input type=submit  style='$STYLE{default_submit}' value="Submit" />
		</p>
		</form>
		
		};
	
	return $form; 
	}else{ 
		return undef;
	}
}




=pod

=item make_safer

	$string = make_safer($string); 

This subroutine is used to make sure strings, such as list names, 
path to directories, critical stuff like that. 
This is in effort to make Mojo Mail able to run in 
'Taint' Mode. If you need to run in taint mode, it may need still some tweakin. 

=cut


sub make_safer { 

	my $string = shift || undef; 
	
	if($string){
		$string =~ tr/\0-\037\177-\377//d;    # remove unprintables
		$string =~ s/(['\\])/\$1/g;           # escape quote, backslash
	return $string; 
	}else{ 
		return 0;
	}

}

=pod

=item urlify

	$string = urlify($string);

This simple subbroutine wraps an <a href...> </a> around what it sees as links in a string. 
This is mostly to make links in plain text archived messages into live links. 

=cut 



sub urlify { 

my $string = shift || undef; 

if($string){ 

my @Checking = split("\n", $string); 


my $urls = '(http|telnet|gopher|file|wais|ftp|webcal)';
my $ltrs = '\w';
my $gunk = '/#~:.?+=&%@!\-';
my $punc = '.:?\-';
my $any  = "${ltrs}${gunk}${punc}";
my $findings; 

foreach(@Checking){
    s{
      \b                    # start at word boundary
      (                     # begin $1  {
       $urls     :          # need resource and a colon
       [$any] +?            # followed by on or more
                            #  of any valid character, but
                            #  be conservative and take only
                            #  what you need to....
      )                     # end   $1  }
      (?=                   # look-ahead non-consumptive assertion
       [$punc]*             # either 0 or more punctuation
       [^$any]              #   followed by a non-url char
       |                    # or else
       $                    #   then end of the string
      )
     }{<a href="$1" target=out>$1</a>}igox;
    $findings .= "$_ \n";
}
return $findings;
}else{ 
return undef;

}
}

sub webify_plain_text{ 

my $string = shift; 

$string =~ s/>/\&gt;/g;
$string =~ s/</\&lt;/g;
$string =~ s/"/\&quot;/g;
$string =~ s/\n\n/<\/p><p>/gi;
$string =~ s/\n/<br>/gi;
$string = urlify($string);
return $string; 

}

=pod

=item interpolate_string

	$string = interpolate_string(-String => $string, 
	                             -List_Db_Ref => \%list_info);


This is used for psuedo tag interpolation, ie, changing [mojo_url] and friends into meaning full text. 

=cut

 
sub interpolate_string { 

	my %args = ( 
	-String      => undef,
	-List_Db_Ref => undef,
	-Email       => undef,
	@_
	); 
	
	my $string = $args{-String}      || undef;
	my $db_ref = $args{-List_Db_Ref} || undef;
	
	
	if($string and $db_ref){ 
	
		#first, lets get global things done
		$string =~ s/\[mojo_url\]/$MOJO_URL/go;
		
		#now, list-wide
		
		$string =~ s/\[list_name\]/$db_ref->{list_name}/go; 
		
		$string =~ s/\[list_info\]/$db_ref->{info}/go;
		$string =~ s/\[list_privacy_policy\]/$db_ref->{list_private_policy}/go; 
		$string =~ s/\[privacy_policy\]/$db_ref->{list_private_policy}/go; 
		
		$string =~ s/\[list_private_policy\]/$db_ref->{list_private_policy}/go; 
		$string =~ s/\[mojo_email\]/$db_ref->{mojo_email}/go;
		
		$string =~ s/\[list_owner_email\]/$db_ref->{mojo_email}/go;
		$string =~ s/\[list_admin_email\]/$db_ref->{admin_email}/go;
		$string =~ s/\[list\]/$db_ref->{list}/go; 

		my $t = localtime(); 
		
		$string =~ s/\[date\]/$t/go; 
		
				
		my $plain_subscribe_link = subscribe_link(-list  => $db_ref->{list},
											      -email => '[email]',
											      -pin   => '[pin]');
		
		my $plain_unsubscribe_link = unsubscribe_link(-list  => $db_ref->{list},
											          -email => '[email]',
											          -pin   => '[pin]');
											  
									  

		
		$string =~ s/\[plain_list_subscribe_link\]/$plain_subscribe_link/go; 
		$string =~ s/\[plain_list_unsubscribe_link\]/$plain_unsubscribe_link/go; 
		
		
		#foreach(keys %$db_ref){
			#my $tag = "[$_]";
			#$string =~ s/\Q$tag/$db_ref->{$_}/g;
		#}
	
	
		if($args{-Email}){ 
			$string =~ s/\[subscriber_email\]/$args{-Email}/g;
		}
		
		
		return $string; 
	}else{ 
		return undef;
	}


}

=pod

=item check_list_setup

check_list_setup() is used when creating and editing the core basic 
list information, like the list name, list password, list owner's email address 
and the list password. to check a new list, you'll want to do this: 

 my ($list_errors,$flags) = 
     check_list_setup(-fields => {list            => $list, 
                                   mojo_email      => $mojo_email, 
                                    password        => $password, 
                                    retype_password => $retype_password, 
                                    info            => $info,
                                    }); 




Its a big boy. What's happening?                                                             
this function returns two things, a reference to a hash	with any errors it 
finds, and a scalar who's value is 1 or above if it finds any errors. 
here's a small reference to what $list_errors would return, all values in the 
hash ref will be one IF they are found to have something wrong in em: 

	

list                             - no list name was given
list_exists                      - the list exists 
password                         - no password given
retype_password                  - the second password was not given
password_ne_retype_password      - the first password didn't math the second
slashes_in_name                  - slashes were found in the list name
weird_characters                 - unprintable characters were found in the list name                                                    
quotes                           - quotes were found in the list name
invalid_mojo_email               - the email address for the list owner is invlaid
info                             - no list info was given. 

here's a better example on how to use this:

 my ($list_errors,$flags) = 
 check_list_setup(-fields => {list            => $list, 
                                mojo_email      => $mojo_email, 
                                password        => $password, 
                                retype_password => $retype_password, 
                                info            => $info,
                                });
	if($flags >= 1){
        print "your list name was never entered!" if $list_errors -> {list} == 1; 
 	}

Now, if you want to check the setup of a list already created (editing a list) just set the 
-new_list flag to 'no', like this: 


 my ($list_errors,$flags) = 
 check_list_setup(-fields => {list            => $list, 
                                mojo_email      => $mojo_email, 
                                password        => $password, 
                                retype_password => $retype_password, 
                                info            => $info,
                                },
                    -new_list => 'no'                
                                ); 	

This will stop checks on the list name (which is already set) and if the list exists (which,
hopefully it does, since we're editing it) 

=cut 



sub check_list_setup {

    my %args = (-fields    => undef,  
    			-new_list  => 'yes', 
    			@_); 
    		   
	my %new_list_errors = (); 
	my $list_errors     = 0;
    my $fields = $args{-fields}; 
    
	if($fields->{list} eq ""){ 
		$list_errors++;
		$new_list_errors{list} = 1;
	}else{ 
		$new_list_errors{list} = 0;
	}
	
	if($fields->{list_name} eq ""){ 
		$list_errors++;
		$new_list_errors{list_name} = 1;
	}else{ 
		$new_list_errors{list_name} = 0;
	}
	
	if($args{-new_list} eq "yes") {
		my $list_exists = check_if_list_exists(-List=>$fields->{list}); 
		if($list_exists >= 1){
			 $list_errors++; 
			 $new_list_errors{list_exists} = 1;
		}else{ 
			 $new_list_errors{list_exists} = 0;
		}	
	}

	if($args{-new_list} eq "yes") {
		if(!defined($fields->{password}) || $fields->{password} eq ""){	
			$list_errors++;
			$new_list_errors{password} = 1;
		}else{ 
			$new_list_errors{password} = 0;
		}
		
		
		if($fields ->{retype_password} eq ""){
			$list_errors++;
			$new_list_errors{retype_password} = 1;
		}else{ 
			$new_list_errors{retype_password} = 0;
		}
		
		
		
		if($fields ->{password} ne $fields ->{retype_password}) { 
			 $list_errors++;
			 $new_list_errors{password_ne_retype_password} = 1;
		}else{ 
			 $new_list_errors{password_ne_retype_password} = 0;
		}
		
		
		if($fields ->{list} =~ m/\/|\\/){ 
        	$list_errors++;
			$new_list_errors{slashes_in_name} = 1;
		}else{ 
			$new_list_errors{slashes_in_name} = 0;
		}
		
		
		if($fields ->{list} =~ m/\0-\037\177-\377/){ 
        	$list_errors++; 
       		$new_list_errors{weird_characters} = 1;
      	}else{ 
      		$new_list_errors{weird_characters} = 0;
      	}
      
    	if($fields ->{list} =~ m/\"|\'/){ 
        	$list_errors++; 
       		$new_list_errors{quotes} = 1;
      	}else{ 
      		$new_list_errors{quotes} = 0;
      	}
	}
	
	my $invalid_email = check_for_valid_email($fields->{mojo_email});
	
	if($invalid_email >= 1){
		$list_errors++;
		$new_list_errors{invalid_mojo_email} = 1;
	}else{ 
		$new_list_errors{invalid_mojo_email} = 0;
	}
	
	
	if($fields ->{info} eq ""){ 
		$list_errors++;
		$new_list_errors{list_info} = 1;
	}else{ 
		$new_list_errors{list_info} = 0;
	}
	return ($list_errors, \%new_list_errors);
}

=pod

=item check_admin_cgi_security


	my ($problems, $flags, $root_logged_in) =
         check_admin_cgi_security(-Admin_List     => $args{-Admin_List},
                                   -Admin_Password => $args{-Admin_Password},
                                   -Function       => $args{-Function},
                                   -IP_Address     => $ENV{REMOTE_ADDR});


Checks the security for logins via the CGI interface to the list administration control panel

=cut



sub check_list_security { 

require MOJO::Password; 

	#error and security checks. 
	#will report errors and only let 
	#the correct people into the admin work area. 
	
	my %args = (-Admin_List      => undef, 
				-Admin_Password  => undef,
				-Function        => undef, 
				-IP_Address      => undef,
				@_); 
				
	my ($problems, $flags, $root_logged_in) = 
	    check_admin_cgi_security(-Admin_List     => $args{-Admin_List},
                                 -Admin_Password => $args{-Admin_Password},
                                 -Function       => $args{-Function},
                                 -IP_Address     => $ENV{REMOTE_ADDR});

    if($problems){ 
    	enforce_admin_cgi_security(-Admin_List     => $args{-Admin_List},
    	 						   -Admin_Password => $args{-Admin_Password},
    	 						   -Flags          => $flags);
    }else{ 
   		return $root_logged_in;
   	}

}



=pod

=item user_error 

deals with errors from a CGI interface

	user_error(-List => 'my_list', 
	           -Error => 'some_error', 
	           -Email => 'some@email.com'); 


=cut


sub user_error { 
	#$list = $admin_list unless $list; 
	# my $error = shift; 
	
	my %args = (-List => undef, -Error => undef, -Email => undef, @_); 
	
	my $list = $args{-List}; 
	my $error = $args{-Error}; 
	my $email = $args{-Email}; 
	
	require MOJO::Error; 
	my $error_msg = MOJO::Error::cgi_user_error(-List  => $list,
												-Error => $error,
												-Email => $email);
	#go, errors in the... whatever shouldn't make the script process anything more
	
	require CGI;
	my $q = new CGI;
	print $q->header() . $error_msg;
	exit; 
 }


=pod

=item check_admin_cgi_security

sanity security check for the CGI interface

	my ($problems, $flags, $root_logged_in) = 
	    check_admin_cgi_security(-Admin_List         => $args{-Admin_List},
                                 -Admin_Password => $args{-Admin_Password},
                                 -Function       => $args{-Function},
                                 -IP_Address     => $ENV{REMOTE_ADDR});
	
	

=cut


sub check_admin_cgi_security { 
	
	my $root_logged_in = 0;
	require MOJO::Password;
	my $problems = 0; 
	my %flags    = (); 
	my %args = (-Admin_List      => undef, 
				-Admin_Password  => undef,
				-Function        => undef, 
				-IP_Address      => undef,
				@_); 
	
	unless(defined($args{-Admin_List})){
		$problems++;
		$flags{"need_to_login"} = 1  
	}
	
	# look for ip addresses, if needed
	if($ALLOWED_IP_ADDRESSES[0]){ 
		my $ip_check = 0; 
		foreach(@ALLOWED_IP_ADDRESSES){ 
			if($_ eq $args{-IP_Address}){ 
				$ip_check = 1;
				last;
			}
		}	
		#error! no ip!
		if($ip_check == 0){
			$problems++;
			$flags{"bad_ip"} = 1 
		}
	}
	
	my $list = $args{-Admin_List}; 
	my ($list_exists) = check_if_list_exists(-List=>$list);
	
	# error! no such list
	if($list_exists <= 0){
		$problems++;
		$flags{"no_list"} = 1;
	}
	
	my %list_info = open_database(-List => $list); 
	
	unless($list_info{cipher_key}){ 
		setup_list({list => $list});
		%list_info = open_database(-List => $list);
	} 
	
	
	my $cipher_pass    = MOJO::Password::cipher_decrypt($list_info{cipher_key}, $args{-Admin_Password});                             
	my $password_check = MOJO::Password::check_password($list_info{password},$cipher_pass); 


	# if root logging in is set, let em login with the root password 
	
	if($ALLOW_ROOT_LOGIN == 1){ 
		if(defined($MOJO_ROOT_PASSWORD)){
			my $cipher_mojo_root_password = MOJO::Password::cipher_decrypt($list_info{cipher_key}, $args{-Admin_Password});	
			if($ROOT_PASS_IS_ENCRYPTED == 1){ 	
				my $root_password_check = MOJO::Password::check_password($MOJO_ROOT_PASSWORD, $cipher_mojo_root_password); 
				if($root_password_check == 1){
					$password_check++;
					$root_logged_in = 1; 
				}
			}else{ 
				my $cipher_mojo_admin_password = MOJO::Password::cipher_decrypt($list_info{cipher_key}, $args{-Admin_Password});
				if($MOJO_ROOT_PASSWORD eq $cipher_mojo_admin_password){ 
					$password_check++;
					$root_logged_in = 1; 
				}
			}
		}
	}
	# error! wrong password
	if ($password_check < 1){ 
		$problems++;
		$flags{"invalid_password"} = 1;
	} 
	
	# last but not least, we see if they're allowed in this particular function. 
    # we are sneaky shits, aren't we?!
    
    if($root_logged_in != 1){
		require MOJO::Widgets::Admin_Menu;
		my $function_permissions = MOJO::Widgets::Admin_Menu::check_function_permissions(-List_Ref => \%list_info, 
																						 -Function => $args{-Function});
		if ($function_permissions < 1){
			$problems++;
			$flags{"no_admin_permissions"} = 1;
		} 
	}
    
    return ($problems, \%flags, $root_logged_in); 

}


sub root_password_verification { 
	my $root_pass = shift; 
	require MOJO::Password;
	if($ROOT_PASS_IS_ENCRYPTED == 1){ 	
		my $root_password_check = MOJO::Password::check_password($MOJO_ROOT_PASSWORD, $root_pass); 
		if($root_password_check == 1){
			return 1; 
		}else{ 
			return 0; 
		}
	}else{ 
		if($MOJO_ROOT_PASSWORD eq $root_pass){ 
			return 1; 
		}else{ 
			return 0; 
		}
	}
}




=pod

=item enforce_admin_cgi_security

	if($problems){ 
        	enforce_admin_cgi_security(-Admin_List     => $args{-Admin_List},
                                	   -Admin_Password => $args{-Admin_Password},
                                	   -Flags          => $flags);
        }
        
    

shows the correct error message for list logins

=cut



sub enforce_admin_cgi_security { 
	my %args = (-Admin_List     => undef,
    	 		-Admin_Password => undef,
    	 		-Flags          => {},
    	 		@_);
	my $flags = $args{-Flags};
	require MOJO::Error; 
	my @error_precedence = qw(need_to_login bad_ip no_list invalid_password no_admin_permissions);
	foreach (@error_precedence){
		if($flags->{$_} == 1){ 
			my $error_msg = MOJO::Error::cgi_user_error(-List  => $args{-Admin_List},
														-Error => $_);
			#go, errors in the... whatever shouldn't make the script process anything more
			print "Content-type: text/html\r\n\r\n", $error_msg;
			exit; 	
		} 	
	}
}
 
 
=pod

=item make_all_list_files

	make_all_list_files(-List => $list); 

makes all the list files needed for a Mojo Mail list. 

=cut

 
sub make_all_list_files { 

my %args = (-List => undef, @_); 

my $list = $args{-List}; 

 #untaint 
$list = make_safer($list); 
$list =~ /(.*)/; 
$list = $1; 


# make email list file
sysopen(LIST, "$FILES/$list.list", O_RDWR|O_CREAT, $FILE_CHMOD)or die "couldn't open $FILES/$list.list for reading: $!\n";
flock(LIST, LOCK_SH);
close (LIST);

#chmod!
chmod($FILE_CHMOD, "$FILES/$list.list"); 



# make e-mail blacklist file
sysopen(LIST, "$FILES/$list.black_list", O_RDWR|O_CREAT, $FILE_CHMOD)or die "couldn't open $FILES/$list.black_list for reading: $!\n";
flock(LIST, LOCK_SH);
close (LIST);

#chmod!
chmod($FILE_CHMOD, "$FILES/$list.black_list"); 

my %fake_info; 
$fake_info{list} = $list;

require MOJO::Archive;
my $archive = MOJO::Archive->new(-List => \%fake_info); 
 

require MOJO::HTML; 
my $print_template = MOJO::HTML::default_template($MOJO_URL); 
#make a template file 
#print it out.
sysopen(TEMPLATE,"$TEMPLATES/$list.template", O_RDWR|O_CREAT, $FILE_CHMOD) or die "couldn't open '$TEMPLATES/$list.template' for writing: $!\n";
print TEMPLATE $print_template;
close(TEMPLATE); 
#chmod!
chmod($FILE_CHMOD, "$TEMPLATES/$list.template"); 


#do some hardcore guessin'
chmod($FILE_CHMOD, 
"$FILES/mj\-$list",
"$FILES/mj\-$list.db",
"$FILES/mj\-$list.pag",
"$FILES/mj\-$list.dir",
"$ARCHIVES/mj\-$list-archive",
"$ARCHIVES/mj\-$list-archive.db",
"$ARCHIVES/mj\-$list-archive.pag",
"$ARCHIVES/mj\-$list-archive.dir",
);  


return 1; 


}


=pod

=item message_id

returns an id, based on the date. 

=cut


sub message_id { 

	my ($sec, $min, $hour, $day, $month, $year) = (localtime)[0,1,2,3,4,5];
	my $message_id = sprintf("%02d%02d%02d%02d%02d%02d", $year+1900, $month+1, $day,  $hour, $min, $sec);
	return $message_id; 

}


=pod

=item subscribe_link

	subscribe_link(
		-url           => $MOJO_URL, 
		-email         => 'you@me.com', 
		-pin           => 1234, 
		-make_pin      => 0,
		-list          => 'mylist',
		-escape_list   => 1,
		-escape_all    => 0); 
	
creates a subscription link	

=cut 


sub subscribe_link {
	my %args = (
	-url      => $MOJO_URL, 
	-email    => undef, 
	-function => 'n',
	-pin      => undef, 
	-make_pin => 0,
	-escape_list   => 1,
	-escape_all    => 0,
	@_); 
	
	if($args{-email} && $args{-make_pin} == 1){ 
		$args{-pin} = make_pin(-Email => $args{-email}); 
	}


	my $link = "$args{-url}\?";
	
	if($args{-escape_all} == 1){ 
		foreach($args{-email}, $args{-pin}, $args{-function}, $args{-list}){ 
			$_ = uriescape($_);
		}
	}elsif($args{-escape_list} == 1){ 
		$args{-list} = uriescape($args{-list}); 
	}
	
	$args{-email} =~ s/\@/\%40/g;
	
	my @qs; 
	push(@qs, "f\=$args{-function}") if $args{-function};   
	push(@qs, "l\=$args{-list}")	 if $args{-list};
	push(@qs, "e\=$args{-email}")    if $args{-email};
	push(@qs, "p\=$args{-pin}")      if $args{-pin};
  
	$link .= join '&', @qs; 
	return $link;
}

=pod

=item unsubscribe_link

	unsubscribe_link(
		-url           => $MOJO_URL, 
		-email         => 'you@me.com', 
		-pin           => 1234, 
		-make_pin      => 0,
		-list          => 'mylist',
		-escape_list   => 1,
		-escape_all    => 0); 

creates an unsubscription link	

=cut 

sub unsubscribe_link {
	my %args = (
	-url           => $MOJO_URL, 
	-email         => undef, 
	-function      => 'u',
	-pin           => undef, 
	-make_pin      => 0,
	-list          => undef,
	-escape_list   => 1,
	-escape_all    => 0,
	@_); 
	
	if($args{-email} && $args{-make_pin} == 1){ 
		$args{-pin} = make_pin(-Email => $args{-email}); 
	}

	if($args{-escape_all} == 1){ 
		foreach($args{-email}, $args{-pin}, $args{-function}, $args{-list}){ 
			$_ = uriescape($_);
		}
	}elsif($args{-escape_list} == 1){ 
		$args{-list} = uriescape($args{-list}); 
	}
	
	my $link = "$args{-url}\?";
	$args{-email} =~ s/\@/\%40/g;
	
	my @qs; 
	push(@qs, "f\=$args{-function}") if $args{-function};   
	push(@qs, "l\=$args{-list}")	if $args{-list};
	push(@qs, "e\=$args{-email}") if $args{-email};
	push(@qs, "p\=$args{-pin}")    if $args{-pin};
  

	$link .= join '&', @qs; 
	return $link;
}



sub check_setup { 	
	if($OS =~ /^Win|^MSWin/i){ 
		warn "directory setup test disabled for WinNT";
		return 1; 
	}else{ 	
		my @tests = ($FILES, $TEMPLATES, $TMP);
		foreach my $test_dir(@tests){ 
			open(TEST, $test_dir) or warn $!; 
			if(-d TEST && -e _){ 
				close(TEST);
			}else{ 
				close(TEST);
				return 0;
			}
		} 	
		return 1;
	}
} 


sub cased {
	my $str = shift; 
	if($EMAIL_CASE eq 'lc_all'){ 	
		return lc($str);
	}elsif($EMAIL_CASE eq 'lc_domain'){ 
		my ($name, $domain) = split('@', $str); 
		return $name.'@'.lc($domain);
	}else{ 
		my ($name, $domain) = split('@', $str); 
		return lc($name).'@'.$domain;	
	}
}


sub xss_filter { 
	my $t = shift; 
	   if($t){ 
		   #$t =~ s/[^A-Za-z0-9 ]*/ /g;
		   $t =~ s/\</&lt;/g; 
		   $t =~ s/\>/&gt;/g; 
		   $t =~ s/\"/&quot;/g;
	   }
	   return $t;
}


=pod

=back 


=head1 COPYRIGHT

Copyright (c) 1999 - 2002 Justin Simoni (justin@skazat.com) http://skazat.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.


=head1 CONTACT INFO

Justin Simoni http://skazat.com justin\@skazat.com 

A good place to start to get information is at: 

http://mojo.skazat.com 

=cut





1; 

