RADIUS::UserFile - Perl extension for manipulating a RADIUS users file.

  use RADIUS::UserFile;

  my $users = new RADIUS::UserFile 
                  File => '/etc/raddb/users',
                  Check_Items => [ qw(Password Calling-Station-Id) ];

  $users->load('/usr/local/etc/radius/users');

  $users->add(Who        => 'joeuser',
              Attributes => { key1 => 'val1', key2 => 'val2' },
              Comment    => 'Created on '. scalar localtime);

  $users->update(File => '/etc/raddb/users',
                 Who => qw(joeuser janeuser));

  print $users->format('joeuser');

package RADIUS::UserFile;

require 5.004;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Carp;
use IO::File;
use File::Copy;
use Fcntl qw(:flock);
use Tie::IxHash;

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(add attributes comment dump files format load new read_users
                update user usernames users values);

$VERSION = '1.01';

#my $RADIUS_USERS = '/etc/raddb/users';  # default users info file
my $ATTR_MAX = 31;                      # max char len of any attribute name

my %fields = (
    users       => undef,
    removed     => undef,              # cheap hack for remove()
    files       => undef,
    comments    => undef,
    check_items => undef,
    ERROR       => undef,
    DEBUG       => undef
);

# Create, initialize, and return a new RADIUS::UserFile object.
#
sub new
{
    my $me = shift;
    my $class = ref($me) || $me;
    my $self = { %fields };
    bless $self, $class;

    my %args = @_;
    return $self->_initialize(\%args);
}


# Do initial object-creation setup stuff.
# 
sub _initialize
{
    my ($self, $args) = @_;

    if ($args->{Debug}) {
        $self->{DEBUG} = $args->{Debug};
        $| = 1;
    }

    if ($args->{Check_Items}) {
        $self->{check_items} = [ @{$args->{Check_Items}} ];
    }
    else {
	    $self->{check_items} = [ "Password", "Auth-Type",
	                             "Called-Station-Id", "Calling-Station-Id",
                                 "Client-Port-DNIS", "Expiration" ];
    }

    if ($args->{File}) {
        $self->debug(7, "init - loading $args->{File}");
        my ($users, $comments) = $self->read_users($args->{File}, $args->{Who});
        return 0 unless defined $comments and defined $users;

        if ($users) {
            @{$self->{users}}{keys %$users} = values %$users;
            @{$self->{comments}}{keys %$comments} = values %$comments;
            push @{$self->{files}}, $args->{File};
        }
    }

    return $self;
}


