package DADA::App::Guts;

=cut

=pod

=head1 NAME


DADA::App::Guts

=head1 SYNOPSIS 

 use DADA::App::Guts; 

=head1 DESCRIPTION

This module holds commonly used subroutines for the variety of other modules
in Dada Mail. This module is slowly fading away, in favor of having much of
Dada Mail Object Oriented. There are some subroutines that are, in reality, 
just wrappers around the new, Object Oriented ways of doing things. They are
noted here.

=head1 SUBROUTINES

=cut



use lib qw(./ ../  ../DADA ../DADA/perllib); 



use Carp qw(carp croak);

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

use DADA::Logging::Usage;
my $log =  new DADA::Logging::Usage;;

use DADA::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_info
delete_email_list
check_if_list_exists
available_lists
archive_message

setup_list
date_this
convert_to_ascii
uriescape
lc_email
make_safer
interpolate_string
webify_plain_text
check_list_setup
make_all_list_files

message_id
subscribe_link
unsubscribe_link

check_list_security
user_error
check_setup

cased
root_password_verification
xss_filter
check_referer

escape_for_sending

entity_protected_str

optimize_mime_parser



);



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@example.com 

=cut


sub make_pin {
	my %args = ( 
	-Email      => undef, 
	@_
	); 
	
	
	my $email = $args{-Email} || undef;
	my $pin = 0; 
	
	if($email){ 
	
		$email = cased($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){ 
		$email = cased($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();

Please 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 croak "$PROGRAM_NAME $VER error, can't open $path to read: $!"; 
	
	while(defined($present_list = readdir LISTS) ) { 
		
		#don't read '.' or '..'
		next if $present_list =~ /^\.\.?$/;
		 
		$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 Dada Mail 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 
			croak "$PROGRAM_NAME $VER Error: can't write new template at '$list_path/$list_template.template': $!"; 
	
		flock(TEMPLATE, LOCK_EX) or 
			croak "$PROGRAM_NAME $VER Error: can't lock to write new template at '$list_path/$list_template.template': $!" ; 
		
		print TEMPLATE $print_template;
		
		close(TEMPLATE); 
	
		}else{ 	
			carp('$PROGRAM_NAME $VER 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){

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

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

}else{ 

carp('$PROGRAM_NAME $VER Error: No list name given to delete list template');
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 croak "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)$/)) { 
				 
				 $deep_six = make_safer($deep_six); 
				 $deep_six =~ /(.*)/; 
				 $deep_six = $1;

				 unlink("$FILES/$deep_six"); 
			} 
		 }
	}else{ 
		carp('$PROGRAM_NAME $VER 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 = ( 
	-List      => undef, 
	-Type      => 'list',
	@_,
	);

	die 'no list! '
		if ! $args{-List};

	my $deep_six = $FILES . '/' . $args{-List} . '.' . $args{-Type};

	$deep_six = make_safer($deep_six); 
	$deep_six=~ /(.*)/; 
	$deep_six = $1; 

	my $n = unlink($deep_six);
	warn "couldn't delete '$deep_six'! " . $!
		if $n == 0; 
}

=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, 
				@_); 
	
	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 Dada Mail lists available at $path

=cut

sub available_lists { 

	my %args = ( 
				-As_Ref   => 0,
				-In_Order => 0,
				-Dont_Die => 0,
				@_
			   ); 
	
	
	
	require DADA::MailingList::Settings; 
	
	my $want_ref        = $args{-As_Ref};
	my @dbs             = ();
	my @available_lists = (); 
	my $present_list;
	
	my $path = $FILES; 
	 #untaint 
	$path = make_safer($path); 
	$path =~ /(.*)/; 
	$path = $1; 
	
	if(opendir(LISTS, $FILES)){ 
		while(defined($present_list = readdir LISTS) ) { 
			next if $present_list =~ /^\.\.?$/;
					$present_list =~ s(^.*/)();
			next if $present_list !~ /^mj-.*$/; 
	
			$present_list =~ s/mj-//;
			$present_list =~ s/(\.dir|\.pag|\.db)$//;
			$present_list =~ s/(\.list|\.template)$//;
	 
			next if $present_list eq ""; 
			push(@dbs, $present_list) 
				if(defined($present_list) && $present_list ne "" && $present_list !~ m/^\s+$/); 
		}
		
		foreach my $all_those(@dbs) {      
			 push( @available_lists, $all_those)
			 	if($all_those !~ m/\-archive.*|\-schedules.*/)
		}		    
		
		#give me just one occurence of each name
		my %seen = (); 
		my @unique = grep {! $seen{$_} ++ }  @available_lists; 
		
		my @clean_unique; 
		
		foreach(@unique){ 
			push(@clean_unique, $_) 
				if(defined($_) && $_ ne "" && $_ !~ m/^\s+$/);
		}
		
		if($args{-In_Order} == 1){ 
		
			my $labels = {}; 
			foreach my $l( @clean_unique){		
				my $ls        = DADA::MailingList::Settings->new(-List => $l); 
				my $li        = $ls->get; 		
				$labels->{$l} = $li->{list_name};
			}			
			@clean_unique = sort { uc($labels->{$a}) cmp uc($labels->{$b}) } keys %$labels;						  
		}
		
		$want_ref == "1" ? return \@clean_unique : return @clean_unique;
		
	}else{ 
		# DON'T rely on this...
		if($args{-Dont_Die} == 1){ 
			$want_ref == "1" ? return [] : return ();	
		}else{ 
			croak("$PROGRAM_NAME $VER error, please MAKE SURE that '$path' is a directory (NOT a file) and that Dada Mail has enough permissions to write into this directory: $!"); 
	
		}
	}
	

} 

     

=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    = "a.m."; 
		
		
		if($hour < 10){ 
			$hour = $hour/1; 
			$hour = 12 if $hour == 0; 
		}
		if($hour > 12){ 
			$hour = $hour - 12; 
			$ending = "p.m.";
		}
		
		
		
		
		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 { 

	 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/<\/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; 


}

=pod

=item uriescape

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

=cut

sub uriescape {

     my $string = shift;

# probably not the best idea to introduce this in a release candidate...     
#    eval {require URI::Escape}; 
#	if(!$@){
#		return URI::Escape::uri_escape($string, "\200-\377");		 
#	}else{ 
	
		 if($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;
	return $string;
}

   
=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);
	}
}


