View of /DadaFork/DADA/Security/SimpleAuthStringState.pm

Parent Directory

Revision Log

Base version: DadaMail 2.10.12

package DADA::Security::SimpleAuthStringState; 

use strict; 


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

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


use base qw(DADA::App::GenericDBFile);

sub new {
	my $class = shift;
	
	my %args = (-List => undef,
				-new_list => 0,  
					@_); 
					     
    my $self = SUPER::new $class (
    							  function => 'simple_auth_string_state',
    							 );  
	   
	   $self->_init; 
	   return $self;
}

sub _init { 
    
    my $self = shift; 
    $self->_can_use_md5;


}

sub make_state { 

    my $self = shift; 
    my $str = $self->_create_auth_string; 
    $self->_open_db; 
        $self->{DB_HASH}->{$str} = 1;
    $self->_close_db; 
    
    return $str;
    
}

sub remove_state { 

    my $self  = shift; 
    my $state = shift; 
    
    $self->_open_db; 
    $self->{DB_HASH}->{$state} = undef;
    delete($self->{DB_HASH}->{$state});
    $self->_close_db; 
}

sub check_state {

    my $self  = shift; 
    my $state = shift;
    my $auth  = 0; 
    $self->_open_db; 
    
    if(exists($self->{DB_HASH}->{$state})){ 
        if($self->{DB_HASH}->{$state} == 1){ 
        
             $self->_close_db; 
             $self->remove_state($state); 
             
             return 1; 

        } else { 
             
             $self->_close_db; 
             $self->remove_state($state); 

            return 0; 
        }
    
    } else { 
        return 0; 
    }
 
   

}




sub _can_use_md5 { 


    my $self = shift; 
    	
	my $can_use_md5 = 0; 	
	
	
    eval {require Digest::MD5}; # hey, just in case, right?
    if(!$@){
        $self->{can_use_md5} = 1; 
    }	
}


sub _create_auth_string { 

	my $self = shift; 
	require    DADA::Security::Password; 
	my $str  = DADA::Security::Password::generate_rand_string(undef, 64);
	
	if($self->{_can_use_md5}){
	
	    require Digest::MD5; # Reminder: Ship with Digest::Perl::MD5....
        
        if($] >= 5.008){
            require Encode;
            my $cs = Digest::MD5::md5_hex(Encode::encode_utf8($$str));
            return $cs;
        }else{ 			
            my $cs = Digest::MD5::md5_hex($$str);
            return $cs;
        }
   } else { 
    # Guess we're faking it...
      return $str; 
   }

} 





1;


__END__




sub tally_up_scores { 

    my $self   = shift; 
    my $scores = shift; 
    my $give_back_scores = {}; 
    
    $self->_open_db; 
		    
    foreach(keys %$scores){ 
       $self->{DB_HASH}->{$_} += $scores->{$_};
       #warn "$_ has a score of " . $self->{DB_HASH}->{$_}; 
       $give_back_scores->{$_} = $self->{DB_HASH}->{$_};
    }
    $self->_close_db; 
    
    return $give_back_scores; 
}




sub removal_list { 

    my $self         = shift; 
    my $threshold    = shift || 0; 
    my $removal_list = [];

    $self->_open_db; 
    
    foreach(keys %{$self->{DB_HASH}}){
    
          if($self->{DB_HASH}->{$_} >= $threshold){
            #warn "Adding $_ to removal list.";
            push(@$removal_list, $_);
        }

    }
    
    $self->_close_db; 
    
    return $removal_list

}




sub flush_old_scores { 

    my $self = shift; 
    my $threshold = shift || 0;

    $self->_open_db; 
    
    foreach(keys %{$self->{DB_HASH}}){
    
        if($self->{DB_HASH}->{$_} >= $threshold){
            #warn "Removing $_ from score card.";
            $self->{DB_HASH}->{$_} = 0; # for whatever reason that it doesn't get removed...
            delete($self->{DB_HASH}->{$_});
        }

    }
    
    $self->_close_db; 

    # Flushing - shouldn't be needed? 
	$self->_open_db; 
	$self->_close_db;

}




sub erase { 

    my $self = shift; 
    
    $self->_open_db; 
    $self->{DB_HASH} = {}; 
    $self->_close_db; 

    # Flushing - shouldn't be needed? 
	$self->_open_db; 
	$self->_close_db;
	
	return 1; 

}



1;