package DADA::App::Guts;


=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 qw(!:DEFAULT);  

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
uriencode
js_enc

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

check_list_security
user_error
check_setup

cased
root_password_verification
xss_filter
isa_ip_address
check_referer

escape_for_sending

entity_protected_str

optimize_mime_parser



);




use strict; 
use vars qw(@EXPORT); 

my %GLOBAL = (
available_lists => [],  
); 



=pod

=head2 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<@DADA::Config::EMAIL_EXCEPTIONS> array in the Config file. Good for testing. 


=cut


sub check_for_valid_email { 

    my $email = shift or undef;
    my $email_check = 0;

    require Email::Valid;
    if(defined(Email::Valid->address(-address => $email, -fudge => 0))){     
        $email_check =  0;
    } else { 
        
        $email_check =  1;
    }
	my %exceptions; 
	foreach(@DADA::Config::EMAIL_EXCEPTIONS){
	    $exceptions{$_}++
	} 
	$email_check = 0 if exists($exceptions{$email}); 	
	return $email_check; 

}
							
							
							
							
=pod

=head2 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

=head2 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

=head2 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 $DADA::Config::PIN_WORD  and the $DADA::Config::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 $DADA::Config::PIN_NUM  and $DADA::Config::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*", $DADA::Config::PIN_WORD );
		 
		# make the pin by adding the $pin and $DADA::Config::PIN_NUM ber together, 
		# multiplying by a number you can pick 
		# and subtract that number by the $pin helper. 
		
		$pin = ((($pin + $pin_helper) * $DADA::Config::PIN_NUM ) - $pin_helper); 
		
		# give it back. 
		return $pin; 
		
	}else{ 
	
		return undef;
	
	}
}

=pod

=head2 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*", $DADA::Config::PIN_WORD );
		$check_pin = ((($check_pin + $pin_helper) * $DADA::Config::PIN_NUM ) - $pin_helper);
	
	  if ($check_pin != $pin){ 
	  	$invalid_pin++;
	  }
		return  $invalid_pin; 
	 }else{ 
		return 1; 
	}
}



=pod

=head2 make_template


	make_template({ 
	              -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 $DADA::Config::TEMPLATES  directory (which is usually set the same as $DADA::Config::FILES)
under the name $listname.template, where $listname is the List's shortname.

=cut

sub make_template { 

    my ($args) = @_;

    if ( !$args->{-List} ) {
        carp
            "You need to supply a List make_template({-List => your_list}) in the paramaters.";
        return undef;
    }
    
    if ( !$args->{-Template} ) {
        carp
            "You need to supply a Template make_template({-Template => your_list}) in the paramaters.";
        return undef;
    }

	
	#get the variable
	my $print_template = $args->{-Template};
	my $list_path = $DADA::Config::TEMPLATES;
	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,  $DADA::Config::FILE_CHMOD ) or 
			croak "$DADA::Config::PROGRAM_NAME $DADA::Config::VER Error: can't write new template at '$list_path/$list_template.template': $!"; 
	
		flock(TEMPLATE, LOCK_EX) or 
			croak "$DADA::Config::PROGRAM_NAME $DADA::Config::VER Error: can't lock to write new template at '$list_path/$list_template.template': $!" ; 
		
		print TEMPLATE $print_template;
		
		close(TEMPLATE); 
	
	    chmod($DADA::Config::FILE_CHMOD , "$list_path/$list_template.template"); 

	}else{ 	
			carp('$DADA::Config::PROGRAM_NAME $DADA::Config::VER Error: no list name was given to save new template');
			return undef;
	}
}



=pod

=head2 delete_list_template

	delete_list_template({ -List => $list }); 


deletes a template file for a list. 

=cut

sub delete_list_template { 

    my ($args) = @_;

     if ( !$args->{-List} ) {
        carp
            "You need to supply a List make_template({-List => your_list}) in the paramaters.";
        return undef;
    }
    

    my $list = $args->{-List} || undef; 
    
     $list = make_safer($list); 
     $list =~ /(.*)/; 
     $list = $1;              
     my $deep_six = $DADA::Config::TEMPLATES . '/' . $list . '.template';
     
     if(-e $deep_six){ 
     
         my $n = unlink($deep_six); 
         
         if($n == 0){
            carp $deep_six . " didn't go quietly"; 
            return 0; 	
         } else { 
            return 1; 
         }
    } else {
       # It's actually "OK" if there's no template. 
       #carp 'No template at ' . $deep_six . ' to remove!'; 
        return 1; 
    }

}




=pod

=head2 delete_list_info

	delete_list_info(-List => $list); 

deletes the db file for a list. 

=cut

