svn commit: r264555 - in user/des/fbp/lib/FBP: . Model Schema/Result
Dag-Erling Smørgrav
des at FreeBSD.org
Wed Apr 16 21:09:18 UTC 2014
Author: des
Date: Wed Apr 16 21:09:17 2014
New Revision: 264555
URL: http://svnweb.freebsd.org/changeset/base/264555
Log:
Model.
Modified:
user/des/fbp/lib/FBP/Model/FBP.pm
user/des/fbp/lib/FBP/Schema.pm
user/des/fbp/lib/FBP/Schema/Result/Person.pm
user/des/fbp/lib/FBP/Schema/Result/Poll.pm
user/des/fbp/lib/FBP/Schema/Result/Question.pm
Modified: user/des/fbp/lib/FBP/Model/FBP.pm
==============================================================================
--- user/des/fbp/lib/FBP/Model/FBP.pm Wed Apr 16 21:01:44 2014 (r264554)
+++ user/des/fbp/lib/FBP/Model/FBP.pm Wed Apr 16 21:09:17 2014 (r264555)
@@ -29,7 +29,7 @@ Dag-Erling Smørgrav <des at freebsd.org>
=head1 LICENSE
-This library is free software, you can redistribute it and/or modify
+This library is free software. You can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
Modified: user/des/fbp/lib/FBP/Schema.pm
==============================================================================
--- user/des/fbp/lib/FBP/Schema.pm Wed Apr 16 21:01:44 2014 (r264554)
+++ user/des/fbp/lib/FBP/Schema.pm Wed Apr 16 21:09:17 2014 (r264555)
@@ -25,8 +25,6 @@ it under the same terms as Perl itself.
=cut
-__PACKAGE__->meta->make_immutable;
-
1;
# $FreeBSD$
Modified: user/des/fbp/lib/FBP/Schema/Result/Person.pm
==============================================================================
--- user/des/fbp/lib/FBP/Schema/Result/Person.pm Wed Apr 16 21:01:44 2014 (r264554)
+++ user/des/fbp/lib/FBP/Schema/Result/Person.pm Wed Apr 16 21:09:17 2014 (r264555)
@@ -173,6 +173,42 @@ __PACKAGE__->has_many(
# Created by DBIx::Class::Schema::Loader v0.07039 @ 2014-04-16 20:57:55
# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:19kISwX2Afx2WCQPAB8akw
+use Crypt::SaltedHash;
+
+=head2 set_password
+
+Set this person's password to the specified string.
+
+=cut
+
+sub set_password($$) {
+ my ($self, $password) = @_;
+
+ if ($password !~ m/^[[:print:]]{8,}$/a || $password !~ m/[0-9]/a ||
+ $password !~ m/[A-Z]/a || $password !~ m/[a-z]/a) {
+ die("Your password must be at least 8 characters long and contain" .
+ " at least one upper-case letter, one lower-case letter and" .
+ " one digit.\n");
+ }
+ my $csh = new Crypt::SaltedHash(algorithm => 'SHA-256');
+ $csh->add($password);
+ $self->set_column(password => $csh->generate());
+ $self->update()
+ if $self->in_storage();
+}
+
+=head2 check_password
+
+Verify that the specified string matches the user's password.
+
+=cut
+
+sub check_password($$) {
+ my ($self, $password) = @_;
+
+ return Crypt::SaltedHash->validate($self->password, $password);
+}
+
=head1 AUTHOR
Dag-Erling Smørgrav <des at freebsd.org>
Modified: user/des/fbp/lib/FBP/Schema/Result/Poll.pm
==============================================================================
--- user/des/fbp/lib/FBP/Schema/Result/Poll.pm Wed Apr 16 21:01:44 2014 (r264554)
+++ user/des/fbp/lib/FBP/Schema/Result/Poll.pm Wed Apr 16 21:09:17 2014 (r264555)
@@ -164,6 +164,57 @@ __PACKAGE__->has_many(
# Created by DBIx::Class::Schema::Loader v0.07039 @ 2014-04-16 20:57:55
# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:wB2dAarq+nsbZ5Ljfsil7Q
+use DateTime;
+
+=index2 active
+
+True if the poll was, is or will be active at the specified date and
+time.
+
+=cut
+
+sub active($;$) {
+ my ($self, $when) = @_;
+
+ $when //= DateTime->now();
+ return DateTime->compare($when, $self->starts) >= 0 &&
+ DateTime->compare($when, $self->ends) <= 0;
+}
+
+=head2 validate_answer
+
+Validates an answer to this poll and dies if it is not valid.
+
+=cut
+
+sub validate_answer($%) {
+ my ($self, %answers) = @_;
+
+ my %questions = map({ $_->id => $_ } $self->questions);
+ # Verify that all questions have received valid answers
+ foreach my $qid (keys %questions) {
+ if (!defined($answers{$qid})) {
+ die("Question $qid has not been answered.\n");
+ } elsif (ref($answers{$qid}) ne 'ARRAY') {
+ die("Internal error\n");
+ } else {
+ $questions{$qid}->validate_answer(@{$answers{$qid}});
+ }
+ }
+ # Verify that there are no answers without a matching question
+ if (!(keys(%answers) ~~ keys(%questions))) {
+ die("Too many answers\n");
+ }
+}
+
+sub commit_answer($$%) {
+ my ($self, $voter, %answers) = @_;
+
+ foreach my $question ($self->questions) {
+ $question->commit_answer($voter, @{$answers{$question->id}});
+ }
+}
+
=head1 AUTHOR
Dag-Erling Smørgrav <des at freebsd.org>
Modified: user/des/fbp/lib/FBP/Schema/Result/Question.pm
==============================================================================
--- user/des/fbp/lib/FBP/Schema/Result/Question.pm Wed Apr 16 21:01:44 2014 (r264554)
+++ user/des/fbp/lib/FBP/Schema/Result/Question.pm Wed Apr 16 21:09:17 2014 (r264555)
@@ -182,6 +182,80 @@ __PACKAGE__->has_many(
# Created by DBIx::Class::Schema::Loader v0.07039 @ 2014-04-16 20:57:55
# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:I/1G7NpDuffuLD3XnoJLpw
+=head2 validate_answer
+
+Validates an answer to this question and dies if it is not valid.
+
+=cut
+
+sub validate_answer($@) {
+ my ($self, @answer) = @_;
+
+ if (!@answer && $self->min_options > 0) {
+ die("You did not answer this question.\n");
+ } elsif (@answer < $self->min_options) {
+ die("You must select at least " . $self->min_options . " options\n");
+ } elsif (@answer > $self->max_options) {
+ if ($self->max_options == 1) {
+ die("You may only select one option.\n");
+ } else {
+ die("You may select at most " . $self->max_options . " options.");
+ }
+ }
+ foreach my $oid (@answer) {
+ $self->options->find($oid)
+ or die("Option $oid is not a valid answer to this question\n");
+ }
+}
+
+=head2 commit_answer
+
+Registers a voter's answer to this question.
+
+=cut
+
+sub commit_answer($$@) {
+ my ($self, $voter, @answer) = @_;
+
+ print STDERR "Question ", $self->id, " commit_answer\n";
+ $voter->votes->search({ question => $self->id })->delete();
+ foreach my $oid (@answer) {
+ $voter->votes->create({ question => $self->id, option => $oid });
+ }
+}
+
+=head2 prev
+
+Returns the previous question by rank.
+
+=cut
+
+sub prev($) {
+ my ($self) = @_;
+
+ my $questions = $self->poll->questions->
+ search({ rank => { '<', $self->rank } },
+ { order_by => { -desc => 'id' } })
+ or return undef;
+ return $questions->slice(0, 1)->first;
+}
+
+=head2 prev
+
+Returns the next question by rank.
+
+=cut
+
+sub next($) {
+ my ($self) = @_;
+
+ my $questions = $self->poll->questions->
+ search({ rank => { '>', $self->rank } },
+ { order_by => { -asc => 'id' } })
+ or return undef;
+ return $questions->slice(0, 1)->first;
+}
+
=head1 AUTHOR
Dag-Erling Smørgrav <des at freebsd.org>
More information about the svn-src-user
mailing list