package Gtk2::Ex::FormFactory::Rules;

use strict;
use Carp;

use File::Basename;

my %RULES = (
    "empty"			=> sub { $_[0] eq ''			},
    "not-empty"			=> sub { $_[0] ne ''			},

    "alphanumeric"		=> sub { $_[0] =~ /^\w+$/		},
    "identifier"		=> sub { $_[0] =~ /^[a-z_]\w*$/i	},
    "no-whitespace"		=> sub { $_[0] !~ /\s/			},

    "integer"			=> sub { $_[0] =~ /^[+-]?\d+$/		},
    "positive-integer"		=> sub { $_[0] =~ /^[+]?\d+$/ 		},
    "negative-integer"		=> sub { $_[0] =~ /^-\d+$/		},

    "float"			=> sub { $_[0] =~ /^[+-]?\d+(\.\d+)?$/	},
    "positive-float"		=> sub { $_[0] =~ /^[+]?\d+(\.\d+)?$/	},
    "negative-float"		=> sub { $_[0] =~ /^-\d+(\.\d+)?$/	},

    "odd"			=> sub {   $_[0] % 2			},
    "even"			=> sub { !($_[0] % 2)			},
    
    "file-executable"		=> sub { (-f $_[0] && -x $_[0])		},
    "file-writable"		=> sub { (-f $_[0] && -w $_[0])		},
    "file-readable"		=> sub { (-f $_[0] && -r $_[0])		},
    
    "dir-writable"		=> sub { (-d $_[0] && -w $_[0])		},
    "dir-readable"		=> sub { (-d $_[0] && -r $_[0])		},

    "parent-dir-writable"	=> sub { -w dirname($_[0]) 		},
    "parent-dir-readable"	=> sub { -r dirname($_[0])		},
);

my %RULES_MESSAGES = (
    "empty"			=> "{field} is not empty.",
    "not-empty"			=> "{field} is empty.",

    "alphanumeric"		=> "{field} is not alphanumeric.",
    "identifier"		=> "{field} is no identifier.",
    "no-whitespace"		=> "{field} contains whitespace.",

    "integer"			=> "{field} is no integer.",
    "positive-integer"		=> "{field} is no positive integer.",
    "negative-integer"		=> "{field} is no negative integer.",

    "float"			=> "{field} is no float.",
    "positive-float"		=> "{field} is no positive float.",
    "negative-float"		=> "{field} is no negativ float.",

    "odd"			=> "{field} is not odd.",
    "even"			=> "{field} is not even.",
    
    "file-executable"		=> "{field} is no file and/or not executable.",
    "file-writable"		=> "{field} is no file and/or not writable.",
    "file-readable"		=> "{field} is no file and/or not readable.",
    
    "dir-writable"		=> "{field} is no directory and/or not writable.",
    "dir-readable"		=> "{field} is no directory and/or not readable.",

    "parent-dir-writable"	=> "{field} has no writable parent directory.",
    "parent-dir-readable"	=> "{field} has no readable parent directory.",
);

my $MESSAGE_FORMAT = "Data entered is invalid.\n\n[MESSAGES]\nOld value restored.";

sub get_rules			{ shift->{rules}			}
sub get_rules_messages		{ shift->{rules_messages}		}
sub get_message_format		{ shift->{message_format}		}

sub set_rules			{ shift->{rules}		= $_[1]	}
sub set_rules_messages		{ shift->{rules_messages}	= $_[1]	}
sub set_message_format		{ shift->{message_format}	= $_[1]	}

sub new {
	my $class = shift;
	my %par = @_;
	my  ($rules, $rules_messages, $message_format) =
	@par{'rules','rules_messages','message_format'};

	$rules 		||= {};
	$rules_messages	||= {};
	$message_format ||= $MESSAGE_FORMAT;

	my $self = bless {
		rules		=> $rules,
		rules_messages	=> $rules_messages,
		message_format	=> $message_format,
	}, $class;

	return $self;
}

sub check {
	my $self = shift;
	my ($rules, $field, $value) = @_;

	$rules = [ $rules ] unless ref $rules eq 'ARRAY';

	my $messages;
	foreach my $rule ( @{$rules} ) {
		if ( ref $rule eq 'CODE' ) {
			my $msg = &$rule($value);
			$messages .= "$msg\n" if $msg;
			next;
		}
		
		my $coderef = $self->get_rules->{$rule} || $RULES{$rule};
		
		if ( $coderef ) {
			if ( ! &$coderef($value) ) {
				my $message =
					$self->get_rules_messages->{$rule} ||
					$RULES_MESSAGES{$rule};
				warn "Message of rule '$rule' not defined"
					if $message eq '';
				$message ||= "{field} has an unknown error";
				$messages .= "$message\n";
			}
		} else {
			warn "Unknown rule '$rule'. Verification skipped.";
		}
	}

	if ( $messages ) {
		my $format = $self->get_message_format;
		$messages =~ s/\{field\}/$field/g;
		$format =~ s/\[MESSAGES\]/$messages/;
		$messages = $format;
	}

	return $messages;
}

1;


