File Coverage

blib/lib/CGI/Auth/Basic.pm
Criterion Covered Total %
statement 27 242 11.1
branch 0 96 0.0
condition 0 69 0.0
subroutine 9 36 25.0
pod 7 7 100.0
total 43 450 9.5


line stmt bran cond sub pod time code
1             package CGI::Auth::Basic;
2 1     1   16098 use strict;
  1         1  
  1         38  
3 1     1   3 use warnings;
  1         2  
  1         28  
4 1     1   4 use constant EMPTY_STRING => q{};
  1         5  
  1         66  
5 1     1   4 use constant CHMOD_VALUE => 0777;
  1         1  
  1         31  
6 1     1   4 use constant MIN_PASSWORD_LENGTH => 3;
  1         1  
  1         35  
7 1     1   4 use constant MAX_PASSWORD_LENGTH => 32;
  1         1  
  1         62  
8 1     1   5 use constant CRYP_CHARS => q{.}, q{,}, q{/}, 0..9, q{A}..q{Z}, q{a}..q{z};
  1         1  
  1         122  
9 1     1   6 use constant RANDOM_NUM => 64;
  1         2  
  1         61  
10 1     1   6 use Carp qw( croak );
  1         1  
  1         3458  
11              
12             our $VERSION = '1.23';
13              
14             our $RE = qr{\A\w\./}xms; # regex for passwords
15             our $FATAL_HEADER;
16              
17             # Fatal and other error messages
18             our %ERROR = (
19             INVALID_OPTION => 'Options must be in "param => value" format!',
20             CGI_OBJECT => 'I need a CGI object to run!!!',
21             FILE_READ => 'Error opening pasword file: ',
22             NO_PASSWORD => 'No password specified (or password file can not be found)!',
23             UPDATE_PFILE => 'Your password file is empty and your current setting does not allow this code to update the file! Please update your password file.',
24             ILLEGAL_PASSWORD => 'Illegal password! Not accepted. Go back and enter a new one',
25             FILE_WRITE => 'Error opening password file for update: ',
26             UNKNOWN_METHOD => 'There is no method called "%s". Check your coding.',
27             EMPTY_FORM_PFIELD => q{You didn't set any password (password file is empty)!},
28             WRONG_PASSWORD => '

Wrong password!

',
29             INVALID_COOKIE => 'Your cookie info includes invalid data and it has been deleted by the program.',
30             );
31              
32             sub new {
33 0     0 1   my($class, @args) = @_;
34 0           my $self = {};
35 0           bless $self, $class;
36 0 0         $self->_fatal($ERROR{INVALID_OPTION}) if @args % 2;
37 0           $self->_set_options( @args );
38 0           $self->_init;
39 0           return $self;
40             }
41              
42             sub _set_options {
43 0     0     my($self, %o) = @_;
44 0 0         if ( $o{cgi_object} eq 'AUTOLOAD_CGI' ) {
45 0           require CGI;
46 0           $o{cgi_object} = CGI->new;
47             }
48             else {
49             # long: i_have_another_cgi_like_object_and_i_want_to_use_it
50             # don't know if such a module exists :p
51 0 0         if ( ! $o{ihacloaiwtui} ) {
52 0 0         $self->_fatal($ERROR{CGI_OBJECT}) if ref $o{cgi_object} ne 'CGI';
53             }
54             }
55              
56 0           my $password;
57 0 0 0       if ($o{file} and -e $o{file} and not -d $o{file}) {
      0        
58 0           $self->{password_file_path} = $o{file};
59             # Don't execute until check_user() called.
60 0     0     $password = sub {$self->_pfile_content};
  0            
61             }
62             else {
63 0           $password = $o{password};
64             }
65              
66 0 0         $self->_fatal($ERROR{NO_PASSWORD}) if ! $password;
67              
68 0           $self->{password} = $password;
69 0           $self->{cgi} = $o{cgi_object};
70 0   0       $self->{program} = $self->{cgi}->url || EMPTY_STRING;
71              
72             # object tables user specified default
73 0   0       $self->{cookie_id} = $o{cookie_id} || 'authpass';
74 0   0       $self->{http_charset} = $o{http_charset} || 'ISO-8859-1';
75 0   0       $self->{logoff_param} = $o{logoff_param} || 'logoff';
76 0   0       $self->{changep_param} = $o{changep_param} || 'changepass';
77 0   0       $self->{cookie_timeout} = $o{cookie_timeout} || EMPTY_STRING;
78 0   0       $self->{setup_pfile} = $o{setup_pfile} || 0;
79 0   0       $self->{chmod_value} = $o{chmod_value} || CHMOD_VALUE;
80 0   0       $self->{use_flock} = $o{use_flock} || 1;
81 0   0       $self->{hidden} = $o{hidden} || [];
82 0           return;
83             }
84              
85             sub exit_code {
86 0     0 1   my $self = shift;
87 0   0       my $code = shift || return;
88 0 0         $self->{EXIT_PROGRAM} = $code if ref $code eq 'CODE';
89 0           return;
90             }
91              
92             sub _init {
93 0     0     my $self = shift;
94              
95 0 0         if ( ! ref $self->{hidden} eq 'ARRAY' ) {
96 0           $self->_fatal('hidden parameter must be an arrayref!');
97             }
98              
99 0           my $hidden;
100             my @hidden_q;
101 0           foreach (@{ $self->{hidden} }) {
  0            
102 0 0         next if $_->[0] eq $self->{cookie_id}; # password!
103 0 0         next if $_->[0] eq $self->{cookie_id} . '_new'; # password!
104 0           $hidden .= qq~\n~;
105 0           push @hidden_q, join q{=}, $_->[0], $_->[1];
106             }
107              
108 0 0         $self->{hidden_q} = @hidden_q ? join(q{&}, @hidden_q) : EMPTY_STRING;
109 0   0       $self->{hidden} = $hidden || EMPTY_STRING;
110 0           $self->{logged_in} = 0;
111 0     0     $self->{EXIT_PROGRAM} = sub {CORE::exit()};
  0            
112              
113             # Set default titles
114 0           $self->{_TEMPLATE_TITLE} = {
115             title_login_form => 'Login',
116             title_cookie_error => 'Your invalid cookie has been deleted by the program',
117             title_login_success => 'You are now logged-in',
118             title_logged_off => 'You are now logged-off',
119             title_change_pass_form => 'Change password',
120             title_password_created => 'Password created',
121             title_password_changed => 'Password changed successfully',
122             title_error => 'Error',
123             };
124              
125 0           $self->{_TEMPLATE_TITLE_USER} = {};
126 0           $self->{_TEMPLATE_NAMES} = [
127             qw(
128             login_form
129             screen
130             logoff_link
131             change_pass_form
132             )
133             ];
134              
135             # Temporary template variables (but some are not temporary :))
136 0           $self->{$_} = EMPTY_STRING foreach qw(
137             page_form_error
138             page_logoff_link
139             page_content
140             page_title
141             );
142              
143 0           return;
144             }
145              
146             sub _setup_password {
147 0     0     my $self = shift;
148 0 0         $self->_fatal($ERROR{UPDATE_PFILE}) unless $self->{setup_pfile};
149 0 0         if ( ! $self->{cgi}->param('change_password') ) {
150 0           return $self->_screen(
151             content => $self->_change_pass_form($ERROR{EMPTY_FORM_PFIELD}),
152             title => $self->_get_title('change_pass_form'),
153             );
154             }
155 0           my $password = $self->{cgi}->param($self->{cookie_id}.'_new');
156 0           $self->_check_password($password);
157 0           $self->_update_pfile($password);
158 0           return $self->_screen(
159             content => $self->_get_title('password_created'),
160             title => $self->_get_title('password_created'),
161             cookie => $self->_empty_cookie,
162             forward => 1,
163             );
164             }
165              
166             sub _check_password {
167 0     0     my $self = shift;
168 0           my $password = shift;
169 0   0       my $not_ok = ! $password ||
170             $password =~ /\s/xms ||
171             length($password) < MIN_PASSWORD_LENGTH ||
172             length($password) > MAX_PASSWORD_LENGTH ||
173             $password =~ $RE;
174 0 0         $self->_error( $ERROR{ILLEGAL_PASSWORD} ) if $not_ok;
175 0           return;
176             }
177              
178              
179             sub _update_pfile {
180 0     0     my $self = shift;
181 0           my $password = shift;
182 0           require IO::File;
183 0           my $PASSWORD = IO::File->new;
184 0 0         $PASSWORD->open( $self->{password_file_path}, '>' ) or $self->_fatal($ERROR{FILE_WRITE}." $!");
185 0 0         flock $PASSWORD, Fcntl::LOCK_EX() if $self->{use_flock};
186 0           my $pok = print {$PASSWORD} $self->_encode($password);
  0            
187 0 0         flock $PASSWORD, Fcntl::LOCK_UN() if $self->{use_flock};
188 0           $PASSWORD->close;
189 0           return chmod $self->{chmod_value}, $self->{password_file_path};
190             }
191              
192             sub _pfile_content {
193 0     0     my $self = shift;
194 0           require IO::File;
195 0           my $PASSWORD = IO::File->new;
196 0 0         $PASSWORD->open($self->{password_file_path}) or $self->_fatal($ERROR{FILE_READ}." $!");
197 0           my $flat = do { local $/; my $rv = <$PASSWORD>; $rv };
  0            
  0            
  0            
198 0           chomp $flat;
199 0           $PASSWORD->close;
200 0           $flat =~ s{\s}{}xmsg;
201 0           return $flat;
202             }
203              
204             sub check_user {
205 0     0 1   my $self = shift;
206 0           $self->_check_user_real;
207              
208             # We have a valid user. Below are accessible as user functions
209 0 0         if ( $self->{cgi}->param($self->{changep_param}) ) {
210 0 0         if ( ! $self->{cgi}->param('change_password') ) {
211 0           $self->_screen(
212             content => $self->_change_pass_form,
213             title => $self->_get_title('change_pass_form')
214             );
215             }
216 0           my $password = $self->{cgi}->param($self->{cookie_id}.'_new');
217 0           $self->_check_password($password);
218 0           $self->_update_pfile($password);
219 0           $self->_screen(content => $self->_get_title('password_changed'),
220             title => $self->_get_title('password_changed'),
221             cookie => $self->_empty_cookie,
222             forward => 1);
223             }
224 0           return;
225             }
226              
227             # Main method to validate a user
228             sub _check_user_real {
229 0     0     my $self = shift;
230 0           my $pass_param;
231              
232 0 0         if(ref($self->{password}) eq 'CODE') {
233 0           require Fcntl; # we need flock constants
234 0   0       $self->{password} = $self->{password}->() || $self->_setup_password;
235             }
236              
237 0 0         if ($self->{cgi}->param($self->{logoff_param})) {
238 0           $self->_screen(
239             content => $self->_get_title('logged_off'),
240             title => $self->_get_title('logged_off'),
241             cookie => $self->_empty_cookie,
242             forward => 1,
243             );
244             }
245              
246             # Attemp to login via form
247 0 0         if ($pass_param = $self->{cgi}->param($self->{cookie_id})){
    0          
248 0 0 0       if ( $pass_param !~ $RE && $self->_match_pass( $pass_param ) ) {
249 0           $self->{logged_in} = 1;
250 0           $self->_screen(
251             content => $self->_get_title('login_success'),
252             title => $self->_get_title('login_success'),
253             forward => 1,
254             cookie => $self->{cgi}->cookie(
255             -name => $self->{cookie_id},
256             -value => $self->{password},
257             -expires => $self->{cookie_timeout},
258             ),
259             );
260             }
261             else {
262 0           $self->_screen(
263             content => $self->_login_form($ERROR{WRONG_PASSWORD}),
264             title => $self->_get_title('login_form'),
265             );
266             }
267             # Attemp to login via cookie
268             }
269             elsif ($pass_param = $self->{cgi}->cookie($self->{cookie_id})) {
270 0 0 0       if ( $pass_param !~ $RE && $pass_param eq $self->{password} ) {
271 0           $self->{logged_in} = 1;
272 0           return 1;
273             }
274             else {
275 0           $self->_screen(
276             content => $ERROR{INVALID_COOKIE},
277             title => $self->_get_title('cookie_error'),
278             cookie => $self->_empty_cookie,
279             forward => 1,
280             );
281             }
282             }
283             else {
284 0           $self->_screen(
285             content => $self->_login_form,
286             title => $self->_get_title('login_form'),
287             );
288             }
289 0           return;
290             }
291              
292             # Private method. Used internally to compile templates
293             sub _compile_template {
294 0     0     my $self = shift;
295 0           my $key = shift;
296 0           my $code = $self->{'template_'.$key};
297 0 0         return if ! $code;
298 0           $code =~ s{<\?(?:\s+|)(\w+)(?:\s+|)\?>}
299             {
300 0           my $param = lc $1;
301 0 0 0       if ( $param !~ m{\W}xms && exists $self->{$param} ) {
302 0           $self->{$param};
303             }
304             }xmsge;
305 0           return $code;
306             }
307              
308             sub _get_title {
309 0     0     my $self = shift;
310 0 0         my $key = shift or return;
311 0   0       return $self->{_TEMPLATE_TITLE_USER}{'title_'.$key}
312             || $self->{_TEMPLATE_TITLE}{'title_'.$key};
313             }
314              
315             sub set_template {
316 0     0 1   my($self, @args) = @_;
317 0 0         $self->_fatal($ERROR{INVALID_OPTION}) if @args % 2;
318 0           my %o = @args;
319 0 0         if ($o{delete_all}) {
320 0           foreach my $key (keys %{$self}) {
  0            
321 0 0         delete $self->{$key} if $key =~ m{ \A template_ }xms;
322             }
323 0           $self->{_TEMPLATE_TITLE_USER} = {};
324             }
325             else {
326 0           foreach my $key (@{ $self->{_TEMPLATE_NAMES} }) {
  0            
327 0 0         $self->{'template_'.$key} = $o{$key} if exists $o{$key};
328             }
329             }
330 0           return 1;
331             }
332              
333             sub set_title {
334 0     0 1   my($self, @args) = @_;
335 0 0         $self->_fatal($ERROR{INVALID_OPTION}) if @args % 2;
336 0           my %o = @args;
337 0           foreach ( keys %o ) {
338 0 0         next if ! $self->{_TEMPLATE_TITLE}{'title_'.$_};
339 0           $self->{_TEMPLATE_TITLE_USER}{'title_'.$_} = $o{$_};
340             }
341 0           return;
342             }
343              
344             sub _login_form {
345 0     0     my($self, @args) = @_;
346 0 0         $self->{page_form_error} = shift @args if @args;
347 0   0       return $self->_compile_template('login_form') || <<"TEMPLATE";
348             $self->{page_form_error}
349              
350            
351             method = "post"
352             >
353            
354             cellpadding = "0"
355             cellspacing = "0"
356             >
357            
358            
359            
360             cellpadding = "4"
361             cellspacing = "1"
362             >
363            
364            
365             colspan = "3"
366             >
367             You need to login to use this function
368            
369            
370            
371            
372             Enter the password to run this program:
373            
374            
375            
376             name = "$self->{cookie_id}"
377             />
378            
379            
380             align = "right"
381             >
382            
383             name = "submit"
384             value = "Login"
385             />
386             $self->{hidden}
387            
388            
389            
390            
391            
392            
393            
394             TEMPLATE
395             }
396              
397             sub _change_pass_form {
398 0     0     my($self, @args) = @_;
399 0 0         $self->{page_form_error} = shift @args if @args;
400 0   0       return $self->_compile_template('change_pass_form') || <<"PASS_FORM";
401             qq~
402             $self->{page_form_error}
403              
404            
405             method = "post"
406             >
407              
408            
409             cellpadding = "0"
410             cellspacing = "0"
411             >
412            
413            
414            
415             cellpadding = "4"
416             cellspacing = "1"
417             >
418            
419            
420             colspan = "3"
421             >
422             Enter a password between 3 and 32 characters
423             and no spaces allowed!
424            
425            
426            
427            
428             Enter your new password:
429            
430            
431            
432             name = "$self->{cookie_id}_new"
433             />
434            
435            
436             align="right"
437             >
438            
439             name = "submit"
440             value = "Change Password"
441             />
442            
443             name = "change_password"
444             value = "ok"
445             />
446            
447            
448             name = "$self->{changep_param}"
449             value = "1"
450             />
451            
452             $self->{hidden}
453            
454            
455            
456            
457            
458            
459             PASS_FORM
460             }
461              
462             sub logoff_link {
463 0     0 1   my $self = shift;
464 0 0         my $query = $self->{hidden_q} ? q{&} . $self->{hidden_q} : EMPTY_STRING;
465 0 0         if ( $self->{logged_in} ) {
466 0   0       return $self->_compile_template('logoff_link') || <<"TEMPLATE";
467            
468             [
469             Log-off
470             -
471             Change password
472             ]
473            
474             TEMPLATE
475             }
476 0           return EMPTY_STRING;
477             }
478              
479             # For form errors
480             sub _error {
481 0     0     my $self = shift;
482 0           my $error = shift;
483 0           return $self->_screen(
484             content => qq~$error~,
485             title => $self->_get_title('error'),
486             );
487             }
488              
489             sub _screen {
490 0     0     my($self, @args) = @_;
491 0 0         my %p = @args % 2 ? () : @args;
492 0 0         my @cookie = $p{cookie} ? (-cookie => $p{cookie}) : ();
493              
494 0           my $refresh_url;
495 0 0         if ( $self->{hidden_q} ) {
496 0           $refresh_url = "$self->{program}?$self->{hidden_q}";
497             }
498             else {
499 0           my @qs;
500 0           foreach my $p ( $self->{cgi}->param ) {
501 0 0 0       next if $p eq $self->{logoff_param}
      0        
      0        
502             || $p eq $self->{changep_param}
503             || $p eq $self->{cookie_id}
504             || $p eq $self->{cookie_id} . '_new';
505 0           push @qs, $p . q{=} . $self->{cgi}->param( $p );
506             }
507 0           my $url = $self->{program};
508 0 0         if ( @qs ) {
509 0           $url =~ s{\?}{}xmsg;
510 0           $url .= q{?} . join q{&}, @qs;
511             }
512 0           $refresh_url = $url;
513             }
514              
515             # Set template vars
516 0           $self->{page_logoff_link} = $self->logoff_link;
517 0           $self->{page_content} = $p{content};
518 0           $self->{page_title} = $p{title};
519 0 0         $self->{page_refresh} = $p{forward}
520             ? qq~~
521             : EMPTY_STRING
522             ;
523 0 0         $self->{page_inline_refresh} = $p{forward}
524             ? qq~»~
525             : EMPTY_STRING
526             ;
527 0   0       my $out = $self->_compile_template('screen') || <<"MAIN_TEMPLATE";
528            
529            
530             $self->{page_refresh}
531             $self->{page_title}
532            
541            
542            
543             $self->{'page_logoff_link'}
544             $self->{'page_content'}
545             $self->{'page_inline_refresh'}
546            
547            
548             MAIN_TEMPLATE
549 0           my $header = $self->{cgi}->header(
550             -charset => $self->{http_charset},
551             @cookie
552             );
553 0           my $pok = print $header . $out;
554 0           return $self->_exit_program;
555             }
556              
557             sub fatal_header {
558 0     0 1   my($self, @args) = @_;
559 0 0         $FATAL_HEADER = shift @args if @args;
560 0   0       return $FATAL_HEADER || qq~Content-Type: text/html; charset=ISO-8859-1\n\n~;
561             }
562              
563             # Trap deadly errors
564             sub _fatal {
565 0     0     my $self = shift;
566 0   0       my $error = shift || EMPTY_STRING;
567 0           my @rep = caller 0;
568 0           my @caller = caller 1;
569 0           $rep[1] =~ s{.*[\\/]}{}xms;
570 0           $caller[1] =~ s{.*[\\/]}{}xms;
571 0           my $class = ref $self;
572 0           my $fatal = $self->fatal_header;
573 0           $fatal .= <<"FATAL";
574            
575            
576             Flawless Victory
577            
582            
583            
584            

$class $VERSION - Fatal Error
585             $error
586            
587            
588             Program terminated at $caller[1]
589             (package $caller[0]) line $caller[2].
590            
591             Error occurred in $rep[0] line $rep[2].
592            
593            
594            
595             FATAL
596 0           my $pok = print $fatal;
597 0           return $self->_exit_program;
598             }
599              
600             sub _match_pass {
601 0     0     my $self = shift;
602 0           my $form = shift;
603 0           return crypt($form, substr $self->{password}, 0, 2 ) eq $self->{password};
604             }
605              
606             sub _encode {
607 0     0     my $self = shift;
608 0           my $plain = shift;
609 0           my $salt = join EMPTY_STRING, (CRYP_CHARS)[ rand RANDOM_NUM, rand RANDOM_NUM ];
610 0           return crypt $plain, $salt;
611             }
612              
613             sub _empty_cookie {
614 0     0     my $self = shift;
615 0           return $self->{cgi}->cookie(
616             -name => $self->{cookie_id},
617             -value => EMPTY_STRING,
618             -expires => '-10y',
619             )
620             }
621              
622             sub _exit_program {
623 0     0     my $exit = shift->{EXIT_PROGRAM};
624 0 0         return $exit ? $exit->() : exit;
625             }
626              
627             1;
628              
629             __END__