Authen::Krb5::KDB::V3 - objects for Kerberos V5 database V3 principals

    use Authen::Krb5::KDB::V3;

    $p = Authen::Krb5::KDB::V3->new( data => "..." );

    if ($p->type eq 'princ') {
	print $p->name, ": ", $p->fail_auth_count"\n";
    }

package Authen::Krb5::KDB::V3;

# $Id: V3.pm,v 1.13 2002/10/09 20:41:55 steiner Exp $

use Carp;
use POSIX qw(strftime);
use Authen::Krb5::KDB_H qw(:Attributes KRB5_KDB_V1_BASE_LENGTH);
use Authen::Krb5::KDB::TL;
use Authen::Krb5::KDB::Key;
use Authen::Krb5::KDB::Utils;
use strict;
use vars qw($VERSION);

$VERSION = do{my@r=q$Revision: 1.13 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r};

# If value is 1, the value is read/write and we build the accessor function;
#  if 0, the value is read-only and an accessor function is built.
#  if -1, the accessor function is written by hand

my %Princ_Fields = (
    'type'            =>  0,
    'len'             =>  0,
    'name_len'        =>  0,
    'n_tl_data'       =>  0,
    'n_key_data'      =>  0,
    'e_length'        =>  0,
    'name'            => -1,
    'attributes'      =>  1,
    'max_life'        =>  1,
    'max_renew_life'  =>  1,
    'expiration'      =>  1,
    'pw_expiration'   =>  1,
    'last_success'    => -1,
    'last_failed'     => -1,
    'fail_auth_count' =>  1,
    'tl_data'         => -1,
    'key_data'        => -1,
    'e_data'          => -1,
 );

my %Princ_Ext_Fields = (
    'last_success_dt' => 0,
    'last_failed_dt'  => 0,
 );

### From krb5-1.2.4/src/kadmin/dbutil/dump.c
# * The dump format is as follows:
# *	len strlen(name) n_tl_data n_key_data e_length
# *	name
# *	attributes max_life max_renewable_life expiration
# *	pw_expiration last_success last_failed fail_auth_count
# *	n_tl_data*[type length <contents>]
# *	n_key_data*[ver kvno ver*(type length <contents>)]
# *	<e_data>
# * Fields which are not encapsulated by angle-brackets are to appear
# * verbatim.  Bracketed fields absence is indicated by a -1 in its
# * place

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my %args = @_;
        # checks => level
        # lineno => N
        # data => "string"

    $args{'raw_data'} = $args{'data'};

    my $p = $class->new_princ ( %args );
    return $p;
}

