#!/usr/bin/perl

# Copyright Massachusetts Institute of technology, 2000.
# Written by Eric Prud'hommeaux

# $Id: DBMUserRecords.pm,v 1.26 2005/02/07 09:08:25 eric Exp $

# Things that need to be done:
# 1: more docs

#####
# What It Does:

use strict;

package W3C::Annotations::DBMUserRecords;
use POSIX;

# W3C perl modules
use W3C::Util::Object;
use W3C::Util::Exception;

# package variables
use vars qw($REVISION $VERSION @ISA @EXPORT_OK);
$REVISION = '$Id: DBMUserRecords.pm,v 1.26 2005/02/07 09:08:25 eric Exp $ ';
@ISA = qw(W3C::Annotations::UserRecordSet);
use W3C::Annotations::UserRecord qw($RW_read $RW_write);

# overloadable defaults
use vars qw($DEFAULT_DB_TYPE);
$DEFAULT_DB_TYPE = 'NDBM_File';

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);

    if ($self->{-forceUser}) {
	return $self;
    }

    $self->{DB_TYPE} = $DEFAULT_DB_TYPE;
    if (my $type = $self->{-type}) {
	if ($type =~ m/^(db|DB_File)$/i) {
	    $self->{DB_TYPE} = 'DB_File';
	} elsif ($type =~ m/^(gdbm|GDBM_File)$/i) {
	    $self->{DB_TYPE} = 'GDBM_File';
	} elsif ($type =~ m/^(ndbm|NDBM_File)$/i) {
	    $self->{DB_TYPE} = 'NDBM_File';
	} elsif ($type =~ m/^(sdbm|SDBM_File)$/i) {
	    $self->{DB_TYPE} = 'SDBM_File';
	} else {
	    &throw(new W3C::Util::Exception(-message => "db type \"$type\" unknown"));
	}
    }
    require "$self->{DB_TYPE}.pm";

    return $self;
}

sub accessDB {
    my ($self, $file, $key, $value) = @_;
    my $ret = undef; # use in READ mode
    my %dbm;
    my $rwMode = (ref $value eq 'SCALAR' && $value == $RW_read) ? O_RDONLY : O_CREAT|O_RDWR;
    my $fileMode = 4+32+128+256;
    my $expire = time() + $self->{-busyWait};

    # For some reason, tie doesn't mind you tying to a non-existent
    # file. For practical reasons, we do.
    if (!$file) {
	# set $!
	tie(%dbm, $self->{DB_TYPE}, $file, $rwMode, $fileMode);
	my $ex = new W3C::Util::FileOperationException(-filename => $file, -operation => 'tie');
	untie(%dbm);
	# Throw the exception.
	$self->_throwException($ex);
    }

    # Try to tie to the file (may be blocked by another process
    # locking the same file).
    if (!tie(%dbm, $self->{DB_TYPE}, $file, $rwMode, $fileMode)) {
	do {
	    if ($! =~ m/temporar/) {
		if (time() > $expire) {
		    my $str = "Access to \"$file\" timed out after $self->{-busyWait} seconds. $!";
		    $self->_throwException(new W3C::Util::Exception(-message => $str));
		}
	    } else {
		$self->_throwException(new W3C::Util::FileOperationException(-filename => $file, -operation => 'tie'));
	    }
	} while (!tie(%dbm, $self->{DB_TYPE}, $file, $rwMode, $fileMode));
    }

    if (ref $value eq 'SCALAR') {
	if ($value == $RW_read) {
	    $ret = $dbm{$key};
	} else {
	    &throw(new W3C::Util::ProgramFlowException());
	}
    } else {
	if (ref $value eq 'CODE') {
	    $value = &$value($dbm{$key});
	}
	$ret = $value;
	if (defined $value) {
	    $dbm{$key} = $value;
	} else {
	    delete $dbm{$key};
	}
    }
    untie(%dbm);
    return $ret;
}

sub createGroupEntry {
    my ($self, $user, $group, $file) = @_;
    $self->accessDB($file, $user, $group);
}

1;

__END__

=head1 NAME

W3C::Annotations::DBMUserRecords - A specialization L<UserRecord.pm> for Berkely DBs

=head1 SYNOPSIS

  use W3C::Annotations::DBMUserRecords;

=head1 DESCRIPTION

This module implements the L<W3C::Annotations::UserRecord> interface to user accounts. It stores and retrieves user information from a Berkely database. This database is (usually) compatible with the Apache user database. This format, and the libraries that apache links to, are sometimes not synchronized with perl's DB libraries. In these cases, the less efficient L<W3C::Annotations::FlatUserRecord> should work.

This module is used with the W3C::Annotations CPAN module.

=head1 AUTHOR

Eric Prud'hommeaux <eric@w3.org>

=head1 SEE ALSO

L<W3C::Annotations::UserRecord>
L<W3C::Annotations::FlatUserRecords>

=cut

