#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

use strict;
require Exporter;
require AutoLoader;

use Manip;
use W3C::Database::DBIInterface;
use W3C::Rnodes::AclDB;

$W3C::Rnodes::W3CAclIds::REVISION = '$Id: W3CAclIds.pm,v 1.11 1999/12/14 13:14:41 eric Exp $ ';

package W3C::Rnodes::W3CAclIds;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @TODO $ACCESS_CHACL $ACCESS_RACL);
@ISA = qw(W3C::Database::DBIInterface  Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.96;
$DSLI = 'adpO';
@TODO = ();

package W3C::Rnodes::ParameterDescription;

# W3C::Rnodes::ParameterDescription keywords:
$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAME = '$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAME'; # valid ids.value entry
$W3C::Rnodes::ParameterDescription::INPUT_TYPE_IP = '$W3C::Rnodes::ParameterDescription::INPUT_TYPE_IP'; # valid ids.value entry
$W3C::Rnodes::ParameterDescription::INPUT_TYPE_DATE = '$W3C::Rnodes::ParameterDescription::INPUT_TYPE_DATE'; # valid date
$W3C::Rnodes::ParameterDescription::INPUT_TYPE_STRING = '$W3C::Rnodes::ParameterDescription::INPUT_TYPE_STRING'; # any string
$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAMELIST = '$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAMELIST'; # ','-sepparated list of NAMEs
$W3C::Rnodes::ParameterDescription::INPUT_TYPE_HASHABLE = '$W3C::Rnodes::ParameterDescription::INPUT_TYPE_HASHABLE'; # STRING - may be enclosed by 'hash()'

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);
    ($self->{NAMES}, $self->{OPTIONS}, $self->{REQUIRED}, $self->{DEFAULT}, $self->{HELP}, 
     $self->{TABLE}, $self->{FIELD}, $self->{RESOLVE}) = @_;
    return $self;
}

sub matchesDirective {
    my ($self, $lookFor) = @_;
    foreach my $name (@{$self->{NAMES}}) {
	return $self->{NAMES}->[0] if ($name eq $lookFor); # use preffered name
    }
    return undef;
}

sub assume {
    my ($self, $value) = @_;
    my ($found, $parsed);
    foreach my $option (@{$self->{OPTIONS}}) {
	if (!ref $option) {
	    ($value eq $option) && ($parsed = $value) && ($found = $option) && (last);
	} elsif (ref $option eq 'SCALAR') {
	    if ($option == \$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAME) {
		if ($value =~ m/\A\w+\Z/) {
		    $parsed = $value;
		    $found = $option;
		    last;
		} else {
		    die "parameter \"$value\" not compatible with $$option";
		}
	    } elsif ($option == \$W3C::Rnodes::ParameterDescription::INPUT_TYPE_IP) {
		if ($value =~ m/\A[\d\.\*]+\Z/) {
		    $parsed = $value;
		    $found = $option;
		    last;
		} else {
		    die "parameter \"$value\" not compatible with $$option";
		}
	    } elsif ($option == \$W3C::Rnodes::ParameterDescription::INPUT_TYPE_DATE) {
		if ($value eq 'never') {
		    $parsed = 0;
		    $found = $option;
		    last;
#		} elsif ($value eq 'now') { leave for ParseDate
#		    $parsed = ;
#		    $found = $option;
#		    last;
		} elsif (my $date = &Date::Manip::ParseDateString($value)) {
		    $parsed = &Date::Manip::UnixDate($date, "%q");
		    $found = $option;
		    last;
		} else {
		    die "can't parse date format \"$value\"";
		}
	    } elsif ($option == \$W3C::Rnodes::ParameterDescription::INPUT_TYPE_STRING) {
		$parsed = $value;
		$found = $option;
		last;
	    } elsif ($option == \$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAMELIST) {
		my @list = split(/(\w+)\s*,\s*/, $value);
		@list = grep {$_ ne ''} @list;
		$parsed = \@list;
		$found = $option;
		last;
	    } elsif ($option == \$W3C::Rnodes::ParameterDescription::INPUT_TYPE_HASHABLE) {
		if ($value =~ m/\G hash\( \" ([^\"]*) \" \) \s* /gcxsi || 
		    $value =~ m/\G hash\( \' ([^\']*) \' \) \s* /gcxsi || 
		    $value =~ m/\G hash\(    ([^\s]*)    \) \s* /gcxsi) {
		    $parsed = crypt($1, chr(rand(0x7f - 0x3b)+0x3b).chr(rand(0x7f - 0x3b)+0x3b));
		    $found = $option;
		    last;
		} else {
		    $parsed = $value;
		    $found = $option;
		    last;
		}
	    } else {
		die "unknown parameter keyword \"$option\" for \"".$self->{NAMES}->[0]."\".";
	    }
	}
    }
    die "no parameter match for \"$value\"." if (!$found);
    return ($found, $parsed);
}

sub preferredName {
    my ($self) = @_;
    return $self->{NAMES}->[0];
}

sub fieldInfo {
    my ($self) = @_;
    return ($self->{TABLE}, $self->{FIELD}, $self->{RESOLVE});
}

sub required {
    my ($self) = @_;
    return $self->{REQUIRED};
}

sub help {
    my ($self) = @_;
    return $self->{NAMES}->[0].' - '.$self->{HELP};
}

sub default {
    my ($self) = @_;
    return $self->{DEFAULT};
}

package W3C::Rnodes::W3CAclId;
$W3C::Rnodes::W3CAclId::INPUT_NAME = new W3C::Rnodes::ParameterDescription(['name'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAME], 
						 1, undef, 'canonical name of this identity', 'ids', 'value');
$W3C::Rnodes::W3CAclId::INPUT_IP = new W3C::Rnodes::ParameterDescription(['ip'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_IP], 
					       1, undef, 'ip address', 'ids', 'value');
$W3C::Rnodes::W3CAclId::INPUT_EXPIRE = new W3C::Rnodes::ParameterDescription(['expire', 'expires'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_DATE]
						   , 0, 'never', 'identity expiration date', 'ids', 'expire');
$W3C::Rnodes::W3CAclId::INPUT_GROUPS = new W3C::Rnodes::ParameterDescription(['groups','membership'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_NAMELIST], 
						   1, undef, 'groups this user is a member of', 'hierarchy2', 'super', 
						   \ &resolveGroups);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);
    $self->{TYPE} = shift;
    $self->{PARMDESCS} = shift;
    $self->slurp(@_);
    return $self;
}