sub new_princ {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my %args = @_;
        # checks => level
        # lineno => N
        # data => "string"
        # raw_data => "string"
    my $self = {};
    my (@data, $n_data_fields, $n_fields);
    my $n_key_data_fields = 0;

    if (defined($args{'data'})) {
	if ($args{'data'} =~ /;$/) { 
	    chop($args{'data'});
	} else {
	    croak "princ record missing final ';' at line $args{'lineno'}";
	}
	@data = split(/\t/, $args{'data'});
	$self->{'raw_data'} = defined($args{'raw_data'}) ? $args{'raw_data'} : $args{'data'};
    } else {
	croak "data for new principal not defined at line $args{'lineno'}";
    }

    $n_data_fields = scalar @data;

    $self->{'type'} = 'princ';

    $self->{'tl_data'} = [];
    $self->{'key_data'} = [];

    $self->{'len'} = shift @data;
    if ($args{'checks'}) {
	if ($self->{'len'} != KRB5_KDB_V1_BASE_LENGTH) {
	    croak "princ len field not ok at line $args{'lineno'}";
	}
    }
    $self->{'name_len'} = shift @data;
    $self->{'n_tl_data'} = shift @data;
    $self->{'n_key_data'} = shift @data;
    $self->{'e_length'} = shift @data;
    $self->{'name'} = shift @data;
    $self->{'attributes'} = shift @data;
    $self->{'max_life'} = shift @data;
    $self->{'max_renew_life'} = shift @data;
    $self->{'expiration'} = shift @data;
    $self->{'pw_expiration'} = shift @data;
    $self->{'last_success'} = shift @data;
    $self->{'last_success_dt'} = strdate($self->{'last_success'});
    $self->{'last_failed'} = shift @data;
    $self->{'last_failed_dt'} = strdate($self->{'last_failed'});
    $self->{'fail_auth_count'} = shift @data;

    if ($args{'checks'}) {
	if ($self->{'name_len'}  != length($self->{'name'})) {
	    carp "princ name length field not ok at line $args{'lineno'}";
	}
    }

    for my $i (1..$self->{'n_tl_data'}) {
	my $type = shift @data;
	my $len = shift @data;
	my $contents = shift @data;
	if ($args{'checks'}) {
	    if (check_length($len*2, $contents)) {
		carp "princ tl length field not ok at line $args{'lineno'}";
	    }
	}
	push @{$self->{'tl_data'}},
             Authen::Krb5::KDB::TL->new ( checks   => $args{'checks'},
					  lineno   => $args{'lineno'},
					  type     => $type,
					  'length' => $len,
					  contents => $contents );
    }

    for my $i (1..$self->{'n_key_data'}) {
	my $ver = shift @data;
	my $kvno = shift @data;
	$n_key_data_fields += 2;
	my $vers = [];
	for my $j (1..$ver) {
	    my $type = shift @data;
	    my $len = shift @data;
	    my $contents = shift @data;
	    $n_key_data_fields += 3;
	    if ($args{'checks'}) {
		if (check_length($len*2, $contents)) {
		    carp "princ key length field not ok at line $args{'lineno'}";
		}
	    }
	    push @$vers, [ $type, $len, $contents ];
	}
	push @{$self->{'key_data'}},
             Authen::Krb5::KDB::Key->new ( checks  => $args{'checks'},
					   lineno  => $args{'lineno'},
					   version => $ver,
					   kvno    => $kvno,
					   data    => $vers );
    }

    $self->{'e_data'} = shift @data;
    if ($args{'checks'}) {
	if (check_length($self->{'e_length'}, $self->{'e_data'})) {
	    carp "princ e_data length field not ok at line $args{'lineno'}";
	}
    }

    # Note: do tl and key data separately and don't count 'type' field
    $n_fields = scalar(keys %Princ_Fields) - 3;
    $n_fields += 3 * $self->{'n_tl_data'};
    $n_fields += $n_key_data_fields;

    if ($n_data_fields != $n_fields) {
	carp "wrong number of data fields for princ at line $args{'lineno'}";
    }

    if (@data) {
	carp "Still data left from principal at line $args{'lineno'}: @data";
    }

    if ($args{'checks'} == 2) {
	_check_level2($self, $args{'lineno'});
    }

    bless($self, $class);
    return $self;
}

