File Coverage

blib/lib/Data/Password/Manager.pm

Criterion	Covered	Total	%
statement	99	100	99.0
branch	55	60	91.6
condition	3	5	60.0
subroutine	11	11	100.0
pod	5	9	55.5
total	173	185	93.5

package Data::Password::Manager;

use strict;
#use diagnostics;
#use warnings;
use vars qw($VERSION @ISA @EXPORT_OK @to64);
require Exporter;
@ISA = qw(Exporter);
$VERSION = do { my @r = (q$Revision: 0.05 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

@EXPORT_OK = qw(
	pw_gen
	pw_valid
	pw_clean
	pw_obscure
	pw_get
);

#
# crypto lib to decode and encode passwords
#

=head1 NAME

Data::Password::Manager - generate, check, manage B passwords

=head1 SYNOPSIS

  use Data::Password::Manager qw(
        pw_gen
        pw_valid
        pw_obscure
        pw_clean
	pw_get
  );

  $password = pw_gen($cleartext);
  $ok = pw_valid($cleartxt,$password);
  $clean_text = pw_clean($dirty_text);
  ($code,$text) = $pw_obscure($newpass,$oldpass,$min_len);
  $passwd = pw_get($user,$passwd_file,\$error);

=head1 DESCRIPTION

=over 2

=item * $password = pw_gen($cleartext);

Generate a 13 character DES password string from clear text

  input:	string <= 128 characters
  output:	password

=cut

###############################################
# Subroutine to encrypt a string
# uses 'crypt'

sub pw_gen {
  my($clrtxt) = @_;
  my $seed = time + unpack("%16C*", $clrtxt);
  srand;				# init rand generator
  my $salt = &salt_char($clrtxt);	# first salt char
  srand $seed;				# alter rand generator
  $salt .= &salt_char($clrtxt);		# 2nd salt char
  $clrtxt = substr($clrtxt,0,128) if length $clrtxt > 128;
  return crypt($clrtxt,$salt);		# password
}

=item * $ok = pw_valid($cleartxt,$password);

Return true if clear text is password match

  input:	string <= 128 characters,
		password
  output:	true on match, else false

=cut

###############################################
# Subroutine to check a password
# uses 'crypt'
#

sub pw_valid {
  my($plaintxt, $passwd) = @_;
  return crypt($plaintxt, $passwd) eq $passwd
	if $passwd;
# for blank encrypted passwords
  return $plaintxt eq $passwd;
}

=item * $clean_text = pw_clean($dirty_text);

  Clean a text string to only include
  / . 0..9 a..z A..Z

  Useful for restricted password sets
  i.e. http applications

  Returns a string of 128 characters or less

=cut

###############################################
# Subroutine to clean string for crypt use
#
# Input:  [string]
# Output: [clean string <128 characters]

sub pw_clean {
  my $string = $_[0];
  $string =~ tr/[a-zA-Z0-9\/\.]//cd;
  $string = (length $string > 128)
	? substr($string,0,128)
	: $string;
}

=item * ($code,$text) = $pw_obscure($newpass,$oldpass);

Check for a usable password. Returns ok if there is
no old password. i.e. any new password will do.

  input:	string <= 128 characters

  return (0, 'OK') if no old password or new is good
  return ( 1, 'too short' ) if length < $MIN_LEN (default 5)
  return ( 2, 'no change' ) if old eq new
  return ( 3, 'a palindrome' ) if new is a palindrome
  return ( 4, 'case change only' ) if old =~ /$new$/i
  return ( 5, 'to similar' ) see code
  return ( 6, 'to simple' ) if not a good character mix
  return ( 7, 'rotated' ) if new is rotated version of old
  return ( 8, 'flipped' ) if new is old flipped around

=cut

### sub-subroutine to pick a character not in the input string
# Input:  [string]
# Output: [character]
#

@to64 = ('.', '/', 0..9,'A'..'Z', 'a'..'z');

sub salt_char {
  my($clrtxt) = @_;
  my $salt = $to64[rand 64];
# try once again if the character is in the clear text string
  $salt = ($clrtxt =~ /$salt/)
	? $to64[rand 64]
	: $salt;
}

=item * $passwd=pw_get($user,$passwd_file,\$error);

Check a password file for the presence of $user:$password.

  input:	$user
  return:	$password

Returns undef on error and places a descriptive error message in the scalar
$error. Since a valid password can be empty, the caller must check that the
return value is defined, not just false.

FILE is of the form:

	user1:DESpassword1
	user2:DESpassword2
	etc...
	# in-line comments are OK

=back

=cut

# return encrypted password or undef
# since the password can be empty,
# caller must check if "defined"

sub pw_get {
  my($user,$passwd_file,$ep) = @_;
  $$ep = 'could not access password file';
  open(P,$passwd_file)
	or return undef;
  $$ep = "no such user, $user";
  my $passwd;
  foreach() {
    if ($_ =~ /^${user}:(.*)/) {
      $$ep = '';
      $passwd = $1;
      last;
    }
  }
  close P;
  return undef
	if $$ep;
  return $passwd || '';
}


#######################################################
# subroutine to check for obscure password
# This is a port to perl of the functions found
# in the shadow suite.
#######################################################
#
# Copyright 1989 - 1994, Julianne Frances Haugh
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. Neither the name of Julianne F. Haugh nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY JULIE HAUGH AND CONTRIBUTORS `AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL JULIE HAUGH OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

# RCSID("$Id: obscure.c,v 1.7 1998/04/16 19:57:44 marekm Exp $")
#
# This version of obscure.c contains modifications to support "cracklib"
# by Alec Muffet ([e-mail]).  You must obtain the Cracklib
# library source code for this function to operate.
#
#######################################################
# subroutine to do the password checking
#
# Input:	$newpass,[$oldpass],[$minpasslen]
# Return:	( code, message )
#
#		    0	OK
#		   !0	something wrong
#
#sub CryptLibObscure {
#  my($old,$new) = @_;
# @_ = ($new,$old);
# goto &pw_obscure;
#}

sub pw_obscure {
  my ( $oldmono, $newmono );

#  my ( $old, $new )	= @_;
  my ($new,$old,$min_pass_len) = @_;
  $min_pass_len = 5 unless $min_pass_len;

  return (9,'missing new password') unless $new;
  return (0,'OK') unless $old;


  ( $oldmono = $old ) =~ tr/A-Z/a-z/;
  ( $newmono = $new ) =~ tr/A-Z/a-z/;

#  @_ = split ( '', $oldmono );			# turn $old end for end
#  while ( $i = pop ) {
#    $flipped .= $i;
#  }
#  $flipped .= $flipped;

  my $flipped = reverse $oldmono;

  return ( 1, 'too short' ) if ( length ($new) < $min_pass_len );
  return ( 2, 'no change' ) if ( $old eq $new );
  return ( 3, 'a palindrome' ) if ( &CL_Palindrome ($oldmono, $newmono));
  return ( 4, 'case change only' ) if ( $oldmono eq $newmono );
  return ( 5, 'to similar' ) if ( &CL_Similar ($oldmono, $newmono));
  return ( 6, 'to simple' ) if ( &CL_Simple ( $old, $new ));
  $oldmono .= $oldmono;
  return ( 7, 'rotated' ) if ( $oldmono =~ /$newmono/ );
  return ( 8, 'flipped' ) if ( $flipped =~ /$newmono/ );
  return (0,'OK');
}

#######################################################
# subroutine to check for palindrome
#
# Input:	[old], [new]    passwords
# Return:	0, OK
#		1, no good
#
sub CL_Palindrome {
  my ( $i, $j );
  my ( $old, $new ) = @_;
  my @new = split ( '', $new );

# can't be a palindrome - like `R A D A R' or `M A D A M'

  $i = @new;
  for ( $j=0; $j < $i; $j++ ) {
    if ( $new[$i-$j-1] ne $new[$j] ) {
      return (0);
    }
  }
  1;
}

#######################################################
# subroutine to check for similarity between new, old password
#
# Input:	[old], [new]	passwords
# Return:       0, OK
#               1, no good
#
sub CL_Similar {
  my ( $i, $j );
  my ( $old, $new ) = @_;
  my @old = split ( '', $old );

# @new is only used to get cheap length and
# a $#new count so the equation below is consistent
  my @new = split ( '', $new );

# XXX - sometimes this fails when changing from a simple password
# to a really long one (MD5).  For now, I just return success if
# the new password is long enough.  Please feel free to suggest
# something better...  --marekm

  if ( @new >= 8 ) { return (0); }
  $j=0;
  for ( $i=0; ($i<=$#new && $i<=$#old); $i++ ) {
# next line really is $new
    if ( $new =~ /$old[$i]/ ) { ++$j; }
  }
  if ( $i >= $j*2 ) { return (0); }
  1;
}

#######################################################
# subroutine to check for a nice mix of characters
#
# Input:        [old], [new]    passwords
# Return:       0, OK
#               1, no good
#
sub CL_Simple {
  my $i;
  my $digits	= 0;
  my $uppers	= 0;
  my $lowers	= 0;
  my $others	= 0;

  my ( $old, $new ) = @_;
  my @new = split ( '', $new );

  for ( $i=0; $i <= $#new; $i++ ) {
    if ( $new[$i] =~ /[0-9]/ ) { ++$digits;
    } elsif ( $new[$i] =~ /[a-z]/ ) { ++$lowers;
    } elsif ( $new[$i] =~ /[A-Z]/ ) { ++$uppers;
    } else { ++$others; }
  }

# The scam is this - a password of only one character type
# must be 8 letters long.  Two types, 7, and so on.

  my $size = 9;
  if ( $digits ) { --$size; }
  if ( $uppers ) { --$size; }
  if ( $lowers ) { --$size; }
  if ( $others ) { --$size; }

  if ( $size <= $i ) { return (0); }
  1;
}
1;
__END__