=cut

=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 Dada 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
		$string =~ m/(.*)/;
	return $1; 
	}else{ 
		return 0;
	}

}




sub webify_plain_text{ 

	my $s = shift; 
	require HTML::FromText;
	$s = HTML::FromText::text2html($s, %HTMLFROMTEXT_OPTIONS); 

	# Personal HACK
	# I HATE and I mean, HATE the <tt> tag around url's, I mean, wtf?
	
	my $b = quotemeta('<tt><a href=');
	my $e = quotemeta('</a></tt>'); 
	
	$s =~ s/$b(.*?)$e/<a href=$1<\/a>/gi;	

	# HACK - like - wtf, we can't use a <p> tag in HTML::FromText?!
	return '<p>' . $s . '</p>'; 
}

=pod

=item interpolate_string

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


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

=cut

 
sub interpolate_string { 

	my %args = ( 
	-String      => undef,
	-List_Db_Ref => undef,
	-Email       => undef,
	-Skip        => [], 
	@_
	); 
	
	
	my %skip; 
	$skip{$_} = 1 foreach @{$args{-Skip}}; 



	
	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/\[program_url\]/$PROGRAM_URL/go;
		
		#now, list-wide
		
		unless($skip{'list_name'}){ # ha ha! Bastards.
			$string =~ s/\[list_name\]/$db_ref->{list_name}/go; 
		}
		
		
		$string =~ s/\[list_info\]/$db_ref->{info}/go;
		 $string =~ s/\[privacy_policy\]/$db_ref->{privacy_policy}/go; 
		#err, old version...
		$string =~ s/\[list_private_policy\]/$db_ref->{privacy_policy}/go; 
		$string =~ s/\[list_privacy_policy\]/$db_ref->{privacy_policy}/go; 
		
		$string =~ s/\[physical_address\]/$db_ref->{physical_address}/g;
		
		$string =~ s/\[list_owner_email\]/$db_ref->{list_owner_email}/go;
		
		$string =~ s/\[list_owner_email\]/$db_ref->{list_owner_email}/go;
		$string =~ s/\[list_admin_email\]/$db_ref->{admin_email}/go;
		
		
		unless($skip{'list'}){ # ha ha! Bastards.
			$string =~ s/\[list\]/$db_ref->{list}/go; 
		}
		
		my $t = localtime(); 
		
		$string =~ s/\[date\]/$t/go; 
		
		if($args{-Email}){ 
			$string =~ s/\[subscriber_email\]/$args{-Email}/g;
			$string =~ s/\[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, 
                                   list_owner_email      => $list_owner_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_list_owner_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, 
                                list_owner_email      => $list_owner_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, 
                                list_owner_email      => $list_owner_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($fields->{list_name} =~ m/(\>|\<|\")/){ 
		$list_errors++;
		$new_list_errors{list_name_bad_characters} = 1;
	}else{ 
		$new_list_errors{list_name_bad_characters} = 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(length($fields->{list}) > 16){ 
			$list_errors++;
			$new_list_errors{shortname_too_long} = 1;
		}else{ 
			$new_list_errors{shortname_too_long} = 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->{list_owner_email});
	
	if($invalid_email >= 1){
		$list_errors++;
		$new_list_errors{invalid_list_owner_email} = 1;
	}else{ 
		$new_list_errors{invalid_list_owner_email} = 0;
	}
	
	
	if($fields ->{info} eq ""){ 
		$list_errors++;
		$new_list_errors{list_info} = 1;
	}else{ 
		$new_list_errors{list_info} = 0;
	}
	
	
	if($fields->{privacy_policy} eq ""){ 
		$list_errors++;
		$new_list_errors{privacy_policy} = 1;
	}else{ 
		$new_list_errors{privacy_policy} = 0;
	}
	
	if($fields->{physical_address} eq ""){ 
		$list_errors++;
		$new_list_errors{physical_address} = 1;
	}else{ 
		$new_list_errors{physical_address} = 0;
	}
	
	
	return ($list_errors, \%new_list_errors);
}


=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 DADA::App::Error; 
	my $error_msg = DADA::App::Error::cgi_user_error(-List  => $list,
													 -Error => $error,
													 -Email => $email,
													 );
	#go, errors in the... whatever shouldn't make the script process anything more
	
	print $error_msg;
	exit; 
 }
 
 
 
 
 sub root_password_verification { 
	my $root_pass = shift || undef;
	
	return 0 if !$root_pass;
	 
	require DADA::Security::Password;
	if($ROOT_PASS_IS_ENCRYPTED == 1){ 	
		my $root_password_check = DADA::Security::Password::check_password($PROGRAM_ROOT_PASSWORD, $root_pass); 
		if($root_password_check == 1){
			return 1; 
		}else{ 
			return 0; 
		}
	}else{ 
		if($PROGRAM_ROOT_PASSWORD eq $root_pass){ 
			return 1; 
		}else{ 
			return 0; 
		}
	}
}




=pod

=item make_all_list_files

	make_all_list_files(-List => $list); 

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

=cut

 
sub make_all_list_files { 

	my %args = (-List => undef, @_); 
	
	my $list = $args{-List}; 
	
	 #untaint 
	$list = make_safer($list); 
	$list =~ /(.*)/; 
	$list = $1; 
	
	
	if($DB_TYPE eq 'PlainText'){ 
		# make email list file
		sysopen(LIST, "$FILES/$list.list", O_RDWR|O_CREAT, $FILE_CHMOD)
			or croak "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 croak "couldn't open $FILES/$list.black_list for reading: $!\n";
		flock(LIST, LOCK_SH);
		close (LIST);
		#chmod!
		chmod($FILE_CHMOD, "$FILES/$list.black_list"); 	 
	
	}
	#require DADA::Template::HTML; 
	#my $print_template = DADA::Template::HTML::default_template($PROGRAM_URL); 
	#make a template file 
	#print it out.
	#sysopen(TEMPLATE,"$TEMPLATES/$list.template", O_RDWR|O_CREAT, $FILE_CHMOD) 
	#	or croak "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",
	);  
	
	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; 

}





sub check_list_security { 

	my %args = (-Function        => undef, 
				-cgi_obj         => undef, 
				-manual_override => 0, 
				@_);
				warn '$args{-manual_override} in guts: ' . $args{-manual_override}; 
	die 'no CGI Object (-cgi_obj)' if ! $args{-cgi_obj};
	
	require DADA::App::Session; 
	
	my $dada_session = DADA::App::Session->new();
	my ($admin_list, $root_login, $checksout) = $dada_session->check_session_list_security(%args); 
	return ($admin_list, $root_login, $checksout); 
	
}




=pod

=item subscribe_link

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

=cut 


sub subscribe_link {
	my %args = (
	-url      => $PROGRAM_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}); 
	}
	
	if($args{-email}){ 
	my $tmp_email = $args{-email};
	
	    $tmp_email =~ s/\@/\%40/g;
	    $tmp_email =~ s/\+/%2B/g;
	    $args{-email} = $tmp_email; 
	}
	
	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           => $PROGRAM_URL, 
		-email         => 'you@me.com', 
		-pin           => 1234, 
		-make_pin      => 0,
		-list          => 'mylist',
		-escape_list   => 1,
		-escape_all    => 0); 