sub delete_list_info { 

	my %args = ( 
	-List      => undef, 
	@_);
	
	my $list  = $args{-List} || undef; 
	
	if($list){ 
	
		# DEV: This is really bad form - do not emulate!
	
		if($DADA::Config::SETTINGS_DB_TYPE =~ /MySQL|PostgreSQL/){ 
		
			require DADA::App::DBIHandle; 
	    	my $dbi_handle = DADA::App::DBIHandle->new; 
			my $dbh = $dbi_handle->dbh_obj; 
		
			my $query = 'DELETE FROM ' . $DADA::Config::SQL_PARAMS{settings_table} .' WHERE list = ?'; 
			my $sth = $dbh->prepare($query);
			   $sth->execute($list); 
		       $sth->finish; 
		       
		}else {
		
			my $deep_six;
	
	
			opendir(LISTS, $DADA::Config::FILES) or croak "can't open '$DADA::Config::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("$DADA::Config::FILES/$deep_six"); 
				} 
			 }
		}
	}else{ 
		carp('$DADA::Config::PROGRAM_NAME $DADA::Config::VER Error: No list name given to delete list database');
		return undef;
	}
}

=pod

=head2 delete_email_list

	delete_email_list(-List => $list); 

deletes the email list for a list. 

=cut

sub delete_email_list { 

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

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

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

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

    if(-e $deep_six){ 
        my $n = unlink($deep_six);
        carp "couldn't delete '$deep_six'! " . $!
            if $n == 0;
    }
}

=pod

=head2 check_if_list_exists

	check_if_list_exists(-List => $list, ); 

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, 
	            -dbi_handle => undef, 
	            
				@_); 
	
	if($args{-List}){ 
	
		my (@available_lists) = available_lists(-dbi_handle => $args{-dbi_handle});
		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

=head2 available_lists

	my @lists = available_lists();

return an array containing the listshortnames of available list. 

Can take a few paramaters - all are optional: 

=over

=item * -As_Ref

returns a reference to an array, instead of an array

=item * -In_Order

returns the array in alphabetic order - but B<NOTE:> not in alphabetical order based on the listshortnames, but of the actual list names. 

=item * -Dont_Die

As the name implies, the subroutine won't kill the program calling it, if there's a problem opening the directory you've set in the Config.pm B<$FILES> variable. 

=item * -dbi_handle

In Dada Mail, dbi handles are passed to different methods/subroutines in various was, so that they may be reused. 

If you're using Dada Mail with the SQL backend for the list settings, you could do something like this: 

 use DADA::Config; 
 use DADA::App::Guts; 
 
 my $dbi_handle; 
 
 if($SETTINGS_DB_TYPE =~ m/SQL/){        
     require DADA::App::DBIHandle; 
     $dbi_handle = DADA::App::DBIHandle->new; 
 }
 
 my @available_lists = DADA::App::Guts::available_lists(-dbi_handle => $dbi_handle); 

to reuse the database handle you've just made. 

=back

Using all these paramaters at once would look something like this: 

 my $available_lists = available_lists(
                                        -As_Ref => 1, 
                                        -In_Order => 1, 
                                        -Dont_Die => 1, 
                                        -dbi_handle => $dbi_handle, 
                                       );


=cut

sub available_lists { 

    
	my %args = ( 
				-As_Ref     => 0,
				-In_Order   => 0,
				-Dont_Die   => 0,
				-dbi_handle => undef, 
				@_
			   ); 
	

	my $want_ref        = $args{-As_Ref};
	my @dbs             = ();
	my @available_lists = (); 
	my $present_list;
	
	require DADA::MailingList::Settings; 
		   $DADA::MailingLIst::Settings::dbi_obj = $args{-dbi_handle}; 

# DEV: This is really bad form - do not emulate!

	if($DADA::Config::SETTINGS_DB_TYPE =~ /MySQL|PostgreSQL/){ 
		
		require DADA::App::DBIHandle; 
	    my $dbi_handle = DADA::App::DBIHandle->new; 
		my $dbh = $dbi_handle->dbh_obj; 

		my $query  = 'SELECT DISTINCT list from ' . $DADA::Config::SQL_PARAMS{settings_table}; 
		   $query .= ' ORDER BY list ASC'
			 if $args{-In_Order} == 1; 
		
		my $sth = $dbh->prepare($query); 
		   $sth->execute(); 
		
		while((my $l) = $sth->fetchrow_array){ 
				push(@available_lists, $l); 
			}
			
		$sth->finish;

		$want_ref == "1" ? return \@available_lists : return @available_lists;

		
	}

#/end bad form :) 


	
	
	
	my $path = $DADA::Config::FILES; 
	 #untaint 
	$path = make_safer($path); 
	$path =~ /(.*)/; 
	$path = $1; 
	
	if(opendir(LISTS, $DADA::Config::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("$DADA::Config::PROGRAM_NAME $DADA::Config::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

=head2 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 $args{-Write_Month}   == 1; 
		   $date .= "$end{$day} "            if $args{-Write_Day}     == 1; 		
		   $date .= "$year "                 if $args{-Write_Year}    == 1; 
		   $date .= "$hour:$minute"          if $args{-Write_H_And_M} == 1; 
		   $date .= ":$second "              if $args{-Write_Second}  == 1; 
		   $date .= "$ending"              if $args{-Write_H_And_M} == 1; 
		
		return $date; 
		
	}
}

=pod

=head2 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 = shift;
 
     
 #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/\&hellip\;/\&\#133\;/g; 
 $message_body =~ s/\&bull\;/\&#149\;/g; 
# Currently, I don't know what to set this as... so we'll set it as... this!
 $message_body =~ s/\&#149\;/\*/g; 
 
 $message_body =~ s/\&nbsp\;/ /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


 


 
 $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

# }


	eval {require HTML::Entities}; 
	if(!$@){ 
		$message_body = HTML::Entities::decode_entities($message_body);
	}else{ 
		
		# thar be old, crufty code
		 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
		 );
		 
	 
	 $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

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



sub js_enc {

my $str = shift || '';
my @chars = split(//,$str);
foreach my $c (@chars) {
$c = '\x' . sprintf("%x", ord($c));
}
my $e =  join('',@chars);

$e =~ s/\\xa|\\xd/ /g;
$e =~ s/\\x9/\t/g;
return $e; 

}



   
=pod
               
=head2 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($DADA::Config::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

=head2 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;
	
	my %orig_HTMLFROMTEXT_OPTIONS = %DADA::Config::HTMLFROMTEXT_OPTIONS; 
		
	# 1.005 of HTML::FromText sucks at entities, so if we can, let's do a better job...
	if($DADA::Config::HTMLFROMTEXT_OPTIONS{metachars} == 1){ 
	
		eval {require HTML::Entities}; 
		if(!$@){ 
		
			%DADA::Config::HTMLFROMTEXT_OPTIONS = (
				                      %DADA::Config::HTMLFROMTEXT_OPTIONS,
				                      metachars => 0, 
									); 
		
			$s = HTML::Entities::encode_entities($s, "\200-\377");
			
		}else{ 
		    
	        # require HTML::EntitiesPurePerl 
            # is our own module, based on  HTML::Entities. 
            
            eval {require HTML::EntitiesPurePerl}; 
		    if(!$@){ 
		    
		        $s = HTML::EntitiesPurePerl::encode_entities($s, "\200-\377");
		    
		    }


		}
				
		# lame - atom feeds  bitch about this: 
        # TODO - make something for RSS/ATOM feeds that turns all the 
        # named entitied into numbered. 
        # Should be done!
        #$s =~ s/\&eacute;/\&#233;/g; 
        
        
        # SWEAR TO YOU - this is what it usually does: 
        $s =~      s/& /&amp; /g;
        $s =~      s/</&lt;/g;
        $s =~      s/>/&gt;/g;
        $s =~      s/\"/&quot;/g;
      
      
		  
		
	}
	
	$s = HTML::FromText::text2html($s, %DADA::Config::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;	


    #$s =~ s/(\[snip\]|\[code\])<br>/<pre>/gi; 
    #$s =~ s/(\[\/snip\]|\[\/code\])<br>/<\/pre>/gi; 

    $s =~ s/\<br\>/\<br \/\>/gi;

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

=pod

=head2 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\]/$DADA::Config::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; 
		}
		
		if($db_ref->{website_name}){ 
			$string =~ s/\[website_name\]/$db_ref->{website_name}/go; 
		}
		
		if($db_ref->{website_url}){ 
			$string =~ s/\[website_url\]/$db_ref->{website_url}/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

$DADA::Config::TMP/ 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;
		}
		
		
		# it means that the password we're using for the list, 
		# is the Dada Mail Root Password - doh!
		if(root_password_verification($fields->{password}) == 1){ 
		    $list_errors++;
		    $new_list_errors{password_is_root_password} = 1;
		}else{ 
		    $new_list_errors{password_is_root_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

=head2 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($DADA::Config::ROOT_PASS_IS_ENCRYPTED == 1){ 	
		my $root_password_check = DADA::Security::Password::check_password($DADA::Config::PROGRAM_ROOT_PASSWORD, $root_pass); 
		if($root_password_check == 1){
			return 1; 
		}else{ 
			return 0; 
		}
	}else{ 
		if($DADA::Config::PROGRAM_ROOT_PASSWORD eq $root_pass){ 
			return 1; 
		}else{ 
			return 0; 
		}
	}
}




=pod

=head2 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($DADA::Config::SUBSCRIBER_DB_TYPE eq 'PlainText'){ 
		# make email list file
		sysopen(LIST, "$DADA::Config::FILES/$list.list", O_RDWR|O_CREAT, $DADA::Config::FILE_CHMOD )
			or croak "couldn't open $DADA::Config::FILES/$list.list for reading: $!\n";
		flock(LIST, LOCK_SH);
		close (LIST);
		
		#chmod!
		chmod($DADA::Config::FILE_CHMOD , "$DADA::Config::FILES/$list.list"); 	
	
		# make e-mail blacklist file
		sysopen(LIST, "$DADA::Config::FILES/$list.black_list", O_RDWR|O_CREAT, $DADA::Config::FILE_CHMOD )
			or croak "couldn't open $DADA::Config::FILES/$list.black_list for reading: $!\n";
		flock(LIST, LOCK_SH);
		close (LIST);
		#chmod!
		chmod($DADA::Config::FILE_CHMOD , "$DADA::Config::FILES/$list.black_list"); 	 
	
	}
	#require DADA::Template::HTML; 
	#my $print_template = DADA::Template::HTML::default_template($DADA::Config::PROGRAM_URL); 
	#make a template file 
	#print it out.
	#sysopen(TEMPLATE,"$DADA::Config::TEMPLATES /$list.template", O_RDWR|O_CREAT, $DADA::Config::FILE_CHMOD ) 
	#	or croak "couldn't open '$DADA::Config::TEMPLATES /$list.template' for writing: $!\n";
	#print TEMPLATE $print_template;
	#close(TEMPLATE); 
	#chmod!
	#chmod($DADA::Config::FILE_CHMOD , "$DADA::Config::TEMPLATES /$list.template"); 
	
	
	#do some hardcore guessin'
	chmod($DADA::Config::FILE_CHMOD , 
	"$DADA::Config::FILES/mj\-$list",
	"$DADA::Config::FILES/mj\-$list.db",
	"$DADA::Config::FILES/mj\-$list.pag",
	"$DADA::Config::FILES/mj\-$list.dir",
	);  
	
	return 1; 
	
}


=pod

=head2 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, 
				-dbi_handle      => {}, 
				@_);
	croak '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

=head2 check_setup

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

$DADA::Config::FILES
$DADA::Config::TEMPLATES 
$DADA::Config::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($DADA::Config::OS =~ /^Win|^MSWin/i){ 
		carp "directory setup test disabled for WinNT";
		return 1; 
	}else{ 	
		my @tests = ($DADA::Config::FILES, $DADA::Config::TEMPLATES , $DADA::Config::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

=head2 cased

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


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

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

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

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

=cut

sub cased {
	my $str = shift; 
	if($DADA::Config::EMAIL_CASE eq 'lc_all'){ 	
		return lc($str);
	}elsif($DADA::Config::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

=head2 xss_filter

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



sub isa_ip_address { 

    my $ip_address = shift; 
        
    
    my $ReIpNum = qr{([01]?\d\d?|2[0-4]\d|25[0-5])};
    my $ReIpAddr = qr{^$ReIpNum\.$ReIpNum\.$ReIpNum\.$ReIpNum$};
    
 
            if ($ip_address =~ m{$ReIpAddr} == 1){
                return 1; 
            } else { 
                return 0; 
            }

}



=pod

=head2 check_referer

 check_referer($q->referer());

Checks to see if the referer is the same as what's set in $DADA::Config::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 ($DADA::Config::PROGRAM_URL && ($DADA::Config::PROGRAM_URL =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i)) {
    	push(@referers, $2);
    }
	
	if ($DADA::Config::S_PROGRAM_URL && ($DADA::Config::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; 
	
	croak '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($DADA::Config::MIME_OPTIMIZE eq 'faster'){
	
		$parser->output_to_core(0);
		$parser->tmp_to_core(0);
		$parser->use_inner_files(0);
		$parser->output_dir($DADA::Config::TMP );
	
	}elsif($DADA::Config::MIME_OPTIMIZE eq 'less memory'){ 
	
		$parser->output_to_core(0);
		$parser->tmp_to_core(0);
		$parser->output_dir($DADA::Config::TMP );
	
	}elsif($DADA::Config::MIME_OPTIMIZE eq 'no tmp files'){ 
	
		$parser->output_dir($DADA::Config::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{ 
	
		croak 'bad $DADA::Config::MIME_OPTIMIZE setting! (' . $DADA::Config::MIME_OPTIMIZE . ')'; 
	}
	
	return $parser; 
}
	
=pod

=head1 COPYRIGHT

Copyright (c) 1999-2007 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; 

