#!/usr/bin/perl -w
#
# $Id: cvspass.pl,v 1.9 2003/08/06 16:55:34 jmates Exp $
#
# The author disclaims all copyrights and releases this script into the
# public domain.
#
# Run perldoc(1) on this file for additional documentation.
#
######################################################################
#
# REQUIREMENTS

require 5;

use strict;

######################################################################
#
# MODULES

use Carp;         # better error reporting
use Getopt::Std;  # command line option processing

######################################################################
#
# VARIABLES

my $VERSION;
($VERSION = '$Revision: 1.9 $ ') =~ s/[^0-9.]//g;

my (%opts);

# changing min might play havoc with the hand-tweaked scoring system!
my $min_length = 5;
my $max_length = 8;

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

######################################################################
#
# MAIN

# parse command-line options
getopts('h?', \%opts);

help() if exists $opts{'h'} or exists $opts{'?'};

# optional args
my $username   = shift || '';
my $systemname = shift || '';

# solicit password from STDIN (unless not on a tty, in which case
# we probably want to read the password in automagically...)
my $word;

PWCHECK: for (;;) {
  $word = solicit_passwd();

  # some sanity checks for "decent" password
  unless (defined $word) {
    warn "Error: passwords did not match.\n";
    next PWCHECK;
  }

  if (length $word < $min_length) {
    warn "Error: too short, at least $min_length characters required.\n";
    next PWCHECK;
  }
  if (length $word > $max_length) {
    warn "Error: too long, no more than $max_length characters allowed.\n";
    next PWCHECK;
  }

  if (check_passwd_str($word, $min_length) < 0) {
    warn "Error: password too simple.\n";
    next PWCHECK;
  }

  last PWCHECK;
}

print(($username) ? "$username:" : '');
print crypt $word, join '', (@salt)[rand 64, rand 64];
print(($systemname) ? ":$systemname\n" : "\n");

exit;

######################################################################
#
# SUBROUTINES

sub solicit_passwd {
  my ($first, $second);

  system "stty -echo";
  print "Password: ";
  chomp($first = <STDIN>);

  print "\nAgain:    ";
  chomp($second = <STDIN>);
  print "\n\n";

  system "stty echo";

  return if $first ne $second;

  return $first;
}

# simple "decent" password checking routine; accepts plaintext
# password and a minimum length that the score is based around.
#
# returns a number, where negative are "bad" passwords (though
# this will depend on how one has tweaked the various tests...
sub check_passwd_str {
  my $word = shift;
  my $min  = shift;

  my (%data, $score);

  # length checks, "longer is better"
  $data{length} = length $word;
  $score += ($data{length} - $min) * 5;

  # character-based frequency count...
  my %chars;
  $chars{$_}++ for split //, $word;

  # punish passwords with low numbers of uniques
  # (this prevents "^^^^^^^^" as a password :)
  $data{uniq_score} = sprintf "%.f", $data{length} / (keys %chars) * 10 - 10;
  $score -= $data{uniq_score};

  undef %chars;

  # punish "simple" passwords brute forcers check for first
  $score -= 25 if $word =~ /^\d+$/;
  $score -= 20 if $word =~ /^[A-Za-z][a-z]+$/;

  # a-z0-9 like "dna578" bad
  $score -= 20 if $word =~ /^[A-Za-z][a-z]+\d+$/;
  $score -= 20 if $word =~ /^\d+[A-Za-z][a-z]+$/;

  # similar, but w/ non-alpha tail
  $score -= 15 if $word =~ /^[A-Za-z][a-z]+\D{1,2}$/;
  $score -= 15 if $word =~ /^\D{1,2}[A-Za-z][a-z]+$/;

  # increase score for non-alphanumeric chars
  $score++ for $word =~ /[^A-Za-z0-9]/g;

  # only allow simple character sets on longer passwords
  $score -= 5 if $word =~ /^[a-zA-Z0-9]+$/;

  # help GC clean out memory of this...
  undef $word;
  undef %data;

  return $score;
}

# a generic help blarb
sub help {
  print <<"HELP";
Usage: $0 [username] [systemname]

Run perldoc(1) on this script for additional documentation.

HELP
  exit;
}

######################################################################
#
# DOCUMENTATION

=head1 NAME

cvspass - generates CVS password hashes

=head1 SYNOPSIS

  $ cvspass cvs localcvs

=head1 DESCRIPTION

=head2 Overview

Generates crypt password hashes suitable for maintaining a cvs passwd
file.  If an optional username and systemname are supplied, output
will be generated suitable for addition to an existing CVSROOT/passwd
file.  Without the names, just a password hash is printed out.

=head2 Normal Usage

  $ cvspass [username] [systemname]

User will be prompted for non-echoed password twice, which is then
checked for validity, etc.

=head1 OPTIONS

This script currently supports the following command line switches:

=over 4

=item B<-h>, B<-?>

Prints a brief usage note about the script.

=back

=head1 BUGS

=head2 Reporting Bugs

Newer versions of this script may be available from:

http://sial.org/code/perl/

If the bug is in the latest version, send a report to the author.
Patches that fix problems or add new features are welcome.

=head2 Known Issues

None.

=head1 SEE ALSO

perl(1)

=head1 AUTHOR

Jeremy Mates, http://sial.org/contact/

=head1 COPYRIGHT

The author disclaims all copyrights and releases this script into the
public domain.

=head1 VERSION

  $Id: cvspass.pl,v 1.9 2003/08/06 16:55:34 jmates Exp $

=cut