User-Simple-1.45000755001750001750 012160150020 13212 5ustar00gwolfgwolf000000000000User-Simple-1.45/LICENSE000444001750001750 47712160150020 14344 0ustar00gwolfgwolf000000000000COPYRIGHT AND LICENCE Copyright (C) 2005-2009 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. User-Simple-1.45/README000444001750001750 270612160150020 14234 0ustar00gwolfgwolf000000000000User::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 allowing for transparent access of arbitrary data (i.e. the user's name, privilege level, etc.) 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, even those not implemented with a real RDBMS (i.e. XBase, CSV, etc). 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 DBI DBI is not called directly from within the module, but it is required in order to do anything with it. COPYRIGHT AND LICENCE Copyright (C) 2005-2009 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. User-Simple-1.45/Changes000444001750001750 767312160150020 14657 0ustar00gwolfgwolf000000000000Revision history for Perl extension User::Simple. 1.45 Tue Jun 18 16:24:21 CDT 2013 - Turns out the POD checks actually need a charset to be explicitly declared, even if using UTF. Go know. Anyway, thanks (again!) to gregor herrmann. 1.44 Tue Jun 18 13:09:03 CDT 2013 - Reencoded the files as UTF8. Older encoding systems must die. - One missing pair of parentheses caused the admin module to fail building under Perl 5.18. Thanks to gregor herrmann for reporting it! 1.43 Tue Jan 20 13:37:10 CST 2009 - Dropped spurious requirement of YAML in the test suite (that was added as a debugging aid :-/ ) Thanks to Slaven Rezic for pointing it out... 1.42 Wed Dec 10 17:22:19 CST 2008 - Fixed a session hash predictability/clash vulnerability, reported by Eugene V. Lyubimkin via Damyan Ivanov. Thanks! 1.40 Fri Jun 27 11:35:01 CDT 2008 - Bah... Why jump through that many hoops? Moving away from ExtUtils::MakeMaker to Module::Build 1.38 Wed Jun 25 17:30:31 CDT 2008 - "The Kwalitee release" - Added Test::Pod test - Regenerated META.yml to be valid. Where did I take mine from?! - Completed license, author license, both in META.yml and in LICENSE - But still, no real, substantive changes! 1.37 Mon Jun 23 10:41:00 CDT 2008 - Fixed remaining file locking problem which caused the tests to fail in *BSD systems. Thanks to Slaven Rezic and CPANTS for helping me spot and fix the bug! 1.36 Sun Jun 15 23:56:56 CDT 2008 - Umh... since the very early revisions (0.9?), I was only explicitly skipping 14 tests if DBD::XBase is not installed. Updating it to 37. Grr. - Changed the tests to run under SQLite3 instead of DBD::XBase - A bit more reliable, it seems 1.35 - Gah... Using DBD::XBase in the tests lets many subtle problems slip by... For example, 1.3 was released with a broken User::Admin::new_user :-/ 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, not as incorrectly :) ) 1.22 Mon Sep 26 19:47:12 2005 - Bugfix: Last remanent of old name/level structure removed. Thanks, Alex Juarez! - Minimum required Perl version reduced to 5.8 (was 5.8.7) 1.2 Fri Sep 23 13:43:00 2005 - API CHANGE - API CHANGE - API CHANGE: Some changes in User::Admin::Simple (in user creation, database structure creation) - Added generic (AUTOLOADed) methods to both User::Simple and User::Simple::Admin to deal with unknown attributes in the table - Finally (completely) removed the deprecated is_admin infrastructure - Name and level are not explicitly implemented from within the class, they become (if required by the user) AUTOLOADed. - Added examples/user-simple-admin, a command-line interface for managing User::Simple tables 1.1 Thu Sep 08 14:40:05 2005 - Never really released, but PAUSE won't allow me to re-use this version number... Sorry 1.0 Sun Aug 21 23:06:08 2005 - Now correctly works with any kind of DBD backend - Added a complete test suite, which surprisingly worked! 0.9 Sat Jul 30 10:45:15 2005 - Added Date::Calc and Digest::MD5 as prerequisite modules - Added a more granular 'level' for the users instead of the all-or-nothing is_admin infrastructure - Modified the is_admin infrastructure so old code works seamlessly with the new version (although sends out some warnings, as is_admin is officially deprecated) - Added/clarified some documentation 0.8 Wed Jun 15 10:52:29 2005 - original version; created by h2xs 1.23 with options -X User::Simple User-Simple-1.45/Build.PL000444001750001750 74312160150020 14627 0ustar00gwolfgwolf000000000000use Module::Build; my $build = Module::Build->new( module_name => 'User::Simple', dist_abstract => 'Simple user sessions management', dist_author => 'Gunnar Wolf ', license => 'perl', requires => {Date::Calc => 0, Digest::MD5 => 0, DBI => 0}, recommends => {}, build_requires => {DBD::SQLite => 0, Test::Pod => 0, Module::Build => 0}, create_makefile_pl => 'passthrough' ); $build->create_build_script; User-Simple-1.45/Makefile.PL000444001750001750 226312160150020 15324 0ustar00gwolfgwolf000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3800 unless (eval "use Module::Build::Compat 0.02; 1" ) { print "This module requires Module::Build to install itself.\n"; require ExtUtils::MakeMaker; my $yn = ExtUtils::MakeMaker::prompt (' Install Module::Build now from CPAN?', 'y'); unless ($yn =~ /^y/i) { die " *** Cannot install without Module::Build. Exiting ...\n"; } require Cwd; require File::Spec; require CPAN; # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); CPAN::Shell->install('Module::Build::Compat'); CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate or die "Couldn't install Module::Build, giving up.\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; Module::Build::Compat->run_build_pl(args => \@ARGV); my $build_script = 'Build'; $build_script .= '.com' if $^O eq 'VMS'; exit(0) unless(-e $build_script); # cpantesters convention require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); User-Simple-1.45/META.yml000444001750001750 125712160150020 14625 0ustar00gwolfgwolf000000000000--- abstract: 'Simple user sessions management' author: - 'Gunnar Wolf ' build_requires: DBD::SQLite: 0 Module::Build: 0 Test::Pod: 0 configure_requires: Module::Build: 0.38 dynamic_config: 1 generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.110440' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: User-Simple provides: User::Simple: file: lib/User/Simple.pm version: 1.45 User::Simple::Admin: file: lib/User/Simple/Admin.pm version: 0 requires: DBI: 0 Date::Calc: 0 Digest::MD5: 0 resources: license: http://dev.perl.org/licenses/ version: 1.45 User-Simple-1.45/META.json000444001750001750 230012160150020 14763 0ustar00gwolfgwolf000000000000{ "abstract" : "Simple user sessions management", "author" : [ "Gunnar Wolf " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.110440", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "User-Simple", "prereqs" : { "build" : { "requires" : { "DBD::SQLite" : 0, "Module::Build" : 0, "Test::Pod" : 0 } }, "configure" : { "requires" : { "Module::Build" : "0.38" } }, "runtime" : { "requires" : { "DBI" : 0, "Date::Calc" : 0, "Digest::MD5" : 0 } } }, "provides" : { "User::Simple" : { "file" : "lib/User/Simple.pm", "version" : "1.45" }, "User::Simple::Admin" : { "file" : "lib/User/Simple/Admin.pm", "version" : 0 } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "1.45" } User-Simple-1.45/MANIFEST000444001750001750 24712160150020 14463 0ustar00gwolfgwolf000000000000Build.PL Changes lib/User/Simple.pm lib/User/Simple/Admin.pm LICENSE Makefile.PL MANIFEST META.yml README t/User-Simple.t t/pod.t examples/user-simple-admin META.json User-Simple-1.45/t000755001750001750 012160150020 13455 5ustar00gwolfgwolf000000000000User-Simple-1.45/t/User-Simple.t000444001750001750 1440612160150020 16171 0ustar00gwolfgwolf000000000000# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl User-Simple.t' use strict; use DBI; use File::Temp qw(:mktemp); my ($db, $tmp_file); ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 40; 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. $tmp_file = mktemp('User-Simple-build-XXXXXX'); eval { $db = DBI->connect('DBI:SQLite:dbname=' .$tmp_file) }; SKIP: { my ($ua, $adm_id, $usr_id, $usr, $session, %users, %sessions); skip 'Not executing the complete tests: Database handler not created ' . '(I need DBD::SQLite for this)', 37 unless $db; ### ### First, the User::Simple::Admin tests... ### # 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), 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', adm_level => 5) and $ua->new_user(login => 'adm2', descr => 'Another administrative user', passwd => 'stillagod', adm_level => 2) and $ua->new_user(login => 'user1', descr => 'Regular user 1', passwd => 'a_password', adm_level => 0) and $ua->new_user(login => 'user2', descr => 'Regular user 2', passwd => 'a_password', adm_level => 0) and $ua->new_user(login => 'user3', descr => 'Regular user 3', passwd => 'a_password', adm_level => 0) and $ua->new_user(login => 'user4', descr => 'Regular user 4', passwd => '', adm_level => 0) and $ua->new_user(login => 'user5', descr => 'Regular user 5', passwd => 'a_password', adm_level => 0)), 'Created some users to test on'); # Does dump_users report the right amount of users? %users = $ua->dump_users; is(scalar(keys %users), 7, 'Right number of users reported'); # Now do some queries on them... $adm_id = $ua->id('admin'); $usr_id = $ua->id('user2'); # Get the information they were created with 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->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->adm_level($usr_id), 0, 'Second user reports the right adm_level'); # Change their details ok($ua->set_login($usr_id, 'luser1'), 'Successfully changed the user login'); is($ua->id('luser1'), $usr_id, 'Changed user login reported correctly'); ok(($ua->set_descr($usr_id, 'Irregular luser 1') and $ua->set_adm_level($usr_id, 1)), "Successfully changed other of this user's details"); diag('Next test will issue a warning - Disregard.'); ok(!($ua->set_login($adm_id, 'adm2')), 'System successfully prevents me from having duplicate logins'); # Remove a user, should be gone. ok($ua->remove_user($usr_id), 'Removed a user'); ok(!($ua->id('luser1')), 'Could not query for the removed user - Good.'); ### ### Now, the User::Simple tests ### ok($usr = User::Simple->new(db=>$db, tbl=>'user_simple'), 'Created a new instance of a User::Simple object'); # Log in with user/password as user4 - As the password is blank, it should # be marked as disabled ok(!($usr->ck_login('user4','')), 'Blank password is successfully disabled'); # Log in with user/password, retrieve the user's data ok($usr->ck_login('user5','a_password'), '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->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"); # Try to log in with an invalid session, check that all of the data is # cleared. is($usr->ck_session('blah'), undef, 'Checked for a wrong session, successfully got refused'); 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->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, 'A new description', 'Reported descr matches'); is($usr->adm_level, 0, 'Reported adm_level matches'); # Ensure that logging in several times in a row produces different # session IDs (that is, that we are not vulnerable to time-based # predictability - see changelog for 1.42) %sessions = (); map { $usr->ck_login('user5', 'a_password'); $sessions{$usr->session} = $_} (1..10); is(scalar(keys %sessions), 10, 'Discrepancy in the number of generated sessions - possible clash?') } unlink($tmp_file) User-Simple-1.45/t/pod.t000444001750001750 40712160150020 14542 0ustar00gwolfgwolf000000000000use strict; use warnings; no warnings qw(redefine); eval 'use Test::Pod'; all_pod_files_ok(); sub all_pod_files_ok { # This definition will be overwritten if Test::Pod is available print "1..1\nok 1 - Skipping POD tests - Test::Pod not available?\n"; } User-Simple-1.45/lib000755001750001750 012160150020 13760 5ustar00gwolfgwolf000000000000User-Simple-1.45/lib/User000755001750001750 012160150020 14676 5ustar00gwolfgwolf000000000000User-Simple-1.45/lib/User/Simple.pm000444001750001750 3625712160150020 16657 0ustar00gwolfgwolf000000000000use warnings; use strict; package User::Simple; =encoding UTF-8 =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; $id = $usr->id; $session = $usr->session; $otherattrib = $user->otherattrib $ok = $user->set_otherattrib($value); =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 privilege level) via a database, while providing a transparent way to access any other attributes you might define. 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 never 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 other implementations based on SQL::Statement - The user table requires the driver to implement primary keys and NOT NULL/UNIQUE constraints. The functionality is split into two modules, L and L. This module provides the functionality your system will need for any interaction started by the user - Authentication, session management, querying the user's data, changing the password and changing any attributes you define not beginning with C. 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 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 for more information. The C parameter is the name of the table where the user information is stored. If not specified, it defaults to 'user_simple'. C is the number of minutes a user's session should last. Its default is of 30 minutes. C 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! =head2 SESSION CREATION/DELETION 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 end a session: $ok = $usr->end_session; To verify whether we have successfully validated a user: $ok = $usr->is_valid; =head2 QUERYING THE CURRENT USER'S DATA To check the user's core attributes (login and ID): $login = $usr->login; $id = $usr->id; You might add extra columns to the User::Simple table in your database - You will still be able to query for them in the same way: $otherattrib = $user->otherattrib; i.e.: $name = $user->name $login = $usr->login; Note that 'name' and 'level' were core attributes until User::Simple version 1.0 - In order to keep User::Simple as simple and extensible as possible, they became extended attributes. You should not have to modify your code using C anyway, as changes are transparent. Some minor API changes do happen in C, though. Extended attributes are not checked in any way by User::Simple, they are just stored in the database just as they are received - Some DBDs might not even verify they are of the correct data type. As always, if you want to ensure consistence, use a real RDBMS. Of course, beware: if the field does not exist, User::Simple will raise an error and die just as if an unknown method had been called. To change the user's password: $ok = $usr->set_passwd($new_pass); 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): $ok = $usr->set_otherattrib($new_value); =head1 DEPENDS ON L L L (and a suitable L backend) =head1 SEE ALSO L for administrative routines =head1 AUTHOR Gunnar Wolf =head1 COPYRIGHT Copyright 2005-2009 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 $AUTOLOAD; our $VERSION = '1.45'; ###################################################################### # Constructor/destructor 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|adm_level)$/; carp "Unknown argument received: $key"; return undef; } if (defined($init{adm_level})) { carp "adm_level is deprecated and will be dropped in future releases"; } # Default values $init{tbl} = 'user_simple' unless defined $init{tbl}; $init{durat} = 30 unless defined $init{durat}; $init{debug} = 2 unless defined $init{debug}; $init{adm_level} = 1 unless defined $init{adm_level}; 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 FROM $init{tbl}") 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} >= 0 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; } # As we are using autoload, better explicitly leave this as an empty sub sub DESTROY {} ###################################################################### # User validation sub ck_session { my ($self, $sess, $sth, $id, $exp); $self = shift; $sess = shift; $self->_debug(5, "Checking session $sess"); # Before checking anything, make sure we don't retain an expired # authorization $self->{id} = undef; 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->_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"); # Before checking anything, make sure we don't retain an expired # authorization $self->{id} = undef; # 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 { my $salt = _session_salt(); unless ($sth = $self->{db}->prepare("UPDATE $self->{tbl} SET session = ? WHERE id = ?") and $sth->execute(md5_hex(join('-', $salt, 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->_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); $self->{id} = undef; return 1; } ###################################################################### # Accessors, mutators sub is_valid { my $self = shift; return $self->id ? 1 : 0; } sub id { my $self = shift; return $self->{id}; } sub set_passwd { my ($self, $pass, $crypted, $sth); $self = shift; $pass = shift; return undef unless ($self->id and $pass); $crypted = md5_hex($pass, $self->id); $self->_debug(5, sprintf('Setting %s\'s password to %s (%s)', $self->login, $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; } # Other attributes are retreived via AUTOLOAD sub AUTOLOAD { my ($self, $newval, $name, $myclass, $set, $raise_error, $value, $valid); $self = shift; $newval = shift; $name = $AUTOLOAD; # 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 # beginning, or we don't discard a thing $name = $AUTOLOAD; $myclass = ref($self); if (!index($name, $myclass)) { # Substitute in $name from the beginning (0) to the length of the class # name plus two (that is, strip the '::') with nothing. 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'"; # Store the RaiseError, as we don't want to change state outside our # scope $raise_error = $self->{db}{RaiseError}; # 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; 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; return $value; } ###################################################################### # 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; } # 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; } } # Generates a random, printable (ASCII 46-126), 10 character long salt # to mix in the session generation. sub _session_salt { join("", map { chr(rand()*78 + 46) } (0..10)) } 1; User-Simple-1.45/lib/User/Simple000755001750001750 012160150020 16127 5ustar00gwolfgwolf000000000000User-Simple-1.45/lib/User/Simple/Admin.pm000444001750001750 4574012160150020 17704 0ustar00gwolfgwolf000000000000use warnings; use strict; package User::Simple::Admin; =encoding UTF-8 =head1 NAME User::Simple::Admin - User::Simple user administration =head1 SYNOPSIS $ua = User::Simple::Admin->new($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; $id = $ua->id($login); $login = $ua->login($id); $otherattrib = $user->otherattrib($id); $ok = $usr->set_login($id, $login); $ok = $usr->set_passwd($id, $passwd); $ok = $usr->set_otherattrib($id, $value); $ok = $usr->clear_session($id); $id = $ua->new_user(login => $login, passwd => $passwd, [otherattribute => $otherattribute]); $ok = $ua->remove_user($id); =head1 DESCRIPTION User::Simple::Admin manages the administrative part of the User::Simple modules - Please check L for a general overview of these modules and an explanation on what-goes-where. User::Simple::Admin works as a regular administrator would: The module should be instantiated only once for all of your users' administration, if possible, and not instantiated once for each user (in contraposition to L, as it works from each of the users' perspective in independent instantiations). Note also that User::Simple::Admin does b perform the administrative user checks - It is meant to be integrated to your system, and it is your system which should carry out all of the needed authentication checks. =head2 CONSTRUCTOR Administrative actions for User::Simple modules are handled through this Admin object. To instantiate it: $ua = User::Simple::Admin->new($db, $user_table); $db is an open connection to the database where the user data is stored. $user_table is the name of the table that holds the users' data. If we do not yet have the needed DB structure to store the user information, we can use this class method as a constructor as well: $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]); The first one should be used if your DBI handle ($db) points to a real RDBMS, such as PostgreSQL or MySQL. In case you are using a file-based DBD (such as DBD::XBase, DBD::DBM, DBD::CVS or any other which does not use a real RDBMS for storage), use Ccreate_plain_db_structure> instead. What is the difference? In the first case, we will create a table that has internal consistency checks - Some fields are declared NOT NULL, some fields are declared UNIQUE, and the user ID is used as a PRIMARY KEY. This cannot, of course, be achieved using file-based structures, so the integrity can only be maintained from within our scripts. This module does not provide the functionality to modify the created tables by adding columns to it, although methods do exist to access and modify the values stored in those columns (see the L section below), as many DBDs do not implement the ALTER TABLE SQL commands. It does, however, allow you to specify extra fields in the tables at creation time - If you specify a third extra parameter, it will be included as part of the table creation - i.e., you can create a User::Simple table with fields for the user's first and family names and a UNIQUE constraint over them this way: $ua = User::Simple::Admin->create_rdbms_db_structure($db, $user_table, 'firstname varchar(30) NOT NULL, famname varchar(30) NOT NULL, UNIQUE (firstname,famname)'); Keep in mind that the internal fields are C, C, C, C and C. Don't mess with them ;-) Avoid adding any fields starting with C or called as any method defined here, as they will 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, they will be visible but not modifiable from within L - You will only be able to modify them from L. =head2 QUERYING FOR DATABASE READINESS In order to check if the database is ready to be used by this module with the specified table name, use the C class method: $ok = User::Simple::Admin->has_db_structure($db, $user_table); =head2 RETRIEVING THE SET OF USERS %users = $ua->dump_users; Will return a hash with the data regarding the registered users with all of the existing DB fields, in the following form: ( $id1 => { login=>$login1, firstname=>$firstname1, famname=>$famname1 }, $id2 => { login=>$login2, firstname=>$firstname2, famname=>$famname2 }, (...) ) Of course, with the appropriate attributes. The internal attributes C, C and C will not be included in the resulting hashes (you have the C as the hash keys). =head2 CREATING, QUERYING AND MODIFYING USERS $id = $ua->new_user(login => $login, passwd => $passwd, [otherattribute => $otherattribute]); Creates a new user with the specified data. Returns the new user's ID. Only the login is mandatory (as it uniquely identifies the user), unless you have specified extra NOT NULL fields or constraints in the DB. If no password is supplied, the account will be created, but no login will be allowed until one is supplied. $ok = $ua->remove_user($id); Removes the user specified by the ID. $id = $ua->id($login); $login = $ua->login($id); $otherattrib = $user->otherattrib($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 firstname, you can use C<$ua->firstname($ua->id($login));> Of course, beware: if you request for a field which does not exist in your table, User::Simple will raise an error and die just as if an unknown method had been called. $ok = $usr->set_login($id, $login); $ok = $usr->set_passwd($id, $passwd); Modifies the requested attribute of the specified user, setting it to the new value. Except for the login, they can all be set to null values - If the password is set to a null or empty value, the account will be locked (that is, no password will be accepted). The internal attributes C, C and C cannot be directly modified (you have the C as the hash keys). Just as with the accessors, if you have extra columns, you can modify them the same way: $ok = $usr->set_otherattrib($id, $value); i.e. $ok = $usr->set_name($id, $name); =head2 SESSIONS $ok = $usr->clear_session($id); Removes the session which the current user had open, if any. Note that you cannot create a new session through this module - The only way of creating a session is through the C method of L. =head1 DEPENDS ON L =head1 SEE ALSO L for the regular user authentication routines (that is, to use the functionality this module adimisters) =head1 AUTHOR Gunnar Wolf =head1 COPYRIGHT Copyright 2005-2009 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); our $AUTOLOAD; ###################################################################### # Constructor/destructor 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; } # As we are using autoload, better explicitly leave this as an empty sub sub DESTROY {} ###################################################################### # Creating the needed structure sub create_rdbms_db_structure { my ($class, $db, $table, $extra_sql, $sql, $sth); $class = shift; $db = shift; $table = shift; $extra_sql = shift || ''; # Avoid warnings on undef # Remember some DBD backends don't implement 'serial' - Use 'integer' and # some logic on our side instead $sql = sprintf('CREATE TABLE %s ( id serial PRIMARY KEY, login varchar(100) NOT NULL UNIQUE, passwd char(32), session char(32) UNIQUE, session_exp varchar(20) %s)', $table, $extra_sql ? ", $extra_sql" : ''); unless ($sth = $db->prepare($sql) and $sth->execute) { carp "Could not create database structure using table $table"; return undef; } return $class->new($db, $table); } sub create_plain_db_structure { my ($class, $db, $table, $extra_sql, $sql, $sth); $class = shift; $db = shift; $table = shift; $extra_sql = shift || ''; # Avoid warnings on undef # Remember some DBD backends don't implement 'serial' - Use 'integer' and # some logic on our side instead $sql = sprintf('CREATE TABLE %s ( id integer, login varchar(100), passwd char(32), session char(32), session_exp varchar(20) %s)', $table, $extra_sql ? ", $extra_sql" : ''); unless ($sth = $db->prepare($sql) 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, passwd, session, session_exp FROM $table") and $sth->execute); return 0; } ###################################################################### # Retrieving information sub dump_users { my ($self, $order, $sth, %users); $self = shift; unless ($sth = $self->{db}->prepare("SELECT * FROM $self->{tbl}") and $sth->execute) { carp 'Could not query for the user list'; return undef; } $sth->execute; # Keep to myself the internal fields, translate the fieldnames to lowercase while (my $row = $sth->fetchrow_hashref) { for my $in_field (keys %$row) { my ($id); # Some DBDs are case-insensitive towards Perl (we can query/modify # the columns case-insensitively), but internally are case # sensitive. Gah, we work around that to provide the much more # common lowercase fields... This might still have some problems # attached, please tell me if it breaks for you. for my $case (qw(id ID Id iD)) { if (exists $row->{$case}) { $id = $row->{$case}; last; } } carp "Did not find an ID field - Cannot continue" unless $id; my $out_field = lc($in_field); next if $out_field =~ /^(?:id|session|session_exp)$/; $users{$id}{$out_field} = $row->{$in_field}; } } 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 undef unless $id; return $self->_get_field($id, 'login'); } ###################################################################### # Modifying information # We need only the mutators for the special case fields - Handle everything # else via AUTOLOAD sub set_login { my ($self, $id, $new, $sth, $ret, $used); $self = shift; $id = shift; $new = shift; return undef unless $id; # Setting the login to the current login? Noop doomed to fail, make it look # as a success $used = $self->id($new); return 1 if $used and $used == $self->id($self->login($id)); if ($used) { carp "The requested login is already used (ID $used)."; return undef; } return $self->_set_field($id, 'login', $new); } sub set_passwd { my ($self, $id, $new, $crypted, $sth); $self = shift; $id = shift; $new = shift; return undef unless $id; # No password was supplied? Prevent anybody from logging in with a blank # password (nothing will get a MD5 equal to this string). if ($new) { $crypted = md5_hex($new, $id); } else { $crypted = '-!- Disabled -!-'; } return $self->_set_field($id, 'passwd', $crypted); } sub clear_session { my ($self, $id); $self = shift; $id = shift; return undef unless $id; return ($self->_set_field($id,'session','') && $self->_set_field($id, 'sesson_exp', '')); } # Other attributes will be retreived via AUTOLOAD sub AUTOLOAD { my ($self, $id, $new, $name, $myclass, $set, $field); $self = shift; $id = shift; $new = shift; # 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 # beginning, or we don't discard a thing $name = $AUTOLOAD; $myclass = ref($self); if (!index($name, $myclass)) { # Substitute in $name from the beginning (0) to the length of the class # name plus two (that is, strip the '::') with nothing. substr($name,0,length($myclass)+2,''); } return undef unless $id; # Do we know how to handle the request? if ($name =~ /^set_(.+)$/) { $set = 1; $field = $1; } else { $field = $name; } if ($set) { if ($field =~ /^(id|session|sesion_exp)$/) { die "Attempt to modify internal field $field"; } return $self->_set_field($id, $field, $new); } return $self->_get_field($id, $field); } ###################################################################### # User creation and removal sub new_user { my ($self, %param, $id, $db, $orig_state, $has_transact); $self = shift; %param = @_; # We will use the database handler over and over - Get a shortcut. $db = $self->{db}; # If available, we will do all this work inside a transaction. Sadly, not # every DBD provides such a facility - By trying to begin_work and # then commit on an empty transaction, we can check if this DBD does # provide it. eval { $db->begin_work; $db->commit; }; $has_transact = $@ ? 0 : 1; # We require a login - Check if we got one. unless ($param{login}) { carp 'A login is required for user creation'; return undef; } # Check first if we have a registered user with this same login if (my $id = $self->id($param{login})) { carp "There is already a user registered with desired login (ID $id)"; return undef; } $orig_state = $db->{RaiseError}; eval { my ($sth); $db->begin_work if $has_transact; $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 a DBD backend which # does not implement unicity, right? :) $sth = $db->prepare("SELECT id FROM $self->{tbl} ORDER BY id desc"); $sth->execute; ($id) = $sth->fetchrow_array; $id++; $sth = $db->prepare("INSERT INTO $self->{tbl} (id, login) VALUES (?, ?)"); $sth->execute($id, $param{login}); # But just to be sure, lets retreive the ID from the login. $id = $self->id($param{login}); $self->set_passwd($id, $param{passwd}); # Set all the other fields we got as parameters for my $field (keys %param) { next if $field =~ /^(login|passwd)$/; # Already handled. $self->_set_field($id, $field, $param{$field}); } $db->commit if $has_transact; $db->{RaiseError} = $orig_state; }; if ($@) { if ($has_transact) { $db->rollback; } else { carp 'User creation was not successful. This DBD does not support'. ' transactions - You might have a half-created user!'; } $db->{RaiseError} = $orig_state; carp "Could not create specified user"; return undef; } return $id; } 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 ($self->_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 ($self->_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 ($self, $field, $raise_error); $self = shift; $field = shift; # If it is one of our internal fields, return successfully right away return 1 if $field =~ /^(login)$/; # Explicitly disallow direct passwd handling return 0 if $field eq 'passwd'; # Allow only valid fields - alphanumeric characters or underscores $field =~ /^[\w\d\_]+$/ or return 0; $raise_error = $self->{db}{RaiseError}; eval { my $sth; $self->{db}{RaiseError} = 1; $sth = $self->{db}->prepare("SELECT $field FROM $self->{tbl}"); $sth->execute; }; if ($@) { # If an error was raised, the field does not exist - Return 0 # Restore the RaiseError $self->{db}{RaiseError} = $raise_error; return 0; } # The field is valid! Return 1. # Restore the RaiseError $self->{db}{RaiseError} = $raise_error; return 1; } 1; User-Simple-1.45/examples000755001750001750 012160150020 15030 5ustar00gwolfgwolf000000000000User-Simple-1.45/examples/user-simple-admin000444001750001750 3114512160150020 20467 0ustar00gwolfgwolf000000000000#!/usr/bin/perl =head1 NAME user-simple-admin - Example script to administer a User::Simple database =head1 SYNOPSIS What you always have to specify: - How to get to the information: a DSN (--dsn), the table name (--tbl), and probably the database user (--dbuser) and password (--dbpass) - An action to perform: --new_user, --mod_user, --remove_user - The attributes needed for your query (--login, --name, --level, --password) - Optionally, to get a listing of the users in the database, use --dump_users Table creation: user-simple-admin --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple --dbuser useradmin --dbpass s3kr3t --create_plain user-simple-admin --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple --dbuser useradmin --dbpass s3kr3t --create_rdbms User creation example: user-simple-admin --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple --dbuser useradmin --dbpass s3kr3t --new_user --login joe --name 'Joe Schmoe' --passwd mys3kr17 --level 5 User remotion: user-simple-admin --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple--dbuser useradmin --dbpass s3kr3t --remove_user --login john User modification: user-simple-admin --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple --dbuser useradmin --dbpass s3kr3t --new_user --login joe --name 'Joe A. Schmoe' --passwd dont_forget_it --level 2 =head1 DESCRIPTION This script gives you access from the command line to the main User::Simple::Admin functionality. Please note that it has been written more as an example than as a script you will use in your day to day administration - But if it suits you, well... :) The script is made to be run non-interactively, taking all of its input via the command line (using the standard L syntax), and signalling either success or failure as the exit code (as always, 0 means success, and any other thing means failure). About the L syntax, in a nutshell: You can specify the options to the script in any order, as long as you keep the switches next to their values (that is, C<--tbl tablename --dump_users> is the same as C<--dump_users --tbl tablename>, but it is not the same as C<--tbl --dump_users tablename>. You can use the shortest possible not ambiguous string for each of the switches (i.e. C<--remove_user> is equivalent to C<--r>). First of all, you have to get the script to get to the users' data - In order to do so, you have to specify a DSN (a DBI Data Source Name - A bit obscure, yes, I should replace it to something more intuitive as soon as I have some time to do so) and the name of the table where the information is located. This should be done with the C<--dsn> and C<--tbl> options. Probably you will also specify a database user name and password - do so using the C<--dbuser> and C<--dbpass> options. =head2 Table creation If you specify C<--create_plain> or C<--create_rdbms>, the User::Admin::Simple object will be instantiated by creating (instead of just accessing) the specified table. Beware, as attempting to create an already existing table will not work! C<--create_rdbms> should be used whenever possible (this is, whenever you are using a real RDBMS behind User::Simple, in contraposition to a simple file-based structure such as DBD::XBase, DBD::CSV or similar ones). If you are using a file-based structure, use C<--create_plain> instead. For further details, refer to the L manual. =head2 User creation To create a new user, specify C<--new_user> and give the desired user information - The only required option is C<--login>, as it is the unique descriptor for this user - The other available switches are C<--name>, C<--passwd> and C<--level>. Again, refer to L for further details. If you do not specify a password upon user creation, the account will be created but access to it will be disabled until a password is set. =head2 User remotion Use C<--remove_user>. You have to specify the C<--login> you will be removing - Don't specify any other data; the script will refuse to work if you specify any of the other data options. =head2 User modification Use C<--mod_user>. You need to specify the C<--login> you are referring to. You cannot change a user's login, it is an immutable field. You can specify one or more of the C<--name>, C<--passwd> and C<--level> data options. =head2 Querying If you specify C<--dump_users>, a user listing will be returned to you. Please note that you can ask for C<--dump_users> when performing other opertions (i.e. creation, remotion) - It will be run as the last operation, however, if the operation fails, the users list will not be dumped. =head2 Other switches C<--quiet> supresses all output (including errors produced by this script, the errors generated by User::Simple::Admin, DBI or whatever else will still be sent) - Only the users dump will be printed. C<--verbose> will give status debug information you will very seldom require. =head2 Examples Create a table in a remote PostgreSQL database and insert a user in it: user-simple-admin --dsn 'dbi:Pg:dbname=userdb;host=dbserver' --dbuser dbadmin --dbpass dbs3kr37 --tbl test --create_rdbms --new_user --login someone --name 'A random user' Change that user's password in order to enable the account user-simple-admin --dsn 'dbi:Pg:dbname=userdb;host=dbserver' --dbuser dbadmin --dbpass dbs3kr37 --tbl test --mod_user --login someone --passwd thepassword Remove that user user-simple-admin --dsn 'dbi:Pg:dbname=userdb;host=dbserver' --dbuser dbadmin --dbpass dbs3kr37 --tbl test --remove_user --login someone Get the users listing in a DBD::XBase database user-simple-admin --dsn 'dbi:XBase:/home/user/databases/users' --tbl user_simple --dump_users =head1 DEPENDS ON L (and a suitable L backend) L L =head1 SEE ALSO L and L =head1 AUTHOR Gunnar Wolf =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 lib qw(/home/gwolf/User-Simple/lib); use strict; use warnings; use Carp; use DBI; use Getopt::Long; use User::Simple::Admin; my (%conf, $db, $ua); # Default values, to be overwritten by Getopt::Long %conf = ( dsn => 'DBI:XBase:/tmp/user_simple', dbtable => 'user_simple', dbuser => undef, dbpass => undef, verbose => 1, create_plain => undef, create_rdbms => undef, new_user => undef, remove_user => undef, mod_user => undef, login => undef, passwd => undef, name => undef, level => undef ); GetOptions ('dsn=s' => \$conf{dsn}, 'tbl=s' => \$conf{dbtable}, 'dbuser=s' => \$conf{dbuser}, 'dbpass=s' => \$conf{dbpass}, 'create_plain' => \$conf{create_plain}, 'create_rdbms' => \$conf{create_rdbms}, 'dump_users' => \$conf{dump_users}, 'new_user' => \$conf{new_user}, 'remove_user' => \$conf{remove_user}, 'mod_user' => \$conf{mod_user}, 'login=s' => \$conf{login}, 'passwd=s' => \$conf{passwd}, 'name=s' => \$conf{name}, 'level=i' => \$conf{level}, 'quiet' => sub {$conf{verbose} = 0}, 'verbose' => sub {$conf{verbose} = 2} ) || usage_err(); debug(2,'Options parsed correctly'); #use Data::Dumper; warn Dumper \%conf; # Check we are requested to carry out at least one operation - Finish # otherwise. Check as well for mutually exclusive options usage_err() unless (# Operations $conf{create_plain} or $conf{create_rdbms} or $conf{new_user} or $conf{remove_user} or $conf{mod_user} or $conf{dump_users} or # Mutually exclusive ($conf{create_plain} and $conf{create_rdbms}) or ($conf{new_user} and $conf{remove_user}) or ($conf{new_user} and $conf{mod_user}) or ($conf{mod_user} and $conf{remove_user}) ); # Connect to the DB $db = DBI->connect($conf{dsn},$conf{dbuser},$conf{dbpass},{AutoCommit => 1}); ref($db) or dbconn_err(); debug(2,'Database connection established'); # get a User::Simple::Admin instance (creating the structure if we were # requested to) if ($conf{create_rdbms}) { $ua = User::Simple::Admin->create_rdbms_db_structure($db, $conf{dbtable}); } elsif ($conf{create_plain}) { $ua = User::Simple::Admin->create_plain_db_structure($db, $conf{dbtable}); } else { $ua = User::Simple::Admin->new($db, $conf{dbtable}); } ref($ua) or useradmin_err(); debug(2,'User::Simple::Admin instance established'); # Ok, everything is now ready - Do what we were told to do! new_user() if $conf{new_user}; remove_user() if $conf{remove_user}; mod_user() if $conf{mod_user}; dump_users() if $conf{dump_users}; debug(2,'Program finished successfully'); exit 0; sub new_user { # For new user creation, we only require a login usage_err() unless $conf{login}; unless ($ua->new_user($conf{login}, $conf{name}, $conf{passwd}, $conf{level})) { newuser_err(); } } sub remove_user { # For user remotion, we require a login - But name, password and level # should not be specified. my ($id); usage_err() if ($conf{name} or $conf{passwd} or $conf{level}); $id = $ua->id($conf{login}) or no_user_err(); $ua->remove_user($id) or remove_err(); } sub mod_user { # For user modification, we require at least one of name, password and # level - and we require login _not_ to be set. my ($id); usage_err() unless ($conf{name} or $conf{passwd} or $conf{level} or !$conf{login}); $id = $ua->id($conf{login}) or no_user_err(); if (defined $conf{name}) { $ua->set_name($id, $conf{name}) or mod_err(); } if (defined $conf{level}) { $ua->set_level($id, $conf{level}) or mod_err(); } if (defined $conf{passwd}) { $ua->set_passwd($id, $conf{passwd}) or mod_err(); } } sub dump_users { my %users = $ua->dump_users; # Print the header first printf("%-4s %-15s %-30s %-5s\n", 'ID', 'Login', 'Name', 'Level'); print '='x60,"\n"; for my $user (sort {$a<=>$b} keys %users) { printf("%4d %-15s %-30s %5d\n", $user, $users{$user}{login}, $users{$user}{name}, $users{$user}{level}); } } sub usage_err { my $progname = $0; $progname =~ s!^.+/([^/]+)$!$1!; debug(1,<<"USAGE"); $progname: Incorrect invocation! What you always have to specify: - How to get to the information: a DSN (--dsn), the table name (--tbl), and probably the database user (--dbuser) and password (--dbpass) - An action to perform: --new_user, --mod_user, --remove_user - The attributes needed for your query (--login, --name, --level, --password) - Optionally, to get a listing of the users in the database, use --dump_users User creation example: $progname --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple --dbuser useradmin --dbpass s3kr3t --new_user --login joe --name 'Joe Schmoe' --passwd mys3kr17 --level 5 User remotion: $progname --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple--dbuser useradmin --dbpass s3kr3t --remove_user --login john User modification: $progname --dsn 'dbi:Pg:dbname=database;host=some.host.org' --table user_simple --dbuser useradmin --dbpass s3kr3t --new_user --login joe --name 'Joe A. Schmoe' --passwd dont_forget_it --level 2 Please check the full documentation for further details: perldoc $0 USAGE exit 1; } sub dbconn_err { debug(1,<<"DBERR"); Could not open DB connection - Please check that the provided data source (dsn), user (dbuser) and password (dbpass) are correct. DBERR exit 2; } sub useradmin_err { debug(1,<<"USERADMIN"); Could not create User::Simple::Admin - This might have happened because you requested to create a table with the same name an existing one, or because you asked to use a table which does not yet exist. USERADMIN exit 3; } sub newuser_err { debug(1,<<"NEWUSER"); Could not create the requested user - This can be because the requested login is already registered. NEWUSER exit 4; } sub no_user_err { debug(1,<<"NOUSER"); Could not find the requested user in the database - The specified login might be wrong, or the user might have been removed. NOUSER exit 5; } sub remove_err { debug(1,<<"REMOVE"); Could not remove the requested user from the database - It might be being referred to from another table if you have such a setup. REMOVE exit 6; } sub mod_err { debug(1,<<"MODIF"); Could not modify the requested user in the database MODIF exit 7; } sub debug { my $level = shift; return unless $conf{verbose} >= $level; warn @_,"\n"; }