[Cpan-forum-commit] rev 28 - in trunk: bin lib/CPAN lib/CPAN/Forum
t t/lib t/lib/CPAN t/lib/CPAN/Forum templates
svn at pti.co.il
svn at pti.co.il
Fri Jan 21 22:00:47 IST 2005
Author: gabor
Date: 2005-01-21 22:00:47 +0200 (Fri, 21 Jan 2005)
New Revision: 28
Added:
trunk/t/011-register.t
trunk/t/lib/CPAN/
trunk/t/lib/CPAN/Forum/
trunk/t/lib/CPAN/Forum/Test.pm
Modified:
trunk/bin/setup.pl
trunk/lib/CPAN/Forum.pm
trunk/lib/CPAN/Forum/DBI.pm
trunk/lib/CPAN/Forum/Users.pm
trunk/t/001-users.t
trunk/t/010-markup.t
trunk/templates/register.tmpl
Log:
more tests
Modified: trunk/bin/setup.pl
===================================================================
--- trunk/bin/setup.pl 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/bin/setup.pl 2005-01-21 20:00:47 UTC (rev 28)
@@ -43,7 +43,7 @@
my $from = delete $opt{from};
CPAN::Forum::Configure->create({field => 'from', value => $from});
-my $user = CPAN::Forum::Users->create({id => 1, %opt});
+my $user = CPAN::Forum::Users->create({id => 1, update_on_new_user => 1, %opt});
$user->password($opt{password});
$user->update;
CPAN::Forum::Usergroups->create({id => 1, name => "admin"});
Modified: trunk/lib/CPAN/Forum/DBI.pm
===================================================================
--- trunk/lib/CPAN/Forum/DBI.pm 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/lib/CPAN/Forum/DBI.pm 2005-01-21 20:00:47 UTC (rev 28)
@@ -52,6 +52,7 @@
email VARCHAR(255) UNIQUE,
fname VARCHAR(255),
lname VARCHAR(255),
+ update_on_new_user VARCHAR(1),
status INTEGER
);
Modified: trunk/lib/CPAN/Forum/Users.pm
===================================================================
--- trunk/lib/CPAN/Forum/Users.pm 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/lib/CPAN/Forum/Users.pm 2005-01-21 20:00:47 UTC (rev 28)
@@ -4,7 +4,8 @@
use Carp;
use base 'CPAN::Forum::DBI';
__PACKAGE__->table('users');
-__PACKAGE__->columns(All => qw/id username password email fname lname status/);
+__PACKAGE__->columns(All => qw/id username password email fname lname status
+ update_on_new_user/);
__PACKAGE__->has_many(posts => "CPAN::Forum::Posts");
Modified: trunk/lib/CPAN/Forum.pm
===================================================================
--- trunk/lib/CPAN/Forum.pm 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/lib/CPAN/Forum.pm 2005-01-21 20:00:47 UTC (rev 28)
@@ -2,7 +2,7 @@
use strict;
use warnings;
-our $VERSION = "0.09_04_dev";
+our $VERSION = "0.09_05";
use base "CGI::Application";
use CGI::Application::Plugin::Session;
@@ -11,6 +11,7 @@
use Fcntl qw(:flock);
use POSIX qw(strftime);
use Carp qw(cluck carp);
+use Mail::Sendmail qw(sendmail);
use CPAN::Forum::INC;
@@ -807,19 +808,19 @@
sub register_process {
my ($self) = @_;
my $q = $self->query;
+
if (not $q->param('nickname') or not $q->param('email')) {
return $self->register({"no_register_data" => 1});
}
- # TODO arbitrary nickname constraints
- if ($q->param('nickname') =~ /\W/ or
- length $q->param('nickname') > 10 or
- length $q->param('nickname') < 4
- ) { # TODO other nicknames ?
- return $self->register({"no_register_data" => 1});
+ # TODO arbitrary nickname constraint, allow other nicknames ?
+ if ($q->param('nickname') !~ /^[a-z0-9]{4,10}$/) {
+ return $self->register({"bad_nickname" => 1});
}
- if ($q->param('email') =~ /[^\w at .-]/) { # TODO fix the e-mail checking and the error message
- return $self->register({"no_register_data" => 1});
+
+ # TODO fix the e-mail checking and the error message
+ if ($q->param('email') !~ /^[a-z0-9_+ at .-]+$/) {
+ return $self->register({"bad_email" => 1});
}
my $user = eval {
@@ -832,6 +833,14 @@
return $self->register({"nickname_exists" => 1});
}
+ $self->send_password($user);
+ $self->notify_admin($user);
+ return $self->register({"done" => 1});
+}
+
+sub send_password {
+ my ($self, $user) = @_;
+
# TODO: put this text in a template
my $password = $user->password;
my $subject = "CPAN::Forum registration";
@@ -849,26 +858,31 @@
my $FROM = $field->value;
$self->log->debug("FROM field set to be $FROM");
- require Mail::Sendmail;
- import Mail::Sendmail qw(sendmail);
my %mail = (
- To => $q->param('email'),
+ To => $user->email,
From => $FROM,
Subject => $subject,
Message => $message,
);
sendmail(%mail);
+}
+sub notify_admin {
+ my ($self, $user) = @_;
+ my ($field) = CPAN::Forum::Configure->search({field => "from"});
+ my $FROM = $field->value;
+
# TODO: the admin should be able to configure if she wants to get messages on
- # every new user
+ # every new user (field update_on_new_user)
my $admin = CPAN::Forum::Users->retrieve(1);
- $mail{To} = $admin->email;
- $mail{Subject} = "New Forum user: " . $user->username;
- $mail{Message} = "";
+ my %mail = (
+ To => $admin->email,
+ From => $FROM,
+ Subject => "New Forum user: " . $user->username,
+ Message => "\nUsername: " . $user->username . "\n",
+ );
sendmail(%mail);
-
- return $self->register({"done" => 1});
}
sub pwreminder {
@@ -918,8 +932,6 @@
my $FROM = $field->value;
$self->log->debug("FROM field set to be $FROM");
- require Mail::Sendmail;
- import Mail::Sendmail qw(sendmail);
my %mail = (
To => $user->email,
From => $FROM,
@@ -1704,9 +1716,6 @@
my $self = shift;
my $post_id = shift;
- require Mail::Sendmail;
- import Mail::Sendmail qw(sendmail);
-
my $post = CPAN::Forum::Posts->retrieve($post_id);
# Subject => '[CPAN Forum] ' . $post->subject,
Modified: trunk/t/001-users.t
===================================================================
--- trunk/t/001-users.t 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/t/001-users.t 2005-01-21 20:00:47 UTC (rev 28)
@@ -1,32 +1,25 @@
#!/usr/bin/perl -w
use strict;
+use warnings;
-use Test::More tests => 4;
-use File::Copy qw(copy);
+use Test::More "no_plan";
-use lib ("blib", "t/lib");
+use lib qw(t/lib);
+use CPAN::Forum::Test;
-chdir "blib";
-copy "../t/CONFIG", ".";
+setup_database();
+ok(-e "blib/db/forum.db");
+ok(-e "blib/db/modules.txt");
-system "$^X bin/setup.pl";
-ok(-e "db/forum.db");
-system "$^X bin/populate.pl ../t/02packages.details.txt";
-
-ok(-e "db/modules.txt");
-chdir "..";
-use constant ROOT => "blib";
-
use CPAN::Forum::DBI;
-CPAN::Forum::DBI->myinit(ROOT . "/db/forum.db");
+CPAN::Forum::DBI->myinit("$ROOT/db/forum.db");
use CGI::Application::Test;
use CPAN::Forum;
-my $cat = CGI::Application::Test->new({root => ROOT, cookie => "cpanforum"});
+my $cat = CGI::Application::Test->new({root => $ROOT, cookie => "cpanforum"});
-
{
my $r = $cat->cgiapp('/', '', {});
like($r, qr{CPAN Forum});
Modified: trunk/t/010-markup.t
===================================================================
--- trunk/t/010-markup.t 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/t/010-markup.t 2005-01-21 20:00:47 UTC (rev 28)
@@ -22,7 +22,7 @@
'apple< sd' => qr(^ERR no_less_sign$),
'apple<' => qr(^ERR no_less_sign$),
'apple<code>sd' => qr(^ERR open_code_without_closing$),
- '1234567890' x 7 . "x" => qr(^ERR line_too_long$),
+# '1234567890' x 7 . "x" => qr(^ERR line_too_long$),
);
Added: trunk/t/011-register.t
===================================================================
--- trunk/t/011-register.t 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/t/011-register.t 2005-01-21 20:00:47 UTC (rev 28)
@@ -0,0 +1,118 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More "no_plan";
+
+
+use lib qw(t/lib);
+use CPAN::Forum::Test;
+
+setup_database();
+
+use CPAN::Forum::DBI;
+CPAN::Forum::DBI->myinit("$ROOT/db/forum.db");
+
+use CGI::Application::Test;
+use CPAN::Forum;
+my $cat = CGI::Application::Test->new({root => $ROOT, cookie => "cpanforum"});
+
+{
+ my $r = $cat->cgiapp('/', '', {});
+ like($r, qr{CPAN Forum});
+}
+
+{
+ my $r = $cat->cgiapp('/register', '', {});
+ like($r, qr{Registration Page});
+}
+
+{
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => '', email => ''});
+ like($r, qr{Registration Page});
+ like($r, qr{Need both nickname and password});
+}
+
+{
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => '', email => 'some at email'});
+ like($r, qr{Registration Page});
+ like($r, qr{Need both nickname and password});
+}
+
+{
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => 'xyz', email => ''});
+ like($r, qr{Registration Page});
+ like($r, qr{Need both nickname and password});
+}
+
+{
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => 'xyz', email => 'a at com'});
+ like($r, qr{Registration Page});
+ like($r, qr{Nickname must be lower case alphanumeric between 4-10 characters});
+}
+
+# reject bad usernames
+foreach my $username ("abc", "Abcde", "asd'er", "ab cd") {
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => $username, email => 'a at com'});
+ like($r, qr{Registration Page});
+ like($r, qr{Nickname must be lower case alphanumeric between 4-10 characters});
+}
+
+# reject bad usernames
+foreach my $email ("adb-?", "Abcde", "asd'er", "ab cd") {
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => "abcde", email => $email});
+ like($r, qr{Registration Page});
+ like($r, qr{Email must be a valid address writen in lower case letters});
+}
+
+my $pw;
+my $password;
+my $sendmail_count;
+# register user
+{
+ no warnings;
+ sub CPAN::Forum::sendmail {
+ my %mail = @_;
+ #use Data::Dumper;
+ #print STDERR Dumper \%mail;
+ #print STDERR
+ if ($mail{Message} =~ /your password is: (\w+)/) {
+ $password = $1;
+ }
+ $sendmail_count++;
+ }
+ use warnings;
+}
+# TODO: check if the call to submail contains the correct values
+{
+ $sendmail_count = 0;
+ $password = '';
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => $users[0]{username}, email => $users[0]{email}});
+ like($r, qr{Registration Page});
+ like($r, qr{Thank you for registering});
+ like($password, qr{\w{5}});
+
+ is($sendmail_count, 2);
+ $pw = $password;
+}
+
+# try to register the same user again and see it fails
+{
+ $sendmail_count = 0;
+ $password = '';
+ my $r = $cat->cgiapp('/', '', {rm => 'register_process', nickname => $users[0]{username}, email => $users[0]{email}});
+ like($r, qr{Registration Page});
+ like($r, qr{Nickname or e-mail already in use});
+ is($sendmail_count, 0);
+ is($password, "");
+}
+
+
+
+
+
+
+
+
+
Added: trunk/t/lib/CPAN/Forum/Test.pm
===================================================================
--- trunk/t/lib/CPAN/Forum/Test.pm 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/t/lib/CPAN/Forum/Test.pm 2005-01-21 20:00:47 UTC (rev 28)
@@ -0,0 +1,33 @@
+package CPAN::Forum::Test;
+
+use File::Copy qw(copy);
+
+require Exporter;
+use vars qw(@ISA @EXPORT);
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(@users $ROOT setup_database);
+
+our $ROOT = "blib";
+
+our @users = (
+ {
+ username => 'abcder',
+ email => 'qqrq at banana.com',
+ },
+);
+
+sub setup_database {
+ chdir "blib";
+ copy "../t/CONFIG", ".";
+
+ system "$^X bin/setup.pl";
+ system "$^X bin/populate.pl ../t/02packages.details.txt";
+
+ chdir "..";
+}
+
+
+
+1;
+
Modified: trunk/templates/register.tmpl
===================================================================
--- trunk/templates/register.tmpl 2005-01-17 13:33:19 UTC (rev 27)
+++ trunk/templates/register.tmpl 2005-01-21 20:00:47 UTC (rev 28)
@@ -9,6 +9,8 @@
<TMPL_ELSE>
<div class="error">
+<TMPL_IF bad_nickname>Nickname must be lower case alphanumeric between 4-10 characters.<br /></TMPL_IF>
+<TMPL_IF bad_email>Email must be a valid address writen in lower case letters<br /></TMPL_IF>
<TMPL_IF no_register_data>Need both nickname and password<br /></TMPL_IF>
<TMPL_IF nickname_exists>Nickname or e-mail already in use<br /></TMPL_IF>
</div>
More information about the Cpan-forum-commit
mailing list