File Coverage

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


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

Wrong password!

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