From 0d6c8cad711ecec432f98f1f613d2d6c1f1ad46b Mon Sep 17 00:00:00 2001 From: David Oswald Date: Mon, 18 Jun 2012 23:41:09 -0700 Subject: [PATCH] CUDBI::Roles added, along with tests. Next: RolePrivileges, and updates to User.pm --- MANIFEST | 2 + Makefile.PL | 4 + lib/Class/User/DBI.pm | 55 ++++---- lib/Class/User/DBI/DB.pm | 37 +++++- lib/Class/User/DBI/Domains.pm | 21 ++-- lib/Class/User/DBI/Privileges.pm | 22 ++-- lib/Class/User/DBI/Roles.pm | 129 ++++++++++--------- t/11-load.t | 2 +- t/15-class_tests.t | 1 - t/17-cudbi_db.t | 20 +-- t/19-cudbi_roles.t | 210 +++++++++++++++++++++++++++++++ 11 files changed, 369 insertions(+), 134 deletions(-) create mode 100644 t/19-cudbi_roles.t diff --git a/MANIFEST b/MANIFEST index fe9df02..1d6722d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3,6 +3,7 @@ lib/Class/User/DBI.pm lib/Class/User/DBI/DB.pm lib/Class/User/DBI/Privileges.pm lib/Class/User/DBI/Domains.pm +lib/Class/User/DBI/Roles.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP @@ -19,6 +20,7 @@ t/15-class_tests.t t/16-cudbi_privileges.t t/17-cudbi_db.t t/18-cudbi_domains.t +t/19-cudbi_roles.t scripts/cudbi-configdb META.json META.yml diff --git a/Makefile.PL b/Makefile.PL index 1ee3985..eeeed84 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -44,6 +44,10 @@ WriteMakefile( file => 'lib/Class/User/DBI/Domains.pm', version => '0.01_002', }, + 'Class::User::DBI::Roles' => { + file => 'lib/Class/User/DBI/Domains.pm', + version => '0.01_002', + }, }, version => '0.02', resources => { diff --git a/lib/Class/User/DBI.pm b/lib/Class/User/DBI.pm index edc463c..7456949 100644 --- a/lib/Class/User/DBI.pm +++ b/lib/Class/User/DBI.pm @@ -12,7 +12,7 @@ use List::MoreUtils qw( any ); use Authen::Passphrase::SaltedSHA512; -use Class::User::DBI::DB qw( %USER_QUERY _db_run_ex ); +use Class::User::DBI::DB qw( %USER_QUERY db_run_ex ); our $VERSION = '0.01_002'; $VERSION = eval $VERSION; ## no critic (eval) @@ -45,16 +45,16 @@ sub _db_conn { sub update_email { my ( $self, $new_email ) = @_; return if !$self->exists_user; - my $sth = $self->_db_run( $USER_QUERY{SQL_update_email}, - $new_email, $self->userid ); + my $sth = + $self->_db_run( $USER_QUERY{SQL_update_email}, $new_email, + $self->userid ); return $new_email; } sub update_username { my ( $self, $new_username ) = @_; return if !$self->exists_user; - my $sth = - $self->_db_run( $USER_QUERY{SQL_update_username}, + my $sth = $self->_db_run( $USER_QUERY{SQL_update_username}, $new_username, $self->userid ); return $new_username; } @@ -82,16 +82,15 @@ sub validated { sub _db_run { my ( $self, $sql, @ex_params ) = @_; my $conn = $self->_db_conn; - # We import _db_run_ex() from Class::User::DBI::DB. - return _db_run_ex( $conn, $sql, @ex_params ); + + # We import db_run_ex() from Class::User::DBI::DB. + return db_run_ex( $conn, $sql, @ex_params ); } # Fetches all IP's that are whitelisted for the user. sub fetch_valid_ips { my $self = shift; - my $sth = - $self->_db_run( $USER_QUERY{SQL_fetch_valid_ips}, - $self->userid ); + my $sth = $self->_db_run( $USER_QUERY{SQL_fetch_valid_ips}, $self->userid ); my @rv; while ( defined( my $row = $sth->fetchrow_arrayref ) ) { if ( defined $row->[0] ) { @@ -105,8 +104,7 @@ sub fetch_valid_ips { sub fetch_credentials { my $self = shift; my $sth = - $self->_db_run( $USER_QUERY{SQL_fetch_credentials}, - $self->userid ); + $self->_db_run( $USER_QUERY{SQL_fetch_credentials}, $self->userid ); my ( $salt_hex, $pass_hex, $ip_required ) = $sth->fetchrow_array; return if not defined $salt_hex; # User wasn't found. my @valid_ips = $self->fetch_valid_ips; @@ -153,17 +151,15 @@ sub exists_user { my $self = shift; return $self->{exists_user} if $self->{exists_user}; # Only query if we have to. - my $sth = $self->_db_run( $USER_QUERY{SQL_exists_user}, - $self->userid ); + my $sth = $self->_db_run( $USER_QUERY{SQL_exists_user}, $self->userid ); return $sth->fetchrow_array; # Will be undef if user doesn't exist. } # May be useful later on if we add user information. sub load_profile { my $self = shift; - my $sth = $self->_db_run( $USER_QUERY{SQL_load_profile}, - $self->userid ); - my $hr = $sth->fetchrow_hashref; + my $sth = $self->_db_run( $USER_QUERY{SQL_load_profile}, $self->userid ); + my $hr = $sth->fetchrow_hashref; return $hr; } @@ -181,8 +177,8 @@ sub add_ips { # Prepare the userid,ip bundles for our insert query. my @execution_param_bundles = map { [ $self->userid, unpack( 'N', inet_aton($_) ) ] } @ips_to_insert; - my $sth = $self->_db_run( $USER_QUERY{SQL_add_ips}, - @execution_param_bundles ); + my $sth = + $self->_db_run( $USER_QUERY{SQL_add_ips}, @execution_param_bundles ); return scalar @ips_to_insert; # Return a count of IP's inserted. } @@ -196,8 +192,8 @@ sub delete_ips { my @ips_for_deletion = grep { exists $found{$_} } @ips; my @execution_param_bundles = map { [ $self->userid, unpack( 'N', inet_aton($_) ) ] } @ips_for_deletion; - my $sth = $self->_db_run( $USER_QUERY{SQL_delete_ips}, - @execution_param_bundles ); + my $sth = + $self->_db_run( $USER_QUERY{SQL_delete_ips}, @execution_param_bundles ); return scalar @ips_for_deletion; # Return a count of IP's deleted. } @@ -216,7 +212,7 @@ sub add_user { my $ips_aref = exists( $userinfo->{ips_aref} ) ? $userinfo->{ips_aref} - : $userinfo->{ips}; # Detect later if missing. + : $userinfo->{ips}; # Detect later if missing. return if $ip_req && !ref $ips_aref eq 'ARRAY'; @@ -261,8 +257,7 @@ sub update_password { my $hash_hex = $passgen->hash_hex; $self->_db_conn->txn( fixup => sub { - my $sth = - $_->prepare( $USER_QUERY{SQL_update_password} ); + my $sth = $_->prepare( $USER_QUERY{SQL_update_password} ); $sth->execute( $salt_hex, $hash_hex, $self->userid ); } ); @@ -274,12 +269,9 @@ sub delete_user { return if !$self->exists_user; # undef if user wasn't in the DB. $self->_db_conn->txn( fixup => sub { - my $sth = - $_->prepare( - $USER_QUERY{SQL_delete_user_users} ); + my $sth = $_->prepare( $USER_QUERY{SQL_delete_user_users} ); $sth->execute( $self->userid ); - my $sth2 = - $_->prepare( $USER_QUERY{SQL_delete_user_ips} ); + my $sth2 = $_->prepare( $USER_QUERY{SQL_delete_user_ips} ); $sth2->execute( $self->userid ); } ); @@ -289,7 +281,6 @@ sub delete_user { return 1; } - =cut sub fetch_roles { my $self = shift; @@ -330,6 +321,7 @@ sub delete_roles { return scalar @prepared_deletes; } =cut + # Class methods sub list_users { @@ -346,7 +338,8 @@ sub configure_db { SQL_configure_db_user_ips ); -# Deleted: SQL_configure_db_user_roles + + # Deleted: SQL_configure_db_user_roles foreach my $sql_key (@SQL_keys) { $conn->run( fixup => sub { diff --git a/lib/Class/User/DBI/DB.pm b/lib/Class/User/DBI/DB.pm index a8116f6..816fcce 100644 --- a/lib/Class/User/DBI/DB.pm +++ b/lib/Class/User/DBI/DB.pm @@ -6,14 +6,20 @@ use warnings; use 5.008; use Exporter; -our @ISA = qw( Exporter ); ## no critic (ISA) -our @EXPORT = qw( _db_run_ex ); -our @EXPORT_OK = qw( %USER_QUERY %PRIV_QUERY %DOM_QUERY _db_run_ex ); +our @ISA = qw( Exporter ); ## no critic (ISA) +our @EXPORT = qw( db_run_ex ); ## no critic (export) +our @EXPORT_OK = qw( + %USER_QUERY + %PRIV_QUERY + %DOM_QUERY + %ROLE_QUERY + _db_run_ex +); use Carp; our $VERSION = '0.01_003'; -$VERSION = eval $VERSION; ## no critic (eval) +$VERSION = eval $VERSION; ## no critic (eval) # ---------------- SQL queries for Class::User::DBI -------------------------- @@ -111,6 +117,27 @@ END_SQL SQL_list_domains => 'SELECT * FROM cud_domains', ); +#----------------- Queries for Class::User::DBI::Domains --------------------- + +our %ROLE_QUERY = ( + SQL_configure_db_cud_roles => << 'END_SQL', + CREATE TABLE IF NOT EXISTS cud_roles ( + role VARCHAR(24) NOT NULL, + description VARCHAR(40) NOT NULL DEFAULT '', + PRIMARY KEY (role) + ) +END_SQL + SQL_exists_role => 'SELECT role FROM cud_roles WHERE role = ?', + SQL_add_roles => + 'INSERT INTO cud_roles ( role, description ) VALUES ( ?, ? )', + SQL_delete_roles => 'DELETE FROM cud_roles WHERE role = ?', + SQL_get_role_description => + 'SELECT description FROM cud_roles WHERE role = ?', + SQL_update_role_description => + 'UPDATE cud_roles SET description = ? WHERE role = ?', + SQL_list_roles => 'SELECT * FROM cud_roles', +); + # ------------------------------ Functions ----------------------------------- # Prepares and executes a database command using DBIx::Connector's 'run' @@ -123,7 +150,7 @@ END_SQL # [ first param list ], [ second param list ], ... # ); -sub _db_run_ex { +sub db_run_ex { my ( $conn, $sql, @ex_params ) = @_; croak ref($conn) . ' is not a DBIx::Connector.' if !$conn->isa('DBIx::Connector'); diff --git a/lib/Class/User/DBI/Domains.pm b/lib/Class/User/DBI/Domains.pm index bed6013..bbccaf7 100644 --- a/lib/Class/User/DBI/Domains.pm +++ b/lib/Class/User/DBI/Domains.pm @@ -1,3 +1,4 @@ +## no critic (RCS,VERSION) package Class::User::DBI::Domains; use strict; @@ -5,7 +6,7 @@ use warnings; use Carp; -use Class::User::DBI::DB qw( _db_run_ex %DOM_QUERY ); +use Class::User::DBI::DB qw( db_run_ex %DOM_QUERY ); our $VERSION = '0.01_003'; $VERSION = eval $VERSION; ## no critic (eval) @@ -46,13 +47,13 @@ sub _db_conn { # returns 0 or 1. sub exists_domain { my ( $self, $domain ) = @_; - croak "Must pass a defined value in domain test." + croak 'Must pass a defined value in domain test.' if !defined $domain; - croak "Must pass a non-empty value in domain test." + croak 'Must pass a non-empty value in domain test.' if !length $domain; return 1 if exists $self->{domains}{$domain}; my $sth = - _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_exists_domain}, $domain ); + db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_exists_domain}, $domain ); my $result = defined $sth->fetchrow_array; $self->{domains}{$domain}++ if $result; # Cache the result. return $result; @@ -74,7 +75,7 @@ sub add_domains { # This change is intended to propagate back to @domains_to_insert. $dom_bundle->[1] = q{} if !$dom_bundle->[1]; } - my $sth = _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_add_domains}, + my $sth = db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_add_domains}, @domains_to_insert ); return scalar @domains_to_insert; } @@ -85,11 +86,11 @@ sub delete_domains { my ( $self, @domains ) = @_; my @domains_to_delete; foreach my $domain (@domains) { - next if !$domain or !$self->exists_domain($domain); + next if !$domain || !$self->exists_domain($domain); push @domains_to_delete, [$domain]; delete $self->{domains}{$domain}; # Remove it from the cache too. } - my $sth = _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_delete_domains}, + my $sth = db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_delete_domains}, @domains_to_delete ); return scalar @domains_to_delete; } @@ -102,7 +103,7 @@ sub get_domain_description { croak 'Specified domain must exist.' if !$self->exists_domain($domain); my $sth = - _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_get_domain_description}, + db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_get_domain_description}, $domain ); return ( $sth->fetchrow_array )[0]; } @@ -118,7 +119,7 @@ sub update_domain_description { croak 'Must specify a description (q{} is ok too).' if !defined $description; my $sth = - _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_update_domain_description}, + db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_update_domain_description}, $description, $domain ); return 1; } @@ -126,7 +127,7 @@ sub update_domain_description { # Returns an array of pairs (AoA). Pairs are [ domain, description ],... sub fetch_domains { my $self = shift; - my $sth = _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_list_domains} ); + my $sth = db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_list_domains} ); my @domains = @{ $sth->fetchall_arrayref }; return @domains; } diff --git a/lib/Class/User/DBI/Privileges.pm b/lib/Class/User/DBI/Privileges.pm index 176d48b..67efd9c 100644 --- a/lib/Class/User/DBI/Privileges.pm +++ b/lib/Class/User/DBI/Privileges.pm @@ -1,3 +1,4 @@ +## no critic (RCS,VERSION) package Class::User::DBI::Privileges; use strict; @@ -5,7 +6,7 @@ use warnings; use Carp; -use Class::User::DBI::DB qw( _db_run_ex %PRIV_QUERY ); +use Class::User::DBI::DB qw( db_run_ex %PRIV_QUERY ); our $VERSION = '0.01_003'; $VERSION = eval $VERSION; ## no critic (eval) @@ -46,13 +47,13 @@ sub _db_conn { # returns 0 or 1. sub exists_privilege { my ( $self, $privilege ) = @_; - croak "Must pass a defined value in privilege test." + croak 'Must pass a defined value in privilege test.' if !defined $privilege; - croak "Must pass a non-empty value in privilege test." + croak 'Must pass a non-empty value in privilege test.' if !length $privilege; return 1 if exists $self->{privileges}{$privilege}; my $sth = - _db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_exists_privilege}, + db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_exists_privilege}, $privilege ); my $result = defined $sth->fetchrow_array; $self->{privileges}{$privilege}++ if $result; # Cache the result. @@ -78,7 +79,7 @@ sub add_privileges { # This change is intended to propagate back to @privs_to_insert. $priv_bundle->[1] = q{} if !$priv_bundle->[1]; } - my $sth = _db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_add_privileges}, + my $sth = db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_add_privileges}, @privs_to_insert ); return scalar @privs_to_insert; } @@ -89,11 +90,11 @@ sub delete_privileges { my ( $self, @privileges ) = @_; my @privs_to_delete; foreach my $privilege (@privileges) { - next if !$privilege or !$self->exists_privilege($privilege); + next if !$privilege || !$self->exists_privilege($privilege); push @privs_to_delete, [$privilege]; delete $self->{privileges}{$privilege}; # Remove it from the cache too. } - my $sth = _db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_delete_privileges}, + my $sth = db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_delete_privileges}, @privs_to_delete ); return scalar @privs_to_delete; } @@ -106,7 +107,7 @@ sub get_privilege_description { croak 'Specified privilege must exist.' if !$self->exists_privilege($privilege); my $sth = - _db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_get_privilege_description}, + db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_get_privilege_description}, $privilege ); return ( $sth->fetchrow_array )[0]; } @@ -122,8 +123,7 @@ sub update_privilege_description { croak 'Must specify a description (q{} is ok too).' if !defined $description; my $sth = - _db_run_ex( $self->_db_conn, - $PRIV_QUERY{SQL_update_privilege_description}, + db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_update_privilege_description}, $description, $privilege ); return 1; } @@ -131,7 +131,7 @@ sub update_privilege_description { # Returns an array of pairs (AoA). Pairs are [ privilege, description ],... sub fetch_privileges { my $self = shift; - my $sth = _db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_list_privileges} ); + my $sth = db_run_ex( $self->_db_conn, $PRIV_QUERY{SQL_list_privileges} ); my @privileges = @{ $sth->fetchall_arrayref }; return @privileges; } diff --git a/lib/Class/User/DBI/Roles.pm b/lib/Class/User/DBI/Roles.pm index ae7ea87..a5dc494 100644 --- a/lib/Class/User/DBI/Roles.pm +++ b/lib/Class/User/DBI/Roles.pm @@ -1,3 +1,4 @@ +## no critic (RCS,VERSION) package Class::User::DBI::Roles; use strict; @@ -5,7 +6,7 @@ use warnings; use Carp; -use Class::User::DBI::DB qw( _db_run_ex %DOM_QUERY ); +use Class::User::DBI::DB qw( db_run_ex %ROLE_QUERY ); our $VERSION = '0.01_003'; $VERSION = eval $VERSION; ## no critic (eval) @@ -15,8 +16,6 @@ $VERSION = eval $VERSION; ## no critic (eval) # This may be two classes: One for the role/description table, and one for the # roles/privileges table. - - # Class methods. sub new { @@ -25,7 +24,7 @@ sub new { croak 'Constructor called without a DBIx::Connector object.' if !ref $conn || !$conn->isa('DBIx::Connector'); $self->{_db_conn} = $conn; - $self->{domains} = {}; + $self->{roles} = {}; return $self; } @@ -35,7 +34,7 @@ sub configure_db { if !ref $conn || !$conn->isa('DBIx::Connector'); $conn->run( fixup => sub { - $_->do( $DOM_QUERY{SQL_configure_db_cud_domains} ); + $_->do( $ROLE_QUERY{SQL_configure_db_cud_roles} ); } ); return 1; @@ -49,93 +48,93 @@ sub _db_conn { } # Usage: -# $dom->exists_domain( $domain ); +# $role->exists_role( $some_role ); # returns 0 or 1. -sub exists_domain { - my ( $self, $domain ) = @_; - croak "Must pass a defined value in domain test." - if !defined $domain; - croak "Must pass a non-empty value in domain test." - if !length $domain; - return 1 if exists $self->{domains}{$domain}; - my $sth = - _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_exists_domain}, $domain ); +sub exists_role { + my ( $self, $role ) = @_; + croak 'Must pass a defined value in role test.' + if !defined $role; + croak 'Must pass a non-empty value in role test.' + if !length $role; + return 1 if exists $self->{roles}{$role}; + my $sth = db_run_ex( $self->_db_conn, $ROLE_QUERY{SQL_exists_role}, $role ); my $result = defined $sth->fetchrow_array; - $self->{domains}{$domain}++ if $result; # Cache the result. + $self->{roles}{$role}++ if $result; # Cache the result. return $result; } # Usage: -# $dom->add_domains( [ qw( domain description ) ], [...] ); -# Returns the number of domains actually added. +# $role->add_roles( [ qw( role description ) ], [...] ); +# Returns the number of roles actually added. -sub add_domains { - my ( $self, @domains ) = @_; - my @domains_to_insert = - grep { ref $_ eq 'ARRAY' && $_->[0] && !$self->exists_domain( $_->[0] ) } - @domains; +sub add_roles { + my ( $self, @roles ) = @_; + my @roles_to_insert = + grep { ref $_ eq 'ARRAY' && $_->[0] && !$self->exists_role( $_->[0] ) } + @roles; # Set undefined descriptions to q{}. - foreach my $dom_bundle (@domains_to_insert) { + foreach my $role_bundle (@roles_to_insert) { - # This change is intended to propagate back to @domains_to_insert. - $dom_bundle->[1] = q{} if !$dom_bundle->[1]; + # This change is intended to propagate back to @roles_to_insert. + $role_bundle->[1] = q{} if !$role_bundle->[1]; } - my $sth = _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_add_domains}, - @domains_to_insert ); - return scalar @domains_to_insert; + my $sth = + db_run_ex( $self->_db_conn, $ROLE_QUERY{SQL_add_roles}, + @roles_to_insert ); + return scalar @roles_to_insert; } -# Deletes all domains in @domains (if they exist). -# Silent if non-existent. Returns the number of domains actually deleted. -sub delete_domains { - my ( $self, @domains ) = @_; - my @domains_to_delete; - foreach my $domain (@domains) { - next if !$domain or !$self->exists_domain($domain); - push @domains_to_delete, [$domain]; - delete $self->{domains}{$domain}; # Remove it from the cache too. +# Deletes all roles in @roles (if they exist). +# Silent if non-existent. Returns the number of roles actually deleted. +sub delete_roles { + my ( $self, @roles ) = @_; + my @roles_to_delete; + foreach my $role (@roles) { + next if !$role || !$self->exists_role($role); + push @roles_to_delete, [$role]; + delete $self->{roles}{$role}; # Remove it from the cache too. } - my $sth = _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_delete_domains}, - @domains_to_delete ); - return scalar @domains_to_delete; + my $sth = db_run_ex( $self->_db_conn, $ROLE_QUERY{SQL_delete_roles}, + @roles_to_delete ); + return scalar @roles_to_delete; } -# Gets the description for a single domain. Must specify a valid domain. -sub get_domain_description { - my ( $self, $domain ) = @_; - croak 'Must specify a domain.' - if !defined $domain; - croak 'Specified domain must exist.' - if !$self->exists_domain($domain); +# Gets the description for a single role. Must specify a valid role. +sub get_role_description { + my ( $self, $role ) = @_; + croak 'Must specify a role.' + if !defined $role; + croak 'Specified role must exist.' + if !$self->exists_role($role); my $sth = - _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_get_domain_description}, - $domain ); + db_run_ex( $self->_db_conn, $ROLE_QUERY{SQL_get_role_description}, + $role ); return ( $sth->fetchrow_array )[0]; } -# Pass a domain and a new description. All parameters required. Description +# Pass a role and a new description. All parameters required. Description # of q{} deletes the description. -sub update_domain_description { - my ( $self, $domain, $description ) = @_; - croak 'Must specify a domain.' - if !defined $domain; - croak 'Specified domain doesn\'t exist.' - if !$self->exists_domain($domain); +sub update_role_description { + my ( $self, $role, $description ) = @_; + croak 'Must specify a role.' + if !defined $role; + croak 'Specified role doesn\'t exist.' + if !$self->exists_role($role); croak 'Must specify a description (q{} is ok too).' if !defined $description; my $sth = - _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_update_domain_description}, - $description, $domain ); + db_run_ex( $self->_db_conn, $ROLE_QUERY{SQL_update_role_description}, + $description, $role ); return 1; } -# Returns an array of pairs (AoA). Pairs are [ domain, description ],... -sub fetch_domains { - my $self = shift; - my $sth = _db_run_ex( $self->_db_conn, $DOM_QUERY{SQL_list_domains} ); - my @domains = @{ $sth->fetchall_arrayref }; - return @domains; +# Returns an array of pairs (AoA). Pairs are [ role, description ],... +sub fetch_roles { + my $self = shift; + my $sth = db_run_ex( $self->_db_conn, $ROLE_QUERY{SQL_list_roles} ); + my @roles = @{ $sth->fetchall_arrayref }; + return @roles; } 1; diff --git a/t/11-load.t b/t/11-load.t index 7cbf76c..33c1653 100644 --- a/t/11-load.t +++ b/t/11-load.t @@ -10,4 +10,4 @@ BEGIN { use_ok('Class::User::DBI') || print "Bail out!\n"; } -diag( "Testing Class::User::DBI $Class::User::DBI::VERSION, Perl $], $^X" ); +diag("Testing Class::User::DBI $Class::User::DBI::VERSION, Perl $], $^X"); diff --git a/t/15-class_tests.t b/t/15-class_tests.t index 4da0dd4..a338766 100644 --- a/t/15-class_tests.t +++ b/t/15-class_tests.t @@ -70,7 +70,6 @@ $conn->run( } ); - Class::User::DBI->configure_db($conn); subtest "Tests for $appuser" => sub { diff --git a/t/17-cudbi_db.t b/t/17-cudbi_db.t index a488934..6c82ac9 100644 --- a/t/17-cudbi_db.t +++ b/t/17-cudbi_db.t @@ -8,7 +8,7 @@ use Test::Exception; use DBIx::Connector; BEGIN { - use_ok( 'Class::User::DBI::DB', qw( _db_run_ex %USER_QUERY %PRIV_QUERY ) ); + use_ok( 'Class::User::DBI::DB', qw( db_run_ex %USER_QUERY %PRIV_QUERY ) ); } # WARNING: Tables will be dropped before and after running these tests. @@ -37,20 +37,20 @@ my $conn = DBIx::Connector->new( } ); -can_ok( 'Class::User::DBI::DB', '_db_run_ex' ); +can_ok( 'Class::User::DBI::DB', 'db_run_ex' ); -dies_ok { _db_run_ex() } -'_db_run_ex(): Dies if not given a DBIx::Connector object.'; -dies_ok { _db_run_ex( bless {}, 'strangeness' ) } -'_db_run_ex(): Dies if given an object that is not DBIx::Connector.'; -dies_ok { _db_run_ex('Strangeness') } -'_db_run_ex(): Dies if parameter is not a DBIx::Connector object.'; +dies_ok { db_run_ex() } +'db_run_ex(): Dies if not given a DBIx::Connector object.'; +dies_ok { db_run_ex( bless {}, 'strangeness' ) } +'db_run_ex(): Dies if given an object that is not DBIx::Connector.'; +dies_ok { db_run_ex('Strangeness') } +'db_run_ex(): Dies if parameter is not a DBIx::Connector object.'; ok( - _db_run_ex( + db_run_ex( $conn, 'CREATE TABLE mydbpm_test ( col1 VARCHAR(24) PRIMARY KEY )' ), - '_db_run_ex(): Connected to DB and created a test table.' + 'db_run_ex(): Connected to DB and created a test table.' ); done_testing(); diff --git a/t/19-cudbi_roles.t b/t/19-cudbi_roles.t new file mode 100644 index 0000000..9bbf22b --- /dev/null +++ b/t/19-cudbi_roles.t @@ -0,0 +1,210 @@ +## no critic (RCS,VERSION,encapsulation,Module) + +use strict; +use warnings; +use Test::More; +use Test::Exception; + +use List::MoreUtils qw( any ); + +BEGIN { + use_ok('Class::User::DBI::Roles'); +} + +use DBIx::Connector; + +can_ok( + 'Class::User::DBI::Roles', + qw( _db_conn add_roles configure_db + delete_roles exists_role fetch_roles + get_role_description update_role_description + new + ) +); + +# WARNING: Tables will be dropped before and after running these tests. +# Only run the tests against a test database containing no data +# of value. +# cud_roles +# By default, tests are run against an in-memory database. (safe) +# YOU HAVE BEEN WARNED. + +# SQLite database settings. +my $dsn = 'dbi:SQLite:dbname=:memory:'; +my $db_user = q{}; +my $db_pass = q{}; + +# mysql database settings. +# my $database = 'cudbi_test'; +# my $dsn = "dbi:mysql:database=$database"; +# my $db_user = 'tester'; +# my $db_pass = 'testers_pass'; + +my $conn = DBIx::Connector->new( + $dsn, $db_user, $db_pass, + { + RaiseError => 1, + AutoCommit => 1, + } +); + +subtest 'Test Class::User::DBI::Roles->new() -- Constructor.' => sub { + dies_ok { Class::User::DBI::Roles->new() } + 'Constructor dies if not passed a DBIx::Connector object.'; + dies_ok { + Class::User::DBI::Roles->new( bless {}, 'Not::DBIx::Conn::Obj' ); + } + 'Conctructor dies if passed a non-DBIx::Connector object.'; + dies_ok { + Class::User::DBI::Roles->new('DBIx::Connector'); + } + 'Constructor dies if passed a string instead of an object ref.'; + + my $d = new_ok( 'Class::User::DBI::Roles', [$conn] ); + isa_ok( $d->{_db_conn}, 'DBIx::Connector', + 'Roles object has a DBIx::Connector object attribute.' ); + ok( exists $d->{roles}, 'Roles object has a "roles" attribute.' ); + is( ref $d->{roles}, + 'HASH', 'Roles object\'s "roles" attribute is a hashref.' ); + + done_testing(); +}; + +subtest 'Test Class::User::DBI::Roles->configure_db() -- Database Config.' => + sub { + dies_ok { Class::User::DBI::Roles->configure_db() } + 'configure_db(): dies if not passed a DBIx::Connector object.'; + dies_ok { + Class::User::DBI::Roles->configure_db( bless {}, + 'Not::DBIx::Conn::Obj' ); + } + 'configure_db(): dies if passed a non-DBIx::Connector object.'; + dies_ok { + Class::User::DBI::Roles->new('DBIx::Connector'); + } + 'configure_db(): dies if passed a string instead of an object ref.'; + ok( + Class::User::DBI::Roles->configure_db($conn), + 'configure_db(): Got a good return value.' + ); + my $sth = $conn->run( + fixup => sub { + my $sub_sth = $_->prepare('SELECT sql FROM sqlite_master'); + $sub_sth->execute(); + return $sub_sth; + } + ); + my $table_creation_SQL = ( $sth->fetchrow_array )[0]; + like( + $table_creation_SQL, + qr/CREATE TABLE cud_roles/, + 'configure_db(): The correct table was created.' + ); + like( $table_creation_SQL, qr/role\s+VARCHAR\(\d+\)/, + 'configure_db(): The \'role\' column was created.' ); + like( + $table_creation_SQL, + qr/description\s+VARCHAR\(\d+\)/, + 'configure_db(): The \'description\' column was created.' + ); + like( $table_creation_SQL, qr/PRIMARY\s+KEY\s*\(role\)/, + 'configure_db(): The primary key was created.' ); + done_testing(); + + }; + +# We'll use this connector object for the rest of our tests. +my $d = Class::User::DBI::Roles->new($conn); + +subtest 'Test add_roles() and exists_role().' => sub { + ok( !$d->exists_role('tupitar'), + 'exists_role(): returns false for a non-existent role.' ); + dies_ok { $d->exists_role() } + 'exists_role(): throws an exception when role is undef.'; + dies_ok { $d->exists_role(q{}) } + 'exists_role(): throws an exception when role is empty.'; + my $role = [ 'tupitar', 'This user can tupitar.' ]; + $d->add_roles($role); + ok( $d->exists_role('tupitar'), + 'add_role(): Added "tupitar". exists_role() returns true.' ); + my @multiple_privs = ( + [ 'tupitar2', 'This user can also tupitar.' ], + [ 'tupitar3', 'And so can this one.' ], + [ 'tupitar4', 'And he can too!' ], + ); + $d->add_roles(@multiple_privs); + is( + scalar( grep { $d->exists_role($_) } qw( tupitar2 tupitar3 tupitar4 ) ), + 3, + 'add_roles(): successfully added 3 more roles.' + ); + done_testing(); +}; + +subtest 'Test delete_roles()' => sub { + is( $d->delete_roles('tupitar'), 1, 'delete_roles(): Deleted one role.' ); + ok( !$d->exists_role('tupitar'), + 'delete_roles(): "tupitar" role is deleted.' ); + is( $d->delete_roles( 'tupitar2', 'tupitar3' ), + 2, 'delete_roles(): Deleted two roles.' ); + ok( !$d->exists_role('tupitar2'), + 'delete_roles(): "tupitar2" is deleted.' ); + ok( !$d->exists_role('tupitar3'), + 'delete_roles(): "tupitar3" is deleted.' ); + is( $d->delete_roles('tupitar3'), + 0, 'delete_roles(): Won\'t try to delete non-existent role.' ); + + done_testing(); +}; + +subtest 'Test fetch_roles().' => sub { + $d->add_roles( + [ 'tupitar2', 'He can tupitar again.' ], + [ 'tupitar5', 'He can do a lot of tupitaring.' ], + ); + my @privs = $d->fetch_roles; + + is( scalar @privs, 3, 'fetch_roles fetches correct number of roles.' ); + is( ref $privs[0], 'ARRAY', 'fetch_roles(): Return value is an AoA\'s.' ); + ok( + ( any { $_->[0] eq 'tupitar2' } @privs ), + 'fetch_roles(): Found a correct role.' + ); + ok( + ( any { $_->[1] =~ /again/ } @privs ), + 'fetch_roles(): Descriptions load correctly.' + ); + + done_testing(); +}; + +subtest 'Test get_role_description().' => sub { + dies_ok { $d->get_role_description('gnarfle') } + 'get_role_description(): Throws an exception for ' . 'non-existent role.'; + dies_ok { $d->get_role_description() } + 'get_role_description(): Throws an exception ' . 'when missing param.'; + like( + $d->get_role_description('tupitar2'), + qr/tupitar again/, + 'get_role_description(): Returns the description ' . 'of a valid role.' + ); + done_testing(); +}; + +subtest 'Test update_role_description()' => sub { + dies_ok { $d->update_role_description() } + 'update_role_description(): Dies if no role specified.'; + dies_ok { $d->update_role_description('gnarfle') } + 'update_role_description(): Dies if role doesn\t exist.'; + dies_ok { $d->update_role_description('tupitar2') } + 'update_role_description(): Dies if no description specified.'; + ok( + $d->update_role_description( 'tupitar2', 'Not gnarfling.' ), + 'update_role_description(): Got a good return value' + ); + like( $d->get_role_description('tupitar2'), + qr/gnarfling/, 'update_role_description(): Description updated.' ); + done_testing(); +}; + +done_testing();