sub slurp {
    my $self = shift;
    my $initializer = $_[0];
    if (ref $initializer eq 'HASH') {
	foreach my $name (keys %$initializer) {
	    $self->put($name, $initializer->{$name});
	}
    } elsif (ref $initializer eq 'ARRAY') {
	my @inputs = @{$self->{PARMDESCS}};
	foreach my $value (@$initializer) {
	    my $input = shift @inputs;
	    $self->put($input, $value);
	}
#    } elsif (ref $initializer eq 'SCALAR') {
#	    my @lines = split("\n", $$initializer);
#	    $self->read(\@lines);
    } else {
	my @inputs = @{$self->{PARMDESCS}};
	foreach my $value (@_) {
	    my $input = shift @inputs;
	    $self->put($input, $value);
	}
    }
    my @required = $self->checkRequired(1); # list of unfilled required fields
    return if ($#required < $[);
    my $exception = (ref $self)." requires:\n";
    foreach my $required (@required) {
	$exception .= '    '.$required->help."\n";
    }
    die $exception;
}

sub put {
    my ($self, $parm, $input) = @_;
    my $type = ref $parm;
    if ($type eq 'W3C::Rnodes::ParameterDescription') {
	my ($option, $value) = $parm->assume($input);
	die $parm->message if (!defined $option);
	$self->{VALUES}{$parm} = $value;
	$self->{INPUT}{$parm} = $input;
	$self->{PARAMETERS}{$parm->preferredName} = $parm;
    } elsif ($type eq '') {
	foreach my $parmDesc (@{$self->{PARMDESCS}}) {
	    if ($parmDesc->matchesDirective($parm)) {
		my ($option, $value) = $parmDesc->assume($input);
		die $parm->message if (!defined $option);
		$self->{VALUES}{$parmDesc} = $value;
		$self->{INPUT}{$parmDesc} = $input;
		$self->{PARAMETERS}{$parmDesc->preferredName} = $parmDesc;
		last;
	    }
	}
    } else {
	die "W3C::Rnodes::W3CAclId can't handle parameters of type \"$type\".";
    }
}

sub get {
    my ($self, $lookFor) = @_;
    my $ret;

    if (!ref $lookFor) {
	# look for parm by preferred name
	$lookFor = $self->{PARAMETERS}{$lookFor};
	return undef if !defined $lookFor;
    }
    if (ref $lookFor eq 'W3C::Rnodes::ParameterDescription') {
	# look for value by parm
	$ret = $self->{VALUES}{$lookFor};
    } else {
	die "don't know how to look up a value by \"$lookFor\".";
    }

#    # make sure return a copy, not a reference
#    return @$ret if (ref $ret eq 'ARRAY');
#    return %$ret if (ref $ret eq 'HASH');
    return $ret;
}

sub NUKEgetParameter {
    my ($self, $preferredName) = @_;
    return $self->{PARAMETERS}{$preferredName};
}

sub setId {
    my ($self, $id) = @_;
    $self->{ID} = $id;
}

sub getId {
    my ($self) = @_;
    return $self->{ID};
}

sub getType {
    my ($self) = @_;
    return $self->{TYPE};
}

sub checkRequired {
    my ($self, $justUnfilled) = @_;
    my @required;
    foreach my $parmDesc (@{$self->{PARMDESCS}}) {
	if ($parmDesc->required) {
	    if ($justUnfilled) {
		push (@required, $parmDesc) if (!exists $self->{VALUES}{$parmDesc});
	    } else {
		push (@required, $parmDesc);
	    }

	}
    }
    return @required;
}

sub render {
    my ($self, $prefix, $separator, $term) = @_;
    my $ret = '';
    foreach my $parmDesc (@{$self->{PARMDESCS}}) {
	my $name = $parmDesc->preferredName;
	my $value = (exists $self->{INPUT}{$parmDesc}) ? $self->{INPUT}{$parmDesc} : $parmDesc->default;
	$value = join(',', @$value) if (ref $value eq 'ARRAY');
	$ret .= $prefix.$name.$separator.$value.$term;
    }
    return $ret;
}

sub renderHelp {
    my ($proto, $parmDescs, $prefix, $separator, $term) = @_;
    my $ret = '';
    foreach my $parmDesc (@$parmDescs) {
	my $name = $parmDesc->preferredName;
	my $default = (defined $parmDesc->default) ? $separator.'['.$parmDesc->default.']' : '';
	my $help = $parmDesc->help;
	$ret .= $prefix.$name.$default.$separator.$help.$term;
    }
    return $ret;
}

# return ref ? maybe a copy would be better

sub parametersNUKE {
    my ($self) = @_;
    return $self->{PARAMETERS};
}

sub tables {
    my ($self, $lookerUpper) = @_;
    my %byTable;
    foreach my $word (keys %{$self->{PARAMETERS}}) {
	my $parm = $self->{PARAMETERS}{$word};
	my ($table, $field, $lateResolve) = $parm->fieldInfo;
#	$byTable{$table}{$field} = $self->getAndResolve($parm, $lookerUpper);
	my $value = $self->get($parm);
	$byTable{$table}{$field} = $lateResolve ? $self->$lateResolve($parm, $value, $lookerUpper) : $value;
    }
    return %byTable;
}

sub getAndResolveNUKE {
    my ($self, $parm, $lookerUpper) = @_;
    my $value = $self->get($parm);
    my ($table, $field, $lateResolve) = $parm->fieldInfo;
    return $lateResolve ? $self->$lateResolve($parm, $value, $lookerUpper) : $value;
}

%W3C::Rnodes::W3CAclId::PRELOADS = ('ids' => {'type' => \ $W3C::Rnodes::W3CAclId::PRELOAD_TYPE},
		       'userDetails'  => {'id' => \ $W3C::Rnodes::W3CAclId::PRELOAD_ID},
		       'hierarchy2'  => {'type' => \ $W3C::Rnodes::W3CAclId::PRELOAD_TYPE,
					 'id' => \ $W3C::Rnodes::W3CAclId::PRELOAD_ID});

sub fields {
    my ($self, $byTable, $table) = @_;
    my %ret;
    # @@@ pick up from PRELOADS table - hardcode for now - in a hurry
    if ($table eq 'ids') {
	$ret{'type'} = $self->{TYPE};
    } elsif ($table eq 'userDetails') {
	$ret{'id'} = $self->{ID};
    } elsif ($table eq 'hierarchy2') {
	$ret{'sub'} = $self->{ID};
	$ret{'type'} = $self->{TYPE};
    }
    map { $ret{$_} = $$byTable{$table}{$_}; } keys %{$$byTable{$table}};
    return \%ret;
}

sub resolveGroups {
    my ($self, $parm, $value, $lookerUpper) = @_;
    my @ret;
    foreach my $name (@$value) {
	push (@ret, $lookerUpper->getGroupId($name));
    }
    return \@ret;
}

package W3C::Rnodes::W3CAclGroup;
@W3C::Rnodes::W3CAclGroup::ISA = ('W3C::Rnodes::W3CAclId');

@W3C::Rnodes::W3CAclGroup::INPUTS = ($W3C::Rnodes::W3CAclId::INPUT_NAME, $W3C::Rnodes::W3CAclId::INPUT_EXPIRE);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new('G', \@W3C::Rnodes::W3CAclGroup::INPUTS, @_);
    bless ($self, $class);
}