# Adds the specified user to the collection.  The arguments provided should
# form a hash with the following structure:
#  'Who' => "user_name"
#  'Attributes' => { key1 => val1, key2 => [ val2 val3 val4 ], ... }
#  'Comment' => "optional text to prefix the user's file entry"
#
# If there is some type of failure, 0 is returned.  Otherwise, 1.
sub add
{
    my ($self, %args) = @_;

    unless ($args{Who} and ref $args{Attributes} eq 'HASH') {
        carp('Insufficient parameters:  missing Who or hash of Attributes.');
        return 0;
    }
    $self->debug(6, "add - adding $args{Who}");

    # Add quotes to each attrib value if it has whitespace and isn't already
    # quoted.
    foreach my $k (keys %{$args{Attributes}}) {
        if (ref $args{Attributes}->{$k} eq 'ARRAY') {
            for (my $i=0; $i <= $#{$args{Attributes}->{$k}}; $i++) {
                $args{Attributes}->{$k}[$i] =~ s/^([^"].*[\s,].*)$/"$1"/;
            }
        }
        else {
            $args{Attributes}->{$k} =~ s/^([^"].*\s.*)$/"$1"/;
        }
    }

    tie %{$self->{'users'}{$args{Who}}}, 'Tie::IxHash'
     unless tied %{$self->{'users'}{$args{Who}}};

    foreach my $k (keys %{$args{Attributes}}) {
        push @{$self->{'users'}{$args{Who}}{$k}},
             ref $args{Attributes}->{$k} eq 'ARRAY'
               ? @{$args{Attributes}->{$k}}
               : $args{Attributes}->{$k}
    }

    if (exists $args{Comment}) {
        $args{Comment} =~ s/^/# /mg;
        $self->{comments}{$args{Who}} .= $args{Comment}. "\n";
    }

    return 1;
}


# Return a list of defined RADIUS attributes for the specified user.
#
sub attributes
{
    my ($self, $who) = @_;
    my @a = eval { local $^W = undef; keys %{$self->{'users'}{$who}} };
    return $@ ? undef : @a;
}


# Return the comment text associated with a user.
#
sub comment
{
    my ($self, $who) = @_;
    my $text = eval { local $^W = undef; $self->{comments}{$who} };
    return $@ ? undef : $text;
}


# Print the attributes of the specified user.
#
sub dump
{
    my ($self, $who) = @_;

    return $self unless defined $self->user($who);
    my @attribs = $self->attributes($who);

    print "RADIUS user $who:\n";

    if (@attribs) {
        foreach my $a (@attribs) {
            foreach my $v ($self->values($who, $a)) {
                printf "  %-${ATTR_MAX}s => %s\n", $a, $v;
            }
        }
    }
    else {
        print "  no attributes defined.\n";
    }

    return $self;
}


# Return a ref to a list of files that we have read user info from.
#
sub files
{
    my $self = shift;
    my @files = eval { local $^W = undef; @{$self->{files}} };
    return $@ ? () : @files;
}


# Return a string containing the attributes for the given user, in the
# format acceptable to a RADIUS users file.  If the user doesn't exist,
# an empty string is returned.
sub format
{
    my ($self, $who) = @_;

    return '' unless defined $self->user($who);
    my $str = $self->comment($who);

    my @attribs = $self->attributes($who);

    # figure out a good way to indent each record
    my $indent = length($who) + 1;
    if ($indent < 24) { $indent = 24 }

    if (@attribs) {
        my (@attrib_strs);
        my @checks = ();

        foreach my $a (@attribs) {
            foreach my $v ($self->values($who, $a)) {
                if ($self->_is_check_item($a)) {
                    $self->debug(8, "format - check item $a = $v");
                    push @checks, "$a = $v";
                }
                else {
                    push @attrib_strs,
                     sprintf("%s%s = %s", ' 'x$indent, $a, $v);
                }
            }
        }
        $str .= $who. (' 'x($indent - length $who)). join(', ', @checks). "\n";
        $str .= join(",\n", @attrib_strs). "\n";
    }

    return $str;
}


# Read user attributes from the specified file.  If a set of users is
# specified using "Who", the information is limited to those users.
#
sub load
{
    my ($self, %args) = @_;
    my $file = $args{File};
    my $who  = $args{Who};

    my ($users, $comments) = $self->read_users($file, $who);
    return 0 unless defined $comments and defined $users;

    foreach my $u (keys %$users) {
        tie(%{$self->{'users'}{$u}}, 'Tie::IxHash');
        foreach my $a (keys %{$users->{$u}}) {
            push @{$self->{'users'}{$u}{$a}}, @{$users->{$u}{$a}};
        }
    }
    foreach my $user (keys %$comments) {
        $self->{comments}{$user} .= $comments->{$user};
    }
    push @{$self->{'files'}}, $file;

    return 1;
}


# Read in a radius users file, according to the EBNF provided in
# "users-file-syntax.1", distributed w/the Ascend radius server software.
# Returns a ref to a hash of user names, where each user element is a hash
# of (attribute_name => value) pairs.  If a second argument is supplied
# ($who), it specifies the set of users to read in... all others in the
# file will be ignored.  If $who is a string, it is interpreted as a single
# user name; if it's a reference to an array, it's interpreted as a set
# of user names.
#
sub read_users
{
    my ($self, $users_file, $who) = @_;
    my (@fields, $user, %users, $attrib_set, $attrib_input, @who_we_want,
        %comments, $comment, $attr, $val);
    local (*USERS);

    $self->debug(2, "read_users - loading $users_file");
    open(USERS, $users_file)
     or carp("Error opening $users_file: $!"), return 0;
    seek USERS, 0, 0;

    @who_we_want = ref $who eq 'ARRAY' ? @$who : $who  if defined $who;

    while (<USERS>) {
        chomp;
        $self->debug(9, "read_users - in=``$_''");
        ($comment = '', next) unless $_;    # Skip if there's nothing useful,
        ($comment .= "$_\n", next) if /^#/; # or if it's just a comment.

        if (/(^[^#,\s]+)\s+(.+)/) {                         # first line
            $user = $1;
            $attrib_input = $2;
            $comments{$user} = $comment if $comment;
            tie(%{$users{$user}}, 'Tie::IxHash');
            $self->debug(5, "read_users - new record $user");
        }
        else {                                              # secondary line
            $attrib_input = $_;
        }

        next if @who_we_want and !grep($_ eq $user, @who_we_want);

        $attrib_set = _parse_attribs($attrib_input, $users_file);
        while (($attr, $val) = splice @$attrib_set, 0, 2) {
            push @{$users{$user}{$attr}}, $val;
        }
    }

    close USERS;

    return (\%users, \%comments);
}

# Return a ref to a hash of RADIUS users attributes.  We assume that
# comments have already been stripped from the input string.
#
sub _parse_attribs
{
    my ($raw, $file) = @_;
    my @attribs;

    $raw =~ s/^\s+//;                           # remove leading whitespace.

    while ($raw =~ s/^(\S+)\s*=\s*(("[^"]*")|[^",\s]+)\s*,?//) {
        if (defined $2) {
            push @attribs, $1, $2;
        }
        else {
            carp("Couldn't understand line $. in `$file'.");
            last;
        }

        $raw =~ s/^\s+//;
    }

    return \@attribs;
}


# Remove the specified users from $self.
sub remove
{
    my ($self, @users) = @_;

    foreach (@users) {
        delete $self->{'users'}{$_} and push @{$self->{removed}}, $_;
        delete $self->{comments}{$_};
    }

    my @removed = eval { local $^W = undef; @{$self->{removed}} };
    return $@ ? () : @removed;
}

sub removed
{
    my $self = shift;
    my @removed = eval { local $^W = undef; @{$self->{removed}} };
    return $@ ? () : @removed;
}


# Update user attributes in a RADIUS users file.  The arguments should be
# specified as a hash.  If the 'File' element is provided, that filename
# is used; otherwise, the last file read is used.  If the 'Who' element is
# provided, only the specified users are updated; otherwise, all known
# users are updated.
sub update
{
    my ($self, %args) = @_;
    my $file = exists $args{File} ? $args{File} : $self->{'files'}->[-1];
    my @who  = exists $args{Who}
               ? (ref $args{Who} eq 'ARRAY' ? @{$args{Who}} : $args{Who})
               : eval { local $^W = undef; keys %{$self->{users}} };
    my $temp = "$file.new";
    local (*IN, *TMP);
    my $oldsep = $/;
    local ($/) = '';        # we'll lose multiple blank lines this way

    carp('No users found'), return 0 unless (@who);
    _setup_files($file, \*IN, $temp, \*TMP) or return 0;
     
    my (%who, @recs, $name, $in);
    @who{@who} = (0) x @who;

    while (<IN>) {
        undef @recs;
        $in = $_;
        while (/^(
                                  (?: \#.*\n)*           # pre-record comment lines
                                  [^\#\s]+.*\n           # start of record
                                  (?:                    # rest of record:
                                      (?: \s+\S.*\n)|      #   attribute settings, or
                                      ((?: \#.*\n)         #   comments not followed by another
                                        (?! [^\#\s]))       #    start of record.
                                  )*
                            )/goxm) {
            push @recs, $1;
        }

        print(TMP $in), next unless @recs;
        foreach my $r (@recs) {
            ($name) = $r =~ /^([^#\s]+)/m;

            if (!$name) {
                print TMP $r;
            }
            elsif (exists $who{$name}) {
                $self->debug(6, "update - existing record $name");
                print TMP $self->format($name) if $who{$name} == 0;
                $who{$name}++;
            }
            elsif (!grep($name eq $_, $self->removed)) {
                print TMP $r;
            }
        }
        print TMP "\n";                 # since the input sep is "\n\n"
    }

    # Print out records for anyone we didn't find in $file.
    foreach (grep($who{$_} == 0, keys %who)) {
        $self->debug(6, "update - new record $_");
        print TMP $self->format($_), "\n";
    }

    $/ = $oldsep;

    # Close out input and output files (original and temporary, respectively)
    _cleanup_files($file, \*IN, $temp, \*TMP) or return 0;

    return 1;
}

# Organizational routine for update().  Sets up file handles for reading
# from the RADIUS users file.  The entire algorithm is like this:
#   open users file for read/write, creating if necessary
#   flock file exclusively
#   compare file opened to file locked, and re-open/lock while not equal
#   read from file, write to temp (handled in update())
#   close temp                    (handled by _cleanup_files)
#   rename temp to file
#   close file
sub _setup_files
{
    my ($file, $IN, $temp, $TMP) = @_;
    my $backup = "$file.bak";
    my $existed = -f $file;
    my ($dev1, $ino1, $dev2, $ino2);

    while (1) {
        open($IN, "+>>$file")
         or carp("Error opening $file: $!"), return 0;
        ($dev1, $ino1) = (stat $IN)[0,1];

        flock($IN, LOCK_EX)
         or carp("Error locking $file: $!"), close $IN, return 0;
        ($dev2, $ino2) = (stat $IN)[0,1];

        last if $dev1 == $dev2 and $ino1 == $ino2;
        close $IN;
    }

    seek $IN, 0, 0;
    open($TMP, ">$temp")
     or carp("Error creating $temp: $!"), close $IN, return 0;

    return 1;
}

# We should have new content in $TMP, and old content in $IN.
# So rename $TMP to $IN and close, releasing the flock on $IN established
# in _setup_files().
sub _cleanup_files
{
    my ($file, $IN, $temp, $TMP) = @_;

    close $TMP           or carp("Error closing $temp: $!"),           return 0;
    rename($temp, $file) or carp("Error renaming $file to $temp: $!"), return 0;
    close $IN            or carp("Error closing $file: $!"),           return 0;

    return 1;
}


# See if attribute is a checkable item (Lucent Radius fix -- Peter Bannis)
sub _is_check_item
{
    my ($self, $attribute) = @_;

    if ($attribute) {
        return grep(/^$attribute$/i, @{$self->{check_items}});
    }
    else {
        return 0;
    }
}


# Return a ref to a hash representing the attributes of the specified user.
#
sub user
{
    my ($self, $who) = @_;
    my %hash = eval { local $^W = undef; %{$self->{'users'}{$who}} };
    return $@ ? undef : \%hash;
}


# Return a ref to a list of users we have RADIUS info for, or a ref to an
# empty anonymous array if no users are defined.
#
sub usernames
{
    my $self = shift;
    my $users = eval { local $^W = undef; [ keys %{$self->{'users'}} ] };
    return $@ ? [] : $users;
}


# Return a ref to a hash of RADIUS users, indexed by user name, each
# containing a hash of attributes.  This is a ref to the actual data
# in the object, so the user information can be changed here.
#
sub users
{
    my $self = shift; return $self->{'users'};
}


# Return an array with the values of the given attribute for the named user.
#
sub values
{
    my ($self, $who, $attr) = @_;    
    my @vals = eval { local $^W = undef; @{$self->{'users'}{$who}{$attr}} };
    return $@ ? undef : @vals;
}

sub debug
{
    my ($self, $level, @msg) = @_;
    if ($level <= $self->{DEBUG}) {
        print STDERR join("\n", @msg), "\n";
    }
}


1;

__END__