sub print_principal {
    my $self = shift;

    if ($self->type() ne 'princ') {
	croak "data is not a princ record but a '" . $self->type() . "'";
    }

    print "Length:        ", $self->len(), "\n";
    print "strlen(Name):  ", $self->name_len(), "\n";
    print "No. tl Data:   ", $self->n_tl_data(), "\n";
    print "No. Key Data:  ", $self->n_key_data(), "\n";
    print "E Length:      ", $self->e_length(), "\n";
    print "Name:          ", $self->name(), "\n";
    print "Attributes:    ", $self->attributes(), "\n";
    if ($self->attributes()) {
	print "               ", $self->get_attributes(), "\n";
    }
    print "MaxLife:       ", $self->max_life(), "\n";
    print "MaxRenewLife:  ", $self->max_renew_life(), "\n";
    print "Expiration:    ", $self->expiration(), "\n";
    print "PW Expiration: ", $self->pw_expiration(), "\n";
    print "Last Success:  ", $self->last_success_dt(),
		       " (", $self->last_success(), ")\n";
    print "Last Failed:   ", $self->last_failed_dt(),
		       " (", $self->last_failed(), ")\n";
    print "Fail Count:    ", $self->fail_auth_count(), "\n";

    my $i = 1;
    print "TL Data:\n";
    foreach my $tl (@{$self->tl_data()}) {
	print " $i: Type:     ", $tl->type(), "\n";
	print "    Length:   ",  $tl->length(), "\n";
	print "    Contents: ",  $tl->contents(), "\n";
	print "      ", $tl->parse_contents(), "\n";
	$i++;
    }
    
    $i = 1;
    print "Key Data:\n";
    foreach my $key (@{$self->key_data()}) {
	print " $i: Ver: ", $key->version(), "\n";
	print "    Kvno: ", $key->kvno(), "\n";
	while ($key->next_data()) {
	    print "      Type:     ", $key->type(), "\n";
	    print "      Length:   ", $key->length(), "\n";
	    print "      Contents: ", $key->contents(), "\n";
	}
	$i++;
    }

    print "E Data: ", $self->e_data(), "\n";
    print "\n";
}

sub get_attributes {
    my $self = shift;
    my @attrs;

    if ($self->type() ne 'princ') {
	croak "data is not a princ record but a '" . $self->type() . "'";
    }

    if ($self->attributes & KRB5_KDB_DISALLOW_POSTDATED) {
	push @attrs, 'DISALLOW_POSTDATED';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_FORWARDABLE) {
	push @attrs, 'DISALLOW_FORWARDABLE';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_TGT_BASED) {
	push @attrs, 'DISALLOW_TGT_BASED';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_RENEWABLE) {
	push @attrs, 'DISALLOW_RENEWABLE';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_PROXIABLE) {
	push @attrs, 'DISALLOW_PROXIABLE';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_DUP_SKEY) {
	push @attrs, 'DISALLOW_DUP_SKEY';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_ALL_TIX) {
	push @attrs, 'DISALLOW_ALL_TIX';
    }
    if ($self->attributes & KRB5_KDB_REQUIRES_PRE_AUTH) {
	push @attrs, 'REQUIRES_PRE_AUTH';
    }
    if ($self->attributes & KRB5_KDB_REQUIRES_HW_AUTH) {
	push @attrs, 'REQUIRES_HW_AUTH';
    }
    if ($self->attributes & KRB5_KDB_REQUIRES_PWCHANGE) {
	push @attrs, 'REQUIRES_PWCHANGE';
    }
    if ($self->attributes & KRB5_KDB_DISALLOW_SVR) {
	push @attrs, 'DISALLOW_SVR';
    }
    if ($self->attributes & KRB5_KDB_PWCHANGE_SERVICE) {
	push @attrs, 'PWCHANGE_SERVICE';
    }
    if ($self->attributes & KRB5_KDB_SUPPORT_DESMD5) {
	push @attrs, 'SUPPORT_DESMD5';
    }
    if ($self->attributes & KRB5_KDB_NEW_PRINC) {
	push @attrs, 'NEW_PRINC';
    }
    return join(' ', @attrs);
}