sub renderHelp {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    return $class->SUPER::renderHelp(\@W3C::Rnodes::W3CAclGroup::INPUTS, @_);
}

package W3C::Rnodes::W3CAclUser;
@W3C::Rnodes::W3CAclUser::ISA = ('W3C::Rnodes::W3CAclId');

$W3C::Rnodes::W3CAclUser::INPUT_EMAIL = new W3C::Rnodes::ParameterDescription(['email'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_STRING], 
						    1, undef, 'user\'s email address', 'userDetails', 'email');
$W3C::Rnodes::W3CAclUser::INPUT_GIVEN = new W3C::Rnodes::ParameterDescription(['given','first','firstName'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_STRING], 
						    1, undef, 'user\'s first (given) address', 'userDetails', 'given');
$W3C::Rnodes::W3CAclUser::INPUT_FAMILY = new W3C::Rnodes::ParameterDescription(['family','last','lastName'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_STRING],
						     1, undef, 'user\'s last (family) name', 'userDetails', 'family');
$W3C::Rnodes::W3CAclUser::INPUT_PASSWORD = new W3C::Rnodes::ParameterDescription(['password','passwd'], [\$W3C::Rnodes::ParameterDescription::INPUT_TYPE_HASHABLE], 
						       1, undef,'hash of password or \'hash(password)\'', 'userDetails', 'passwd');