__END__

=head1 NAME

Gtk2::Ex::FormFactory::Rules - Rule checking in a FormFactory framework

=head1 SYNOPSIS

  Gtk2::Ex::FormFactory::Rules->new (
    rules          => Hashref of rules and their implemenation CODEREF's,
    rules_messages => Hashref of the rules' error messages,
    message_format => Format of the "Invalid rules" message thrown
    		      on the GUI,
  );

=head1 DESCRIPTION

This class implements rule checking in a Gtk2::Ex::FormFactory framework.
Each widget can have on or more rules which are checked against the
widget's value when the user changes it. This way you can prevent the
user from entering illegal data at a high level.

Once the user entered illegal data, the old (legal) value is restored
and a corresponding error dialog pops up.

=head1 OBJECT HIERARCHY

  Gtk2::Ex::FormFactory::Rules

=head1 ATTRIBUTES

Attributes are handled through the common get_ATTR(), set_ATTR()
style accessors.

=over 4

=item B<rules> = HASHREF [optional]

This is a hash of user specified rules. A rule has a name
(the hash key) and a CODREF (the hash value) which implements the
rule. The CODEREF has the following prototype:

  $error = &$CODEREF ($value)

If B<$value> doesn't match the rule, B<$error> is the corresponding
error message. B<$error> is undef, if B<$value> is Ok.

=item B<rules_messages> = HASHREF [optional]

This is a hash of the error messages of the user specified rules.
A message should read read as follows:

  {field} is an odd value.

When presented to the user, the {field} place holder is replaced
with the label of the widget in question.

=item B<message_format> = SCALAR [optional]

This is the format string for the error message which is displayed
to the user. The default is:

  Data entered is invalid.\n\n[MESSAGES]\nOld value restored.

where B<[MESSAGES]> is replaced with the actual list of error
messages.

=back

=head1 BUILTIN RULES

This is a verbatim snapshot of the builtin rules and rules_messages
hashes. Please take a look at Gtk2::Ex::FormFactory::Rules' source code
for a recent list of builtin rules:

  my %RULES = (
    "empty"                     => sub { $_[0] eq ''                    },
    "not-empty"                 => sub { $_[0] ne ''                    },

    "alphanumeric"              => sub { $_[0] =~ /^\w+$/               },
    "identifier"                => sub { $_[0] =~ /^[a-z_]\w*$/i        },
    "no-whitespace"             => sub { $_[0] !~ /\s/                  },

    "integer"                   => sub { $_[0] =~ /^[+-]?\d+$/          },
    "positive-integer"          => sub { $_[0] =~ /^[+]?\d+$/           },
    "negative-integer"          => sub { $_[0] =~ /^-\d+$/              },

    "float"                     => sub { $_[0] =~ /^[+-]?\d+(\.\d+)?$/  },
    "positive-float"            => sub { $_[0] =~ /^[+]?\d+(\.\d+)?$/   },
    "negative-float"            => sub { $_[0] =~ /^-\d+(\.\d+)?$/      },

    "odd"                       => sub {   $_[0] % 2                    },
    "even"                      => sub { !($_[0] % 2)                   },
    
    "file-executable"           => sub { (-f $_[0] && -x $_[0])         },
    "file-writable"             => sub { (-f $_[0] && -w $_[0])         },
    "file-readable"             => sub { (-f $_[0] && -r $_[0])         },
    
    "dir-writable"              => sub { (-d $_[0] && -w $_[0])         },
    "dir-readable"              => sub { (-d $_[0] && -r $_[0])         },

    "parent-dir-writable"       => sub { -w dirname($_[0])              },
    "parent-dir-readable"       => sub { -r dirname($_[0])              },
  );

  my %RULES_MESSAGES = (
    "empty"                     => "{field} is not empty.",
    "not-empty"                 => "{field} is empty.",

    "alphanumeric"              => "{field} is not alphanumeric.",
    "identifier"                => "{field} is no identifier.",
    "no-whitespace"             => "{field} contains whitespace.",

    "integer"                   => "{field} is no integer.",
    "positive-integer"          => "{field} is no positive integer.",
    "negative-integer"          => "{field} is no negative integer.",

    "float"                     => "{field} is no float.",
    "positive-float"            => "{field} is no positive float.",
    "negative-float"            => "{field} is no negativ float.",

    "odd"                       => "{field} is not odd.",
    "even"                      => "{field} is not even.",
    
    "file-executable"           => "{field} is no file and/or not executable.",
    "file-writable"             => "{field} is no file and/or not writable.",
    "file-readable"             => "{field} is no file and/or not readable.",
    
    "dir-writable"              => "{field} is no directory and/or not writable.",
    "dir-readable"              => "{field} is no directory and/or not readable.",

    "parent-dir-writable"       => "{field} has no writable parent directory.",
    "parent-dir-readable"       => "{field} has no readable parent directory.",
  );

=head1 AUTHORS

 Jörn Reder <joern at zyn dot de>

=head1 COPYRIGHT AND LICENSE

Copyright 2004 by Jörn Reder.

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Library General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307
USA.

=cut