sub _check_level2 ($$) {
    my $self = shift;
    my $lineno = shift;

    # check TL and Key data elsewhere

    if ($self->{'name_len'} !~ /^\d+$/) {
	carp "name_len is not valid at line $lineno: $self->{'name_len'}";
    }
    if ($self->{'n_tl_data'} !~ /^\d+$/) {
	carp "n_tl_data is not valid at line $lineno: $self->{'n_tl_data'}";
    }
    if ($self->{'n_key_data'} !~ /^\d+$/) {
	carp "n_key_data is not valid at line $lineno: $self->{'n_key_data'}";
    }
    if ($self->{'e_length'} !~ /^\d+$/) {
	carp "e_length is not valid at line $lineno: $self->{'e_length'}";
    }
    if ($self->{'name'} !~ /^[!-~]+$/) { # any ASCII printable char
	carp "name is not valid at line $lineno: $self->{'name'}";
    }
    if ($self->{'attributes'} !~ /^\d+$/) {
	carp "attributes is not valid at line $lineno: $self->{'attributes'}";
    }
    if ($self->{'max_life'} !~ /^\d+$/) {
	carp "max_life is not valid at line $lineno: $self->{'max_life'}";
    }
    if ($self->{'max_renew_life'} !~ /^\d+$/) {
	carp "max_renew_life is not valid at line $lineno: $self->{'max_renew_life'}";
    }
    if ($self->{'expiration'} !~ /^\d+$/) {
	carp "expiration is not valid at line $lineno: $self->{'expiration'}";
    }
    if ($self->{'pw_expiration'} !~ /^\d+$/) {
	carp "pw_expiration is not valid at line $lineno: $self->{'pw_expiration'}";
    }
    if ($self->{'last_success'} !~ /^\d+$/) {
	carp "last_success is not valid at line $lineno: $self->{'last_success'}";
    }
    if ($self->{'last_failed'} !~ /^\d+$/) {
	carp "last_failed is not valid at line $lineno: $self->{'last_failed'}";
    }
    if ($self->{'fail_auth_count'} !~ /^\d+$/) {
	carp "fail_auth_count is not valid at line $lineno: $self->{'fail_auth_count'}";
    }
    if ($self->{'e_data'} ne '-1' and
	$self->{'e_data'} !~ /^[\da-f]+$/) {
	carp "e_data is not valid at line $lineno: $self->{'e_data'}";
    }
}

### Accessor methods

sub name {
    my $self = shift;
    if (@_) {
	$self->{'name'} = shift;
	$self->{'name_len'} = length($self->{'name'});
    }
    return $self->{'name'};
}

sub last_success {
    my $self = shift;
    if (@_) {
	$self->{'last_success'} = shift;
	$self->{'last_success_dt'} = strdate($self->{'last_success'});
    }
    return $self->{'last_success'};
}

sub last_failed {
    my $self = shift;
    if (@_) {
	$self->{'last_failed'} = shift;
	$self->{'last_failed_dt'} = strdate($self->{'last_failed'});
    }
    return $self->{'last_failed'};
}

sub tl_data {
    my $self = shift;
    if (@_) {
	carp "Argument must be a reference to an array"
	    if (ref($_[0]) ne 'ARRAY');
	$self->{'tl_data'} = shift;
	$self->{'n_tl_data'} = scalar @{$self->{'tl_data'}};
    }
    return $self->{'tl_data'};
}

sub key_data {
    my $self = shift;
    if (@_) {
	carp "Argument must be a reference to an array"
	    if (ref($_[0]) ne 'ARRAY');
	$self->{'key_data'} = shift;
	$self->{'n_key_data'} = scalar @{$self->{'key_data'}};
    }
    return $self->{'key_data'};
}

sub e_data {
    my $self = shift;
    if (@_) {
	$self->{'e_data'} = shift;
	if ($self->{'e_data'} == -1) {
	    $self->{'e_length'} = 0;
	} else {
	    $self->{'e_length'} = length($self->{'e_data'});
	}
    }
    return $self->{'e_data'};
}

# generate rest of accessor methods
foreach my $field (keys %Princ_Fields) {
    no strict "refs";
    if ($Princ_Fields{$field} == 1) {
	*$field = sub {
	    my $self = shift;
	    $self->{$field} = shift  if @_;
	    return $self->{$field};
	};
    } elsif (not $Princ_Fields{$field}) {
	*$field = sub {
	    my $self = shift;
	    carp "Can't change value via $field method"  if @_;
	    return $self->{$field};
	};
    }
}

# all these methods are read-only
foreach my $field (keys %Princ_Ext_Fields) {
    no strict "refs";
    *$field = sub {
	my $self = shift;
	carp "Can't change value via $field method"  if @_;
	return $self->{$field};
    };
}

1;
__END__