File Coverage

blib/lib/Labyrinth/Users.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package Labyrinth::Users;
2              
3 2     2   4217 use warnings;
  2         4  
  2         56  
4 2     2   7 use strict;
  2         3  
  2         56  
5              
6 2     2   8 use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT @EXPORT_OK);
  2         3  
  2         217  
7             $VERSION = '5.30';
8              
9             =head1 NAME
10              
11             Labyrinth::Users - Generic User Management for Labyrinth
12              
13             =head1 DESCRIPTION
14              
15             Contains generic user functionality that are required across the Labyrinth
16             framework, and may be used within plugins.
17              
18             =cut
19              
20             # -------------------------------------
21             # Export Details
22              
23             require Exporter;
24             @ISA = qw(Exporter);
25              
26             %EXPORT_TAGS = (
27             'all' => [ qw( GetUser UserName UserID FreshPassword PasswordCheck UserSelect ) ]
28             );
29              
30             @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
31             @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
32              
33             # -------------------------------------
34             # Library Modules
35              
36 2     2   11 use Labyrinth::Audit;
  2         3  
  2         256  
37 2     2   73 use Labyrinth::Globals;
  0            
  0            
38             use Labyrinth::DBUtils;
39             use Labyrinth::MLUtils;
40             use Labyrinth::Variables;
41              
42             use Session::Token;
43              
44             # -------------------------------------
45             # Variables
46              
47             my (%users,%userids); # quick lookup hashes
48              
49             # -------------------------------------
50             # The Subs
51              
52             =head1 PUBLIC INTERFACE METHODS
53              
54             =over 4
55              
56             =item GetUser($id)
57              
58             Given a user id, performs a database lookup, unless a previous lookup for the
59             same id has already been requested.
60              
61             =item UserName($id)
62              
63             Given a user id, returns the user's name.
64              
65             =item UserID
66              
67             Given a user's name (real name or nick name), returns the user id.
68              
69             =item FreshPassword
70              
71             Returns a generated password string.
72              
73             =item PasswordCheck
74              
75             Checks the given password against the required rules.
76              
77             =back
78              
79             =cut
80              
81             sub GetUser {
82             my $uid = shift;
83             return unless($uid);
84              
85             $users{$uid} ||= do {
86             my @rows = $dbi->GetQuery('hash','GetUserByID',$uid);
87             $rows[0] if(@rows);
88             };
89              
90             return $users{$uid};
91             }
92              
93             sub UserName {
94             my $uid = shift;
95             return unless($uid);
96              
97             my $user = GetUser($uid);
98             return $user->{realname} || $user->{nickname};
99             }
100              
101             sub UserID {
102             my $name = shift;
103             return unless($name);
104              
105             $userids{$name} ||= do {
106             my @rows = $dbi->GetQuery('hash','GetUserByName',$name);
107             return unless(@rows);
108             $users{$rows[0]->{userid}} ||= $rows[0];
109             $rows[0]->{userid};
110             };
111              
112             return $userids{$name};
113             }
114              
115             sub FreshPassword {
116             my $gen = Session::Token->new(length => 10);
117             return $gen->get();
118             }
119              
120             sub PasswordCheck {
121             my $password = shift || return 6;
122             my $plen = length $password;
123              
124             return 4 if($password =~ /\s/);
125             return 1 if($settings{minpasslen} && $plen < $settings{minpasslen});
126             return 2 if($settings{maxpasslen} && $plen > $settings{maxpasslen});
127              
128             # Check unique characters
129             my @chars = split //,$password ;
130             my %unique ;
131             foreach my $char (@chars) {
132             $unique{$char}++;
133             }
134              
135             return 5 if(scalar keys %unique < 3);
136              
137             my $types = 0;
138             $types++ if($password =~ /[a-z]/);
139             $types++ if($password =~ /[A-Z]/);
140             $types++ if($password =~ /\d/);
141             $types++ if($password =~ /[^a-zA-Z\d]/);
142             return 0 if($types > 1);
143              
144             return 3;
145             }
146              
147             =head1 ADMIN INTERFACE METHODS
148              
149             =over 4
150              
151             =item UserSelect
152              
153             Provides a dropdown selection box, as a XHTML code snippet, of the currently
154             listed users.
155              
156             By default only users listed as searchable are listed.
157              
158             =back
159              
160             =cut
161              
162             sub UserSelect {
163             my $opt = shift;
164             my $multi = shift || 5;
165             my $blank = shift || 0;
166             my $field = shift || 'userid';
167             my $title = shift || 'Name';
168             my $all = shift;
169             my $search;
170              
171             $search = 'WHERE search=1' unless($all);
172              
173             my @rows = $dbi->GetQuery('hash','AllUsers',{search=>$search});
174             foreach (@rows) {
175             my @names;
176             push @names, $_->{realname} if($_->{realname});
177             push @names, '(' . $_->{nickname} . ')' if($_->{nickname});
178             $_->{name} = join(' ',@names) if(@names);
179             $_->{name} ||= 'No Name Given';
180             }
181             unshift @rows, {userid=>0,name=>"Select $title"} if($blank == 1);
182             return DropDownMultiRows($opt,$field,'userid','name',$multi,@rows) if($multi > 1);
183             return DropDownRows($opt,$field,'userid','name',@rows);
184             }
185              
186             1;
187              
188             __END__