r1178 - in packages: . libuser-simple-perl libuser-simple-perl/branches libuser-simple-perl/branches/upstream libuser-simple-perl/branches/upstream/current libuser-simple-perl/branches/upstream/current/lib libuser-simple-perl/branches/upstream/current/lib/User libuser-simple-perl/branches/upstream/current/lib/User/Simple libuser-simple-perl/branches/upstream/current/t
Gunnar Wolf
gwolf@costa.debian.org
Thu, 16 Jun 2005 00:10:40 +0000
Author: gwolf
Date: 2005-06-16 00:10:39 +0000 (Thu, 16 Jun 2005)
New Revision: 1178
Added:
packages/libuser-simple-perl/
packages/libuser-simple-perl/branches/
packages/libuser-simple-perl/branches/upstream/
packages/libuser-simple-perl/branches/upstream/current/
packages/libuser-simple-perl/branches/upstream/current/Changes
packages/libuser-simple-perl/branches/upstream/current/MANIFEST
packages/libuser-simple-perl/branches/upstream/current/META.yml
packages/libuser-simple-perl/branches/upstream/current/Makefile.PL
packages/libuser-simple-perl/branches/upstream/current/README
packages/libuser-simple-perl/branches/upstream/current/lib/
packages/libuser-simple-perl/branches/upstream/current/lib/User/
packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple.pm
packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple/
packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple/Admin.pm
packages/libuser-simple-perl/branches/upstream/current/t/
packages/libuser-simple-perl/branches/upstream/current/t/User-Simple.t
packages/libuser-simple-perl/tags/
Log:
[svn-inject] Installing original source of libuser-simple-perl
Added: packages/libuser-simple-perl/branches/upstream/current/Changes
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/Changes 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/Changes 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,6 @@
+Revision history for Perl extension User::Simple.
+
+0.01 Wed Jun 15 10:52:29 2005
+ - original version; created by h2xs 1.23 with options
+ -X User::Simple
+
Added: packages/libuser-simple-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/MANIFEST 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/MANIFEST 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,8 @@
+Changes
+Makefile.PL
+MANIFEST
+README
+t/User-Simple.t
+lib/User/Simple.pm
+lib/User/Simple/Admin.pm
+META.yml Module meta-data (added by MakeMaker)
Added: packages/libuser-simple-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/META.yml 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/META.yml 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,10 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: User-Simple
+version: 0.8
+version_from: lib/User/Simple.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: packages/libuser-simple-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/Makefile.PL 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/Makefile.PL 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,12 @@
+use 5.008007;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'User::Simple',
+ VERSION_FROM => 'lib/User/Simple.pm', # finds $VERSION
+ PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'lib/User/Simple.pm', # retrieve abstract from module
+ AUTHOR => 'Gunnar Wolf <gwolf@>') : ()),
+);
Added: packages/libuser-simple-perl/branches/upstream/current/README
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/README 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/README 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,42 @@
+User::Simple - Simple user sessions management
+
+User::Simple provides a very simple framework for validating users,
+managing their sessions and storing a minimal set of information (this
+is, a meaningful user login/password pair and the user's name) via a
+database. The sessions can be used as identifiers for i.e. cookies on
+a Web system. The passwords are stored as MD5 hashes (this means, the
+password is not stored in clear text).
+
+User::Simple includes User::Simple::Admin, which provides the basic
+functionalities to manage the users.
+
+User::Simple was originally developed with a PostgreSQL database in
+mind, but should work with any DBD.
+
+INSTALLATION
+
+Installing this module is like installing any standard Perl module,
+this means:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ Date::Calc
+ Digest::MD5
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2005 by Gunnar Wolf
+Instituto de Investigaciones Económicas, UNAM
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.7 or,
+at your option, any later version of Perl 5 you may have available.
+
+
Added: packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple/Admin.pm
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple/Admin.pm 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple/Admin.pm 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,435 @@
+# $Id: Admin.pm,v 1.7 2005/06/15 17:17:10 gwolf Exp $
+use warnings;
+use strict;
+
+package User::Simple::Admin;
+
+=head1 NAME
+
+User::Simple::Admin - User::Simple user administration
+
+=head1 SYNOPSIS
+
+ $ua = User::Simple::Admin->new($db, $user_table);
+
+ $ua = User::Simple::Admin->create_db_structure($db, $user_table);
+ $ok = User::Simple::Admin->has_db_structure($db, $user_table);
+
+ %users = $ua->dump_users;
+
+ $id = $ua->id($login);
+ $login = $ua->login($id);
+ $name = $ua->name($id);
+ $is_admin = $ua->is_admin($id);
+
+ $ok = $usr->set_login($id, $login);
+ $ok = $usr->set_name($id, $name);
+ $ok = $usr->set_admin($id);
+ $ok = $usr->unset_admin($id);
+ $ok = $usr->set_passwd($id, $passwd);
+ $ok = $usr->clear_session($id);
+
+ $id = $ua->new_user($login, $name, $passwd, $is_admin);
+
+ $ok = $ua->remove_user($id);
+
+=head1 DESCRIPTION
+
+Administrative actions for User::Simple modules are handled through this
+Admin object. To instantiate it:
+
+ $a = User::Simple::Admin->new($db, $user_table);
+
+$db is an open connection to the database where the user data is stored.
+
+If we do not yet have the needed DB structure to store the user information,
+we can use this method as a constructor as well.
+
+ $ok = User::Simple::Admin->create_db_structure($db, $user_table)
+
+In order to check if the database is ready to be used by this module with the
+specified table name.
+
+ %users = $ua->dump_users;
+
+Will return a hash with the data regarding the registered users, in the
+following form:
+
+ ( $id1 => { is_admin => $is_admin1, name => $name1, login => $login1},
+ $id2 => { is_admin => $is_admin2, name => $name2, login => $login2},
+ (...) )
+
+ $id = $ua->new_user($login, $name, $passwd, $is_admin);
+
+Creates a new user with the specified data. $is_admin is a boolean value - Use
+1 for true, 0 for false. Returns the new user's ID.
+
+ $ok = $ua->remove_user($id);
+
+Removes the user specified by the ID.
+
+ $id = $ua->id($login);
+ $login = $ua->login($id);
+ $name = $ua->name($id);
+ $is_admin = $ua->is_admin($id);
+
+Get the value of each of the mentioned attributes. Note that in order to get
+the ID you can supply the login, every other method answers only to the ID. In
+case you have the login and want to get the name, you should use
+C<$ua->name($ua->id($login));>
+
+ $ok = $usr->set_login($id, $login);
+ $ok = $usr->set_name($id, $name);
+ $ok = $usr->set_passwd($id, $passwd);
+
+Modifies the requested attribute of the specified user, setting it to the new
+value.
+
+ $ok = $usr->set_admin($id);
+ $ok = $usr->unset_admin($id);
+
+Sets or removes the administrative status of this user.
+
+ $ok = $usr->clear_session($id);
+
+Removes the session which the current user had open, if any.
+
+=head1 DEPENDS ON
+
+L<Digest::MD5>
+
+=head1 SEE ALSO
+
+L<User::Simple> for the regular user authentication routines (that is, to
+use the functionality this module adimisters)
+
+=head1 AUTHOR
+
+Gunnar Wolf <gwolf@gwolf.org>
+
+=head1 COPYRIGHT
+
+Copyright 2005 Gunnar Wolf / Instituto de Investigaciones Económicas UNAM
+This module is Free Software, it can be redistributed under the same terms
+as Perl.
+
+=cut
+
+use Carp;
+use Digest::MD5 qw(md5_hex);
+use UNIVERSAL qw(isa);
+
+######################################################################
+# Constructor
+
+sub new {
+ my ($self, $class, $db, $table);
+ $class = shift;
+ $db = shift;
+ $table = shift;
+
+ # Verify we got the right arguments
+ unless (isa($db, 'DBI::db')) {
+ carp "First argument must be a DBI connection";
+ return undef;
+ }
+
+ # In order to check if the table exists, check if it consists only of
+ # valid characters and query for a random user
+ unless ($table =~ /^[\w\_]+$/) {
+ carp "Invalid table name $table";
+ return undef;
+ }
+ unless ($class->has_db_structure($db, $table)) {
+ carp "Table $table does not exist or has wrong structure";
+ carp "Use $class->create_db_structure first.";
+ return undef;
+ }
+
+ $self = { db => $db, tbl => $table };
+
+ bless $self, $class;
+ return $self;
+}
+
+######################################################################
+# Creating the needed structure
+
+sub create_db_structure {
+ my ($class, $db, $table, $sth);
+ $class = shift;
+ $db = shift;
+ $table = shift;
+
+ # Remember some DBD backends don't implement 'serial' - Use 'integer' and
+ # some logic on our side instead
+ unless ($sth = $db->prepare("CREATE TABLE $table (
+ id integer PRIMARY KEY,
+ login varchar NOT NULL UNIQUE,
+ name varchar NOT NULL,
+ passwd varchar,
+ is_admin bool NOT NULL DEFAULT 'f',
+ session varchar UNIQUE,
+ session_exp varchar)") and $sth->execute) {
+ carp "Could not create database structure using table $table";
+ return undef;
+ }
+
+ return $class->new($db, $table);
+}
+
+sub has_db_structure {
+ my ($class, $db, $table, $sth);
+ $class = shift;
+ $db = shift;
+ $table = shift;
+
+ # We check for the DB structure by querying for any given row.
+ # Yes, this method can fail if the needed fields exist but have the wrong
+ # data, if the ID is not linked to a trigger and a sequence, and so on...
+ # But usually, this check will be enough just to determine if we have the
+ # structure ready.
+ return 1 if ($sth=$db->prepare("SELECT id, login, name, passwd, is_admin,
+ session, session_exp FROM $table LIMIT 1") and $sth->execute);
+ return 0;
+}
+
+######################################################################
+# Retrieving information
+
+sub dump_users {
+ my ($self, $order, $sth, %users);
+ $self = shift;
+
+ unless ($sth = $self->{db}->prepare("SELECT id, login, name, is_admin
+ FROM $self->{tbl}") and $sth->execute) {
+ carp 'Could not query for the user list';
+ return undef;
+ }
+
+ while (my @row = $sth->fetchrow_array) {
+ $users{$row[0]} = {login => $row[1],
+ name => $row[2],
+ is_admin => $row[3]
+ };
+ }
+
+ return %users;
+}
+
+sub id {
+ my ($self, $login, $sth, $id);
+ $self = shift;
+ $login = shift;
+
+ $sth = $self->{db}->prepare("SELECT id FROM $self->{tbl} WHERE login = ?");
+ $sth->execute($login);
+
+ ($id) = $sth->fetchrow_array;
+
+ return $id;
+}
+
+sub login {
+ my ($self, $id);
+ $self = shift;
+ $id = shift;
+ return $self->_get_field($id, 'login');
+}
+
+sub name {
+ my ($self, $id);
+ $self = shift;
+ $id = shift;
+ return $self->_get_field($id, 'name');
+}
+
+sub is_admin {
+ my ($self, $id);
+ $self = shift;
+ $id = shift;
+ return $self->_get_field($id, 'is_admin');
+}
+
+######################################################################
+# Modifying information
+
+sub set_login {
+ my ($self, $id, $new);
+ $self = shift;
+ $id = shift;
+ $new = shift;
+ return $self->_set_field($id, 'login', $new);
+}
+
+sub set_name {
+ my ($self, $id, $new);
+ $self = shift;
+ $id = shift;
+ $new = shift;
+ return $self->_set_field($id, 'name', $new);
+}
+
+sub set_admin {
+ my ($self, $id);
+ $self = shift;
+ $id = shift;
+ return $self->_set_field($id, 'is_admin', 1);
+}
+
+sub unset_admin {
+ my ($self, $id);
+ $self = shift;
+ $id = shift;
+ return $self->_set_field($id, 'is_admin', 0);
+}
+
+sub set_passwd {
+ my ($self, $id, $new, $crypted, $sth);
+ $self = shift;
+ $id = shift;
+ $new = shift;
+
+ $crypted = md5_hex($new, $id);
+
+ return $self->_set_field($id, 'passwd', $crypted);
+}
+
+sub clear_session {
+ my ($self, $id);
+ $self = shift;
+ $id = shift;
+ return ($self->_set_field($id,'session','') &&
+ $self->_set_field($id, 'sesson_exp', ''));
+}
+
+######################################################################
+# User creation and removal
+
+sub new_user {
+ my ($self, $login, $name, $passwd, $is_adm, $id, $orig_re);
+ $self = shift;
+ $login = shift;
+ $name = shift;
+ $passwd = shift;
+ $is_adm = shift || 0; # Don't whine on undef
+
+ $orig_re = $self->{db}->{RaiseError};
+ eval {
+ my ($sth, $id);
+ $self->{db}->begin_work;
+ $self->{db}->{RaiseError} = 1;
+
+ # Not all DBD backends implement the 'serial' datatype - We use a
+ # simple integer, and we just move the 'serial' logic to this point,
+ # the only new user creation area.
+ # Yes, this could lead to a race condition and to the attempt to insert
+ # two users with the same ID - We have, however, the column as a
+ # 'primary key'. Any DBD implementing unicity will correctly fail.
+ # And... Well, nobody expects too high trust from DBD::CSV, right? :)
+ $sth = $self->{db}->prepare("SELECT id FROM $self->{tbl} ORDER BY
+ id desc LIMIT 1");
+ $sth->execute;
+ ($id) = $sth->fetchrow_array;
+ $id++;
+
+ $sth = $self->{db}->prepare("INSERT INTO $self->{tbl} (id, login, name,
+ is_admin) VALUES (?, ?, ?, ?)");
+ $sth->execute($id, $login, $name, $is_adm?1:0);
+
+ $id = $self->id($login);
+ $self->set_passwd($id, $passwd);
+
+ $self->{db}->commit;
+ $self->{db}->{RaiseError} = $orig_re;
+ };
+ if ($@) {
+ $self->{db}->rollback;
+ $self->{db}->{RaiseError} = $orig_re;
+ carp "Could not create specified user";
+ return undef;
+ }
+ return 1;
+}
+
+sub remove_user {
+ my ($self, $id, $sth);
+ $self = shift;
+ $id = shift;
+
+ unless ($sth = $self->{db}->prepare("DELETE FROM $self->{tbl} WHERE id=?")
+ and $sth->execute($id)) {
+ carp "Could not remove user $id";
+ return undef;
+ }
+
+ return 1;
+}
+
+######################################################################
+# Private methods and functions
+
+sub _get_field {
+ my ($self, $id, $field, $sth);
+ $self = shift;
+ $id = shift;
+ $field = shift;
+
+ unless (_is_valid_field($field)) {
+ carp "Invalid field: $field";
+ return undef;
+ }
+
+ $sth=$self->{db}->prepare("SELECT $field FROM $self->{tbl} WHERE id = ?");
+ $sth->execute($id);
+
+ return $sth->fetchrow_array;
+}
+
+sub _set_field {
+ my ($self, $id, $field, $val, $sth);
+ $self = shift;
+ $id = shift;
+ $field = shift;
+ $val = shift;
+
+ unless (_is_valid_field($field) or $field eq 'passwd') {
+ carp "Invalid field: $field";
+ return undef;
+ }
+
+ unless ($sth = $self->{db}->prepare("UPDATE $self->{tbl} SET $field = ?
+ WHERE id = ?") and $sth->execute($val, $id)) {
+ carp "Could not set $field to $val for user $id";
+ return undef;
+ }
+
+ return 1;
+}
+
+sub _is_valid_field {
+ my $field = shift;
+ return ($field =~ /^(login|name|is_admin)$/) ? 1 : 0;
+}
+
+1;
+
+# $Log: Admin.pm,v $
+# Revision 1.7 2005/06/15 17:17:10 gwolf
+# Some documentation fixes
+# User::Simple: Finishing touches to breathe independent life to it, so it will
+# become a project of its own ;-)
+#
+# Revision 1.6 2005/05/10 05:06:24 gwolf
+# Replace Crypt::PasswdMD5 for Digest::MD5 for consistency
+#
+# Revision 1.5 2005/05/02 19:11:55 gwolf
+# Fixed a simple warning
+#
+# Revision 1.4 2005/04/06 23:00:09 gwolf
+# Documented
+#
+# Revision 1.3 2005/04/05 00:33:39 gwolf
+# - Admin: Fixed create_db_structure to reflect documented behavior
+# - Documentation details added
+#
Added: packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple.pm
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple.pm 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/lib/User/Simple.pm 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,424 @@
+# $Id: Simple.pm,v 1.7 2005/06/15 17:17:10 gwolf Exp $
+use warnings;
+use strict;
+
+package User::Simple;
+
+=head1 NAME
+
+User::Simple - Simple user sessions management
+
+=head1 SYNOPSIS
+
+ $usr = User::Simple->new(db => $db,
+ [tbl => $user_table],
+ [durat => $duration],
+ [debug => $debug] );
+
+ $ok = $usr->ck_session($session);
+ $ok = $usr->ck_login($login, $passwd, [$no_sess]);
+ $ok = $usr->set_passwd($new_pass);
+ $usr->end_session;
+
+ $name = $usr->name;
+ $login = $usr->login;
+ $id = $usr->id;
+ $session = $usr->session;
+ $ok = $usr->is_admin;
+
+=head1 DESCRIPTION
+
+User::Simple provides a very simple framework for validating users,
+managing their sessions and storing a minimal set of information (this
+is, a meaningful user login/password pair and the user's name) via a
+database. The sessions can be used as identifiers for i.e. cookies on
+a Web system. The passwords are stored as MD5 hashes (this means, the
+password is not stored in clear text).
+
+User::Simple was originally developed with a PostgreSQL database in
+mind, but should work with any real DBMS. Sadly, this rules out DBD::CSV,
+DBD::XBase, DBD::Excel and many others - The user table requires the driver
+to implement primary keys and NOT NULL/UNIQUE constraints.
+
+In order to create a User::Simple object, call the new argument with an
+active DBI (database connection) object as its only argument:
+
+ $usr = User::Simple->new(db => $db, [tbl => $table], [durat => $duration],
+ [debug => $debug]);
+
+Of course, the database must have the right structure in it - please check
+L<User::Simple::Admin> for more information.
+
+The C<tbl> parameter is the name of the table where the user information is
+stored. If not specified, it defaults to 'user_simple'.
+
+C<durat> is the number of minutes a user's session should last. Its default is
+of 30 minutes.
+
+C<debug> is the verbosity level of the debugging messages - The default is 2,
+it accepts integers between 0 and 5 (higher means more messages). Messages of
+high relevance (i.e. the database failing to reflect any changes we request it
+to make) are shown if debug is >= 1, regular failure messages are shown if
+debug >= 3, absolutely everything is shown if debug == 5. Be warned that when
+debug is set to 5, information such as cleartext passwords will be logged as
+well!
+
+Once the object is created, we can ask it to verify that a given user is
+valid, either by checking against a session string or against a login/password
+pair::
+
+ $ok = $usr->ck_session($session);
+ $ok = $usr->ck_login($login, $passwd, [$no_sess]);
+
+The optional $no_sess argument should be used if we do not want to modify the
+current session (or to create a new session), we want only to verify the
+password matches (i.e. when asking for the current password as a confirmation
+in order to change a user's password). It will almost always be left false.
+
+To change the user's password:
+
+ $ok = $usr->set_passwd($nvo_pass);
+
+To end a session:
+
+ $ok = $usr->end_session;
+
+To verify whether we have successfully validated a user:
+
+ $ok = $usr->is_valid;
+
+To check the user's attributes (name, login and ID):
+
+ $name = $usr->name;
+ $login = $usr->login;
+ $id = $usr->id;
+
+To check if the user has administrative access (again, see
+L<User::Simple::Admin> for further details):
+
+ $ok = $usr->is_admin;
+
+=head1 DEPENDS ON
+
+L<Date::Calc>
+
+L<Digest::MD5>
+
+=head1 SEE ALSO
+
+L<User::Simple::Admin> for administrative routines
+
+=head1 TO DO
+
+This module still requires a decent test suite. In order for it to become
+automatic, we need to be able to operate without a real RDBMS, i.e., with
+DBD::CSV.
+
+I would also like to separate a bit the table structure, allowing for
+flexibility - This means, if you added some extra fields to the table,
+provide an easy way to access them. Currently, you have to reach in from
+outside User::Simple, skipping the abstraction, to get them.
+
+Besides that, it works as expected (that is, as I expect ;-) )
+
+=head1 AUTHOR
+
+Gunnar Wolf <gwolf@gwolf.org>
+
+=head1 COPYRIGHT
+
+Copyright 2005 Gunnar Wolf / Instituto de Investigaciones Económicas UNAM
+This module is Free Software, it can be redistributed under the same terms
+as Perl.
+
+=cut
+
+use Carp;
+use Date::Calc qw(Today_and_Now Add_Delta_DHMS Delta_DHMS);
+use Digest::MD5 qw(md5_hex);
+use UNIVERSAL qw(isa);
+
+our $VERSION = '0.8';
+
+######################################################################
+# Constructor
+
+sub new {
+ my ($class, $self, %init, $sth);
+ $class = shift;
+ %init = @_;
+
+ # Verify we got the right arguments
+ for my $key (keys %init) {
+ next if $key =~ /^(db|debug|durat|tbl)$/;
+ carp "Unknown argument received: $key";
+ return undef;
+ }
+
+ # Default values
+ $init{tbl} = 'user_simple' unless defined $init{tbl};
+ $init{durat} = 30 unless defined $init{durat};
+ $init{debug} = 2 unless defined $init{debug};
+
+ unless (defined($init{db}) and isa($init{db}, 'DBI::db')) {
+ carp "Mandatory db argument must be a valid (DBI) database handle";
+ return undef;
+ }
+
+ # In order to check if the table exists, check if it consists only of
+ # valid characters and query for a random user
+ unless ($init{tbl} =~ /^[\w\_]+$/) {
+ carp "Invalid table name $init{tbl}";
+ return undef;
+ }
+ unless ($sth=$init{db}->prepare("SELECT id, login, name, is_admin
+ FROM $init{tbl} LIMIT 1") and $sth->execute) {
+ carp "Table $init{tbl} does not exist or has wrong structure";
+ return undef;
+ }
+
+ unless ($init{durat} =~ /^\d+$/) {
+ carp "Duration must be set to a positive integer";
+ return undef;
+ }
+
+ unless ($init{debug} =~ /^\d+$/ and $init{debug} <= 5) {
+ carp "Debug level must be an integer between 0 and 5";
+ return undef;
+ }
+
+ $self = { %init };
+ bless $self, $class;
+
+ $self->_debug(5, "$class object successfully created");
+
+ return $self;
+}
+
+######################################################################
+# User validation
+
+sub ck_session {
+ my ($self, $sess, $sth, $id, $exp);
+ $self = shift;
+ $sess = shift;
+
+ $self->_debug(5, "Checking session $sess");
+
+ unless ($sth = $self->{db}->prepare("SELECT id, session_exp
+ FROM $self->{tbl} WHERE session = ?") and $sth->execute($sess)
+ and ($id, $exp) = $sth->fetchrow_array) {
+ # Session does not exist
+ $self->_debug(3,"Inexistent session");
+ return undef;
+ }
+
+ unless ($self->_ck_session_expiry($exp)) {
+ $self->_debug(3,"Expired session");
+ return undef;
+ }
+
+ $self->{id} = $id;
+ $self->_populate_from_id;
+ $self->_refresh_session;
+ $self->_debug(5,"Session successfully checked for ID $id");
+
+ return $self->{id};
+}
+
+sub ck_login {
+ my ($self, $login, $pass, $no_sess, $crypted, $sth, $id, $db_pass);
+ $self = shift;
+ $login = shift;
+ $pass = shift;
+ $no_sess = shift;
+
+ $self->_debug(5, "Verifying login: $login/$pass");
+
+ # Is this login/password valid?
+ unless ($sth = $self->{db}->prepare("SELECT id, passwd FROM $self->{tbl}
+ WHERE login = ?") and $sth->execute($login) and
+ ($id, $db_pass) = $sth->fetchrow_array) {
+ $self->_debug(3,"Invalid login $login");
+ return undef;
+ }
+
+ $crypted = md5_hex($pass, $id);
+ if ($crypted ne $db_pass) {
+ $self->_debug(3,"Invalid password ($crypted)");
+ return undef;
+ }
+
+ $self->_debug(5, "login/password verified successfully");
+
+ # User authenticated. Now create the session - Use a MD5 hash of the
+ # current timestamp. Skip this step if $no_sess is true.
+ if ($no_sess) {
+ $self->_debug(3, "Not touching session");
+
+ } else {
+ unless ($sth = $self->{db}->prepare("UPDATE $self->{tbl} SET
+ session = ? WHERE id = ?") and
+ $sth->execute(md5_hex(join('-', Today_and_Now)), $id)) {
+ $self->_debug(1,'Could not create user session');
+ return undef;
+ }
+ }
+
+ # Populate the object with the user's data
+ $self->{id} = $id;
+ $self->_populate_from_id;
+ $self->_refresh_session;
+ $self->_debug(5,"Login successfully checked for ID $id");
+ return $self->{id};
+}
+
+sub end_session {
+ my ($self, $sth);
+ $self = shift;
+ $self->_debug(5, "Closing session for $self->{id}");
+
+ return undef unless ($self->{id});
+
+ $sth = $self->{db}->prepare("UPDATE $self->{tbl} SET session = NULL,
+ session_exp = NULL WHERE id = ?");
+ $sth->execute($self->{id});
+
+ for my $key qw(id is_admin login name session session_exp) {
+ delete $self->{$key};
+ }
+
+ return 1;
+}
+
+######################################################################
+# Accessors, mutators
+
+sub is_valid { my $self = shift; return $self->{id} ? 1 : 0; }
+sub name { my $self = shift; return $self->{name}; }
+sub login { my $self = shift; return $self->{login}; }
+sub id { my $self = shift; return $self->{id}; }
+sub session { my $self = shift; return $self->{session}; }
+sub is_admin { my $self = shift; return $self->{is_admin}; }
+
+sub set_passwd {
+ my ($self, $pass, $crypted, $sth);
+ $self = shift;
+ $pass = shift;
+ $crypted = md5_hex($pass, $self->{id});
+
+ return undef unless ($self->{id} and $pass);
+
+ $self->_debug(5, "Setting $self->{login}'s password to $pass ($crypted)");
+
+ unless ($sth = $self->{db}->prepare("UPDATE $self->{tbl} SET passwd = ?
+ WHERE id = ?") and
+ $sth->execute($crypted, $self->{id})) {
+ $self->_debug(1,"Could not set the requested password");
+ return undef;
+ }
+
+ return 1;
+}
+
+######################################################################
+# Private methods
+
+# Warns the message received as the second parameter if the debug level is
+# >= the first parameter
+sub _debug {
+ my ($self, $level, $text);
+ $self = shift;
+ $level = shift;
+ $text = shift;
+
+ carp $text if $self->{debug} >= $level;
+ return 1;
+}
+
+# Once we have the user's ID, we populate the object by recalling all of the
+# database's fields.
+# Takes no arguments but the object itself.
+sub _populate_from_id {
+ my ($self, $sth);
+ $self=shift;
+
+ $sth=$self->{db}->prepare("SELECT login, name, is_admin, session,
+ session_exp FROM $self->{tbl} WHERE id=?");
+ $sth->execute($self->{id});
+
+ ($self->{login}, $self->{name}, $self->{is_admin}, $self->{session},
+ $self->{session_exp}) = $sth->fetchrow_array;
+
+ return 1;
+}
+
+# Checks if a session's expiration time is still in the future.
+# Receives as its only parameter the expiration time as a string as stored in
+# the database (this is, year-month-day-hour-minute-second). Returns 1 if
+# the session is still valid, 0 if it has expired.
+sub _ck_session_expiry {
+ my ($self, $exp, @exp, @now, @diff, $diff);
+ $self = shift;
+ $exp = shift;
+
+ return undef unless $exp;
+ @exp = split (/-/, $exp);
+ @now = Today_and_Now();
+
+ if (scalar @exp != 6) {
+ $self->_debug(1,"Invalid session format");
+ return undef;
+ }
+
+ @diff = Delta_DHMS(@now, @exp);
+ $diff = ((shift(@diff) * 24 + shift(@diff)) * 60 +
+ shift(@diff)) * 60 + shift(@diff);
+
+ return ($diff > 0) ? 1 : 0;
+}
+
+sub _refresh_session {
+ my ($self, $sth, $new_exp);
+ $self = shift;
+
+ # Do we have an identified user?
+ unless ($self->{id}) {
+ $self->_debug(3,"Cannot refresh session: User not yet identified");
+ return undef;
+ }
+
+ # The new expiration time is set to the current timestamp plus
+ # $self->{durat} minutes
+ $new_exp = join('-', Add_Delta_DHMS(Today_and_Now,
+ 0, 0, $self->{durat}, 0));
+
+ unless ($sth = $self->{db}->prepare("UPDATE $self->{tbl} SET
+ session_exp = ? WHERE id = ?") and
+ $sth->execute($new_exp, $self->{id})) {
+ $self->_debug(1,"Couldn't refresh session.");
+ return undef;
+ }
+}
+
+1;
+
+# $Log: Simple.pm,v $
+# Revision 1.7 2005/06/15 17:17:10 gwolf
+# Some documentation fixes
+# User::Simple: Finishing touches to breathe independent life to it, so it will
+# become a project of its own ;-)
+#
+# Revision 1.6 2005/06/07 01:23:14 gwolf
+# Fixed: Used hardwired reference for table name
+#
+# Revision 1.5 2005/05/10 05:06:24 gwolf
+# Replace Crypt::PasswdMD5 for Digest::MD5 for consistency
+#
+# Revision 1.4 2005/04/14 00:03:41 gwolf
+# Continuing with the translation, it _seems_ everything is working as it should
+#
+# Revision 1.3 2005/04/05 00:33:39 gwolf
+# - Admin: Fixed create_db_structure to reflect documented behavior
+# - Documentation details added
+#
Added: packages/libuser-simple-perl/branches/upstream/current/t/User-Simple.t
===================================================================
--- packages/libuser-simple-perl/branches/upstream/current/t/User-Simple.t 2005-06-15 17:33:50 UTC (rev 1177)
+++ packages/libuser-simple-perl/branches/upstream/current/t/User-Simple.t 2005-06-16 00:10:39 UTC (rev 1178)
@@ -0,0 +1,15 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl User-Simple.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 2;
+BEGIN { use_ok('User::Simple'); use_ok('User::Simple::Admin') };
+
+#########################
+
+# Insert your test code below, the Test::More module is use()ed here so read
+# its man page ( perldoc Test::More ) for help writing this test script.
+