returns an unsubscription link	

=cut 

sub unsubscribe_link {
	my %args = (
	-url           => $PROGRAM_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}\?";
	my $tmp_email = $args{-email} || undef; 
	if($tmp_email){ 
		$args{-email} =~ s/\@/\%40/g;
	}
	$args{-email} = $tmp_email; 
	
	
	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 check_setup

makes sure the following directories exists and can be written into: 

$FILES
$TEMPLATES
$TMP

returns '1' if this is the case, 0 otherwise. 

This test is disabled is $OS is set to a windows ( ^Win|^MSWin/i )
variant. 

=cut

sub check_setup { 	
	if($OS =~ /^Win|^MSWin/i){ 
		carp "directory setup test disabled for WinNT";
		return 1; 
	}else{ 	
		my @tests = ($FILES, $TEMPLATES, $TMP);
		foreach my $test_dir(@tests){ 

			if(-d $test_dir && -e $test_dir){ 
			
			}else{ 
				 carp "Couldn't find: $test_dir";
				return 0;
			}
		} 	
		return 1;
	}
} 




=pod

=item cased

my $email = cased('SOME@WHERE.COM'); 


cased takes a string and recases the string, depending on what 
$EMAIL_CASE is set to. 

if the email address is: SOME@WHERE.com, 

it will be changed to: some@where.com if $EMAIL_CASE is set to: 'lc_all'

it will be changed to: SOME@where.com if $EMAIL_CASE is set to: 'lc_domain'

=cut

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;	
	}
}