$W3C::Rnodes::W3CAclUser::INPUT_STATUS = new W3C::Rnodes::ParameterDescription(['status'], ['none',''], 
						     1, undef, 'user\'s status (\'none\' for now)', 'userDetails', 'status');
@W3C::Rnodes::W3CAclUser::INPUTS = ($W3C::Rnodes::W3CAclId::INPUT_NAME, $W3C::Rnodes::W3CAclId::INPUT_EXPIRE, $W3C::Rnodes::W3CAclUser::INPUT_EMAIL, $W3C::Rnodes::W3CAclUser::INPUT_GIVEN, 
		       $W3C::Rnodes::W3CAclUser::INPUT_FAMILY, $W3C::Rnodes::W3CAclUser::INPUT_PASSWORD, $W3C::Rnodes::W3CAclUser::INPUT_STATUS, 
		       $W3C::Rnodes::W3CAclId::INPUT_GROUPS);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new('U', \@W3C::Rnodes::W3CAclUser::INPUTS, @_);
    bless ($self, $class);
}

sub renderHelp {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    return $class->SUPER::renderHelp(\@W3C::Rnodes::W3CAclUser::INPUTS, @_);
}

package W3C::Rnodes::W3CAclIp;
@W3C::Rnodes::W3CAclIp::ISA = ('W3C::Rnodes::W3CAclId');

@W3C::Rnodes::W3CAclIp::INPUTS = ($W3C::Rnodes::W3CAclId::INPUT_IP, $W3C::Rnodes::W3CAclId::INPUT_EXPIRE, $W3C::Rnodes::W3CAclId::INPUT_GROUPS);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new('I', \@W3C::Rnodes::W3CAclIp::INPUTS, @_);
    bless ($self, $class);
}

sub renderHelp {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    return $class->SUPER::renderHelp(\@W3C::Rnodes::W3CAclIp::INPUTS, @_);
}

# finish up the W3C::Rnodes::W3CAclId package with all the types listed above
package W3C::Rnodes::W3CAclIds;

*W3CAclIds::OBJECT_USER = \ 'W3C::Rnodes::W3CAclUser';
*W3CAclIds::OBJECT_GROUP = \ 'W3C::Rnodes::W3CAclGroup';
*W3CAclIds::OBJECT_IP = \ 'W3C::Rnodes::W3CAclIp';
%W3CAclIds::STR_TO_OBJECT = ('user' => $W3CAclIds::OBJECT_USER, 
			     'group' => $W3CAclIds::OBJECT_GROUP, 
			     'ip' => $W3CAclIds::OBJECT_IP);
%W3CAclIds::OBJECT_TO_STR = ($W3CAclIds::OBJECT_USER => 'user', 
			     $W3CAclIds::OBJECT_GROUP => 'group', 
			     $W3CAclIds::OBJECT_IP => 'ip');

1

__END__

=head1 NAME

W3C::Rnodes::W3CAclIds - 

=head1 SYNOPSIS

@@@

=head1 DESCRIPTION

This module is part of the W3C::Rnodes CPAN module.

=head1 AUTHOR

Eric Prud'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut
