r1408 - in packages/libuser-simple-perl/trunk: . debian lib/User
lib/User/Simple t
Gunnar Wolf
gwolf at costa.debian.org
Thu Oct 6 19:08:46 UTC 2005
Author: gwolf
Date: 2005-10-06 19:08:45 +0000 (Thu, 06 Oct 2005)
New Revision: 1408
Modified:
packages/libuser-simple-perl/trunk/Changes
packages/libuser-simple-perl/trunk/META.yml
packages/libuser-simple-perl/trunk/debian/changelog
packages/libuser-simple-perl/trunk/lib/User/Simple.pm
packages/libuser-simple-perl/trunk/lib/User/Simple/Admin.pm
packages/libuser-simple-perl/trunk/t/User-Simple.t
Log:
New upstream version 1.3 (becomes 1.30 - Silly me for using . as a decimal dot :( )
Modified: packages/libuser-simple-perl/trunk/Changes
===================================================================
--- packages/libuser-simple-perl/trunk/Changes 2005-10-06 19:06:15 UTC (rev 1407)
+++ packages/libuser-simple-perl/trunk/Changes 2005-10-06 19:08:45 UTC (rev 1408)
@@ -1,5 +1,11 @@
Revision history for Perl extension User::Simple.
+1.3 Thu Oct 6 13:21:56 CDT 2005
+ - By popular demand, User::Simple (not necessarily from within
+ ::Admin) can modify the user data - Not only that, but also
+ a subtle distinction was added: fields called beginning with
+ adm_ are not modifiable by it.
+
1.23 Sun Oct 2 11:45:35 CDT 2005
- Bugfix: Some DBDs return uppercase fields, some
lowercase... Try to handle them all correctly (or at least,
Modified: packages/libuser-simple-perl/trunk/META.yml
===================================================================
--- packages/libuser-simple-perl/trunk/META.yml 2005-10-06 19:06:15 UTC (rev 1407)
+++ packages/libuser-simple-perl/trunk/META.yml 2005-10-06 19:08:45 UTC (rev 1408)
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: User-Simple
-version: 1.23
+version: 1.3
version_from: lib/User/Simple.pm
installdirs: site
requires:
Modified: packages/libuser-simple-perl/trunk/debian/changelog
===================================================================
--- packages/libuser-simple-perl/trunk/debian/changelog 2005-10-06 19:06:15 UTC (rev 1407)
+++ packages/libuser-simple-perl/trunk/debian/changelog 2005-10-06 19:08:45 UTC (rev 1408)
@@ -1,3 +1,9 @@
+libuser-simple-perl (1.30-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Gunnar Wolf <gwolf at debian.org> Thu, 6 Oct 2005 14:04:07 -0500
+
libuser-simple-perl (1.23-1) unstable; urgency=low
* New upstream release - Small bugfix
Modified: packages/libuser-simple-perl/trunk/lib/User/Simple/Admin.pm
===================================================================
--- packages/libuser-simple-perl/trunk/lib/User/Simple/Admin.pm 2005-10-06 19:06:15 UTC (rev 1407)
+++ packages/libuser-simple-perl/trunk/lib/User/Simple/Admin.pm 2005-10-06 19:08:45 UTC (rev 1408)
@@ -11,8 +11,10 @@
$ua = User::Simple::Admin->new($db, $user_table);
- $ua = User::Simple::Admin->create_rdbms_db_structure($db, $user_table);
- $ua = User::Simple::Admin->create_plain_db_structure($db, $user_table);
+ $ua = User::Simple::Admin->create_rdbms_db_structure($db, $user_table,
+ [$extra_sql]);
+ $ua = User::Simple::Admin->create_plain_db_structure($db, $user_table,
+ [$extra_sql]);
$ok = User::Simple::Admin->has_db_structure($db, $user_table);
%users = $ua->dump_users;
@@ -96,6 +98,10 @@
become unreachable. And, of course, keep in mind what SQL construct does your
DBD support.
+If you add any fields with names starting with C<adm_>, they will be visible
+but not modifiable from within L<User::Simple> - You will only be able to
+modify them from L<User::Simple::Admin>.
+
=head2 QUERYING FOR DATABASE READINESS
In order to check if the database is ready to be used by this module with the
Modified: packages/libuser-simple-perl/trunk/lib/User/Simple.pm
===================================================================
--- packages/libuser-simple-perl/trunk/lib/User/Simple.pm 2005-10-06 19:06:15 UTC (rev 1407)
+++ packages/libuser-simple-perl/trunk/lib/User/Simple.pm 2005-10-06 19:08:45 UTC (rev 1408)
@@ -23,6 +23,7 @@
$session = $usr->session;
$otherattrib = $user->otherattrib
+ $ok = $user->set_otherattrib($value);
=head1 DESCRIPTION
@@ -43,9 +44,11 @@
The functionality is split into two modules, L<User::Simple> and
L<User::Simple::Admin>. This module provides the functionality your system
will need for any interaction started by the user - Authentication, session
-management, querying the user's data and changing the password. Any other
-changes (i.e., changing the user's login, level or any attributes you define)
-should be carried out using L<User::Simple::Admin>.
+management, querying the user's data, changing the password and changing any
+attributes you define not beginning with C<adm_>. Note that you cannot directly
+modify a user's login, session or session expiry from within this module - Just
+as a general principle, avoid changing logins. If you absolutely must, use
+User::Simple::Admin instead ;-)
=head2 CONSTRUCTOR
@@ -126,6 +129,11 @@
Note that an empty password will not be accepted.
+To change any attribute defined by you and not labeled as for administrative
+use (this is, its name does not start with C<adm_>):
+
+ $ok = $usr->set_otherattrib($new_value);
+
=head1 DEPENDS ON
L<Date::Calc>
@@ -156,7 +164,7 @@
use UNIVERSAL qw(isa);
our $AUTOLOAD;
-our $VERSION = '1.23';
+our $VERSION = '1.3';
######################################################################
# Constructor/destructor
@@ -359,12 +367,11 @@
# Other attributes are retreived via AUTOLOAD
sub AUTOLOAD {
- my ($self, $name, $myclass, $raise_error, $sth, $value);
+ my ($self, $newval, $name, $myclass, $set, $raise_error, $value, $valid);
$self = shift;
+ $newval = shift;
$name = $AUTOLOAD;
- $self->_debug(5, "Querying for autoloaded $name field");
-
# Autoload gives us the fully qualified method name being called - Get our
# class name and strip it off $name. And why the negated index? Just to be
# sure we don't discard what we don't want to - Either it is at the
@@ -377,6 +384,16 @@
substr($name,0,length($myclass)+2,'');
}
+ # Is the user requesting a value or modifying it?
+ $set = 0;
+ if ($name =~ /^set_(.+)$/) {
+ $set = 1;
+ $name = $1;
+ }
+
+ $self->_debug(5, sprintf('%s for autoloaded field "%s"',
+ ($set ? 'Modifying' : 'Querying'), $name));
+
# We require the name to consist only of alphanumeric characters or
# underscores
$name =~ /^[\w\d\_]+$/ or croak "Invalid field name '$name'";
@@ -388,23 +405,44 @@
# In order to check if $name is a valid field in the DB, query for it -
# but do it inside an eval, as we might get killed!
eval {
+ my ($sth);
$self->{db}{RaiseError} = 1;
- $sth = $self->{db}->prepare("SELECT $name FROM $self->{tbl} WHERE
- id = ?");
- $sth->execute($self->id);
+ if ($set) {
+ if ($name =~ /^(session|login|adm_)/) {
+ # The field is valid, the access is not - $valid will be used
+ # to decide how to die.
+ $valid = 1;
+ die "Invalid field $name";
+ }
+
+ $sth = $self->{db}->prepare("UPDATE $self->{tbl} SET $name = ?
+ WHERE id = ?");
+ $sth->execute($newval, $self->id);
+
+ # We should return success/failure - This is a good and easy way to
+ # check - although, yes, it's a second call to AUTOLOAD.
+ $value = ($self->$name eq $newval) ? 1 : 0;
+ } else {
+ $sth = $self->{db}->prepare("SELECT $name FROM $self->{tbl} WHERE
+ id = ?");
+ $sth->execute($self->id);
+ ($value) = $sth->fetchrow_array;
+ }
};
if ($@) {
# Yes, we will croak and die - But this call might be also trapped.
# Restore the RaiseError anyway.
$self->{db}{RaiseError} = $raise_error;
+ if ($valid) {
+ croak "Access to '$name' restricted";
+ }
croak "Field '$name' does not exist in the User::Simple table!";
}
# Restore the RaiseError
$self->{db}{RaiseError} = $raise_error;
- ($value) = $sth->fetchrow_array;
return $value;
}
Modified: packages/libuser-simple-perl/trunk/t/User-Simple.t
===================================================================
--- packages/libuser-simple-perl/trunk/t/User-Simple.t 2005-10-06 19:06:15 UTC (rev 1407)
+++ packages/libuser-simple-perl/trunk/t/User-Simple.t 2005-10-06 19:08:45 UTC (rev 1408)
@@ -11,7 +11,7 @@
# change 'tests => 1' to 'tests => last_test_to_print';
-use Test::More tests => 33;
+use Test::More tests => 39;
BEGIN { use_ok('User::Simple'); use_ok('User::Simple::Admin') };
#########################
@@ -31,41 +31,41 @@
### First, the User::Simple::Admin tests...
###
- # Create now the database and our table - Add 'descr' and 'privlevel'
+ # Create now the database and our table - Add 'descr' and 'adm_level'
# fields
ok($ua = User::Simple::Admin->create_plain_db_structure($db,'user_simple',
- 'descr varchar(30), privlevel integer'),
+ 'descr varchar(30), adm_level integer'),
'Created a new table and an instance of a User::Simple::Admin object');
# Create some user accounts
ok(($ua->new_user(login => 'admin',
descr => 'Administrative user',
passwd => 'Iamroot',
- privlevel => 5) and
+ adm_level => 5) and
$ua->new_user(login => 'adm2',
descr => 'Another administrative user',
passwd => 'stillagod',
- privlevel => 2) and
+ adm_level => 2) and
$ua->new_user(login => 'user1',
descr => 'Regular user 1',
passwd => 'a_password',
- privlevel => 0) and
+ adm_level => 0) and
$ua->new_user(login => 'user2',
descr => 'Regular user 2',
passwd => 'a_password',
- privlevel => 0) and
+ adm_level => 0) and
$ua->new_user(login => 'user3',
descr => 'Regular user 3',
passwd => 'a_password',
- privlevel => 0) and
+ adm_level => 0) and
$ua->new_user(login => 'user4',
descr => 'Regular user 4',
passwd => '',
- privlevel => 0) and
+ adm_level => 0) and
$ua->new_user(login => 'user5',
descr => 'Regular user 5',
passwd => 'a_password',
- privlevel => 0)),
+ adm_level => 0)),
'Created some users to test on');
# Does dump_users report the right amount of users?
@@ -80,12 +80,14 @@
is($ua->login($adm_id), 'admin', 'First user reports the right login');
is($ua->descr($adm_id), 'Administrative user',
'First user reports the right descr');
- is($ua->privlevel($adm_id), 5, 'First user reports the right privlevel');
+ is($ua->adm_level($adm_id), 5,
+ 'First user reports the right adm_level');
is($ua->login($usr_id), 'user2', 'Second user reports the right login');
is($ua->descr($usr_id), 'Regular user 2',
'Second user reports the right descr');
- is($ua->privlevel($usr_id), 0, 'Second user reports the right privlevel');
+ is($ua->adm_level($usr_id), 0,
+ 'Second user reports the right adm_level');
# Change their details
ok($ua->set_login($usr_id, 'luser1'),
@@ -93,7 +95,7 @@
is($ua->id('luser1'), $usr_id, 'Changed user login reported correctly');
ok(($ua->set_descr($usr_id, 'Irregular luser 1') and
- $ua->set_privlevel($usr_id, 1)),
+ $ua->set_adm_level($usr_id, 1)),
"Successfully changed other of this user's details");
diag('Next test will issue a warning - Disregard.');
@@ -120,8 +122,21 @@
'Successfully logged in with one of the users');
is($usr->login, 'user5', 'Reported login matches');
is($usr->descr, 'Regular user 5', 'Reported descr matches');
- is($usr->privlevel, 0, 'Reported privlevel matches');
+ is($usr->adm_level, 0, 'Reported adm_level matches');
+ # Verify we can change the changeable fields and that we cannot change
+ # restricted ones.
+ ok($usr->set_descr('A new description'), "Able to change a user's descr");
+ is($usr->descr, 'A new description', 'descr changed successfully');
+
+ eval { $usr->set_login('please_kill_me') };
+ ok($!, 'Prevented a login change');
+ is($usr->login, 'user5', 'Previous login still there');
+
+ eval { $usr->set_adm_level(5) };
+ ok($!, 'Prevented an adm_level change');
+ is($usr->adm_level, 0, 'Previous adm_level still there');
+
# Get the user's session
ok($session = $usr->session, "Retreived the user's session");
@@ -132,14 +147,14 @@
is($usr->id, undef, "Nobody's ID successfully reports nothing");
is($usr->login, undef, "Nobody's login successfully reports nothing");
is($usr->descr, undef, "Nobody's descr successfully reports nothing");
- is($usr->privlevel, undef,
- "Nobody's privlevel successfully reports nothing");
+ is($usr->adm_level, undef,
+ "Nobody's adm_level successfully reports nothing");
# Now log in using the session we just retreived - We should get the
# full data again.
ok($usr->ck_session($session), 'Successfully checked for a real session');
is($usr->login, 'user5', 'Reported login matches');
- is($usr->descr, 'Regular user 5', 'Reported descr matches');
- is($usr->privlevel, 0, 'Reported privlevel matches');
+ is($usr->descr, 'A new description', 'Reported descr matches');
+ is($usr->adm_level, 0, 'Reported adm_level matches');
}
More information about the Pkg-perl-cvs-commits
mailing list