=pod

=item xss_filer

 $str = xss_filter($str); 
 
Simple subroutine that strips '<', '>' and '"', and replaces them with
HTML entities. This is used to stop text that can be interpretted as
javascript, etc code from being executed.  

=cut

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

=item check_referer

 check_referer($q->referer());

Checks to see if the referer is the same as what's set in $PROGRAM_URL


=cut


sub check_referer {
  require Socket; 
  
  my $check_referer;
  my ($referer) = @_;


  if ($referer && ($referer =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i)) {
    my $refHost;

    $refHost = $2;
	
	
	my @referers;

 	if ($PROGRAM_URL && ($PROGRAM_URL =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i)) {
    	push(@referers, $2);
    }
	
	if ($S_PROGRAM_URL && ($S_PROGRAM_URL =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i)) {
    	push(@referers, $2);
    }
	
	
    foreach my $test_ref (@referers) {
      if ($refHost =~ m|\Q$test_ref\E$|i) {
        $check_referer = 1;
        last;
      }
      elsif ($test_ref =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/ ) {
        if ( my $ref_host = Socket::inet_aton($refHost) ) {
          $ref_host = unpack "l", $ref_host;
          if ( my $test_ref_ip = Socket::inet_aton($test_ref) ) {
            $test_ref_ip = unpack "l", $test_ref_ip;
            if ( $test_ref_ip == $ref_host ) {
              $check_referer = 1;
              last;
            }
          }
        }
      }
    }
  } else {
    return 0;
  }

  return $check_referer;
}


sub escape_for_sending { 
	# i really wish I could find some docs on what
	# needs to be escaped...
	
	my $s = shift; 	
	#$s =~ s/\./\\\./g;	
	#$s =~ s/\"/\\\"/g;	
	$s =~ s/\"/\\\"/g;	
	$s =~ s/\,/\\,/g;
	$s =~ s/:/\\:/g;
	
	
	
	return $s; 
} 




sub entity_protected_str { 

	my $originalString    = shift; 
	my $mode              = shift || 3; 

	
	return $originalString
		if $mode == 4; 
		
	my $encodedString = "";
	my $nowCodeString = "";
	my $randomNumber = -1;
	my $originalLength = length($originalString);
	my $encodeMode = $mode;
	
	my $i;
	for ( $i = 0; $i < $originalLength; $i++) {
		$encodeMode = (int(rand(2)) + 1)
			if ($mode == 3);
		if($encodeMode == 1) {
			#case 1: // Decimal code 
				$nowCodeString = "&#" . ord(substr($originalString,$i)) . ";"; 
		}elsif($encodeMode == 2) {
			#case 2: // Hexadecimal code
				$nowCodeString = "&#x" . perl_dechex(ord(substr($originalString,$i))) . ";";
		}else{	
				return "ERROR: wrong encoding mode.";
		}
		$encodedString .= $nowCodeString;
	}
	return $encodedString;
}


sub perl_dechex { 
	my $s = shift; 
	return sprintf("%X", $s);
}




sub optimize_mime_parser { 

	my $parser = shift; 
	
	die 'need a MIME::Parser object...' 
		if ! $parser; 
		
	
	# what's going on - 
	# http://search.cpan.org/~dskoll/MIME-tools-5.417/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER
	
	if($MIME_OPTIMIZE eq 'faster'){
	
		$parser->output_to_core(0);
		$parser->tmp_to_core(0);
		$parser->use_inner_files(0);
		$parser->output_dir($TMP);
	
	}elsif($MIME_OPTIMIZE eq 'less memory'){ 
	
		$parser->output_to_core(0);
		$parser->tmp_to_core(0);
		$parser->output_dir($TMP);
	
	}elsif($MIME_OPTIMIZE eq 'no tmp files'){ 
	
		$parser->output_dir($TMP);	# uneeded, but just in case?
		$parser->tmp_to_core(1); 
		$parser->output_to_core(1); # pretty bad when it comes to large files...
		
	}else{ 
	
		die 'bad $MIME_OPTIMIZE setting! (' . $MIME_OPTIMIZE . ')'; 
	}
	
	return $parser; 
}
	
=pod

=back 


=head1 COPYRIGHT

Copyright (c) 1999 - 2005 Justin Simoni 
 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





1;