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   35271 use strict;
  1         4  
  1         51  
3 1     1   5 use warnings;
  1         2  
  1         41  
4 1     1   5 use constant EMPTY_STRING => q{};
  1         6  
  1         85  
5 1     1   4 use constant CHMOD_VALUE => 0777;
  1         2  
  1         86  
6 1     1   5 use constant MIN_PASSWORD_LENGTH => 3;
  1         1  
  1         147  
7 1     1   4 use constant MAX_PASSWORD_LENGTH => 32;
  1         1  
  1         119  
8 1     1   4 use constant CRYP_CHARS => q{.}, q{,}, q{/}, 0..9, q{A}..q{Z}, q{a}..q{z};
  1         2  
  1         93  
9 1     1   4 use constant RANDOM_NUM => 64;
  1         1  
  1         41  
10 1     1   4 use Carp qw( croak );
  1         2  
  1         6396  
11              
12             our $VERSION = '1.22';
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             _TEMPLATE_TITLE
142             _TEMPLATE_TITLE_USER
143             _TEMPLATE_NAMES
144             );
145              
146 0           return;
147             }
148              
149             sub _setup_password {
150 0     0     my $self = shift;
151 0 0         $self->_fatal($ERROR{UPDATE_PFILE}) unless $self->{setup_pfile};
152 0 0         if ( ! $self->{cgi}->param('change_password') ) {
153 0           return $self->_screen(
154             content => $self->_change_pass_form($ERROR{EMPTY_FORM_PFIELD}),
155             title => $self->_get_title('change_pass_form'),
156             );
157             }
158 0           my $password = $self->{cgi}->param($self->{cookie_id}.'_new');
159 0           $self->_check_password($password);
160 0           $self->_update_pfile($password);
161 0           return $self->_screen(
162             content => $self->_get_title('password_created'),
163             title => $self->_get_title('password_created'),
164             cookie => $self->_empty_cookie,
165             forward => 1,
166             );
167             }
168              
169             sub _check_password {
170 0     0     my $self = shift;
171 0           my $password = shift;
172 0   0       my $not_ok = ! $password ||
173             $password =~ /\s/xms ||
174             length($password) < MIN_PASSWORD_LENGTH ||
175             length($password) > MAX_PASSWORD_LENGTH ||
176             $password =~ $RE;
177 0 0         $self->_error( $ERROR{ILLEGAL_PASSWORD} ) if $not_ok;
178 0           return;
179             }
180              
181              
182             sub _update_pfile {
183 0     0     my $self = shift;
184 0           my $password = shift;
185 0           require IO::File;
186 0           my $PASSWORD = IO::File->new;
187 0 0         $PASSWORD->open( $self->{password_file_path}, '>' ) or $self->_fatal($ERROR{FILE_WRITE}." $!");
188 0 0         flock $PASSWORD, Fcntl::LOCK_EX() if $self->{use_flock};
189 0           my $pok = print {$PASSWORD} $self->_encode($password);
  0            
190 0 0         flock $PASSWORD, Fcntl::LOCK_UN() if $self->{use_flock};
191 0           $PASSWORD->close;
192 0           return chmod $self->{chmod_value}, $self->{password_file_path};
193             }
194              
195             sub _pfile_content {
196 0     0     my $self = shift;
197 0           require IO::File;
198 0           my $PASSWORD = IO::File->new;
199 0 0         $PASSWORD->open($self->{password_file_path}) or $self->_fatal($ERROR{FILE_READ}." $!");
200 0           my $flat = do { local $/; my $rv = <$PASSWORD>; $rv };
  0            
  0            
  0            
201 0           chomp $flat;
202 0           $PASSWORD->close;
203 0           $flat =~ s{\s}{}xmsg;
204 0           return $flat;
205             }
206              
207             sub check_user {
208 0     0 1   my $self = shift;
209 0           $self->_check_user_real;
210              
211             # We have a valid user. Below are accessible as user functions
212 0 0         if ( $self->{cgi}->param($self->{changep_param}) ) {
213 0 0         if ( ! $self->{cgi}->param('change_password') ) {
214 0           $self->_screen(
215             content => $self->_change_pass_form,
216             title => $self->_get_title('change_pass_form')
217             );
218             }
219 0           my $password = $self->{cgi}->param($self->{cookie_id}.'_new');
220 0           $self->_check_password($password);
221 0           $self->_update_pfile($password);
222 0           $self->_screen(content => $self->_get_title('password_changed'),
223             title => $self->_get_title('password_changed'),
224             cookie => $self->_empty_cookie,
225             forward => 1);
226             }
227 0           return;
228             }
229              
230             # Main method to validate a user
231             sub _check_user_real {
232 0     0     my $self = shift;
233 0           my $pass_param;
234              
235 0 0         if(ref($self->{password}) eq 'CODE') {
236 0           require Fcntl; # we need flock constants
237 0   0       $self->{password} = $self->{password}->() || $self->_setup_password;
238             }
239              
240 0 0         if ($self->{cgi}->param($self->{logoff_param})) {
241 0           $self->_screen(
242             content => $self->_get_title('logged_off'),
243             title => $self->_get_title('logged_off'),
244             cookie => $self->_empty_cookie,
245             forward => 1,
246             );
247             }
248              
249             # Attemp to login via form
250 0 0         if ($pass_param = $self->{cgi}->param($self->{cookie_id})){
    0          
251 0 0 0       if ( $pass_param !~ $RE && $self->_match_pass( $pass_param ) ) {
252 0           $self->{logged_in} = 1;
253 0           $self->_screen(
254             content => $self->_get_title('login_success'),
255             title => $self->_get_title('login_success'),
256             forward => 1,
257             cookie => $self->{cgi}->cookie(
258             -name => $self->{cookie_id},
259             -value => $self->{password},
260             -expires => $self->{cookie_timeout},
261             ),
262             );
263             }
264             else {
265 0           $self->_screen(
266             content => $self->_login_form($ERROR{WRONG_PASSWORD}),
267             title => $self->_get_title('login_form'),
268             );
269             }
270             # Attemp to login via cookie
271             }
272             elsif ($pass_param = $self->{cgi}->cookie($self->{cookie_id})) {
273 0 0 0       if ( $pass_param !~ $RE && $pass_param eq $self->{password} ) {
274 0           $self->{logged_in} = 1;
275 0           return 1;
276             }
277             else {
278 0           $self->_screen(
279             content => $ERROR{INVALID_COOKIE},
280             title => $self->_get_title('cookie_error'),
281             cookie => $self->_empty_cookie,
282             forward => 1,
283             );
284             }
285             }
286             else {
287 0           $self->_screen(
288             content => $self->_login_form,
289             title => $self->_get_title('login_form'),
290             );
291             }
292 0           return;
293             }
294              
295             # Private method. Used internally to compile templates
296             sub _compile_template {
297 0     0     my $self = shift;
298 0           my $key = shift;
299 0           my $code = $self->{'template_'.$key};
300 0 0         return if ! $code;
301 0           $code =~ s{<\?(?:\s+|)(\w+)(?:\s+|)\?>}
302             {
303 0           my $param = lc $1;
304 0 0 0       if ( $param !~ m{\W}xms && exists $self->{$param} ) {
305 0           $self->{$param};
306             }
307             }xmsge;
308 0           return $code;
309             }
310              
311             sub _get_title {
312 0     0     my $self = shift;
313 0 0         my $key = shift or return;
314 0   0       return $self->{_TEMPLATE_TITLE_USER}{'title_'.$key}
315             || $self->{_TEMPLATE_TITLE}{'title_'.$key};
316             }
317              
318             sub set_template {
319 0     0 1   my($self, @args) = @_;
320 0 0         $self->_fatal($ERROR{INVALID_OPTION}) if @args % 2;
321 0           my %o = @args;
322 0 0         if ($o{delete_all}) {
323 0           foreach my $key (keys %{$self}) {
  0            
324 0 0         delete $self->{$key} if $key =~ m{ \A template_ }xms;
325             }
326 0           $self->{_TEMPLATE_TITLE_USER} = {};
327             }
328             else {
329 0           foreach my $key (@{ $self->{_TEMPLATE_NAMES} }) {
  0            
330 0 0         $self->{'template_'.$key} = $o{$key} if exists $o{$key};
331             }
332             }
333 0           return 1;
334             }
335              
336             sub set_title {
337 0     0 1   my($self, @args) = @_;
338 0 0         $self->_fatal($ERROR{INVALID_OPTION}) if @args % 2;
339 0           my %o = @args;
340 0           foreach ( keys %o ) {
341 0 0         next if ! $self->{_TEMPLATE_TITLE}{'title_'.$_};
342 0           $self->{_TEMPLATE_TITLE_USER}{'title_'.$_} = $o{$_};
343             }
344 0           return;
345             }
346              
347             sub _login_form {
348 0     0     my($self, @args) = @_;
349 0 0         $self->{page_form_error} = shift @args if @args;
350 0   0       return $self->_compile_template('login_form') || <<"TEMPLATE";
351             $self->{page_form_error}
352              
353            
354             method = "post"
355             >
356            
357             cellpadding = "0"
358             cellspacing = "0"
359             >
360            
361            
362            
363             cellpadding = "4"
364             cellspacing = "1"
365             >
366            
367            
368             colspan = "3"
369             >
370             You need to login to use this function
371            
372            
373            
374            
375             Enter the password to run this program:
376            
377            
378            
379             name = "$self->{cookie_id}"
380             />
381            
382            
383             align = "right"
384             >
385            
386             name = "submit"
387             value = "Login"
388             />
389             $self->{hidden}
390            
391            
392            
393            
394            
395            
396            
397             TEMPLATE
398             }
399              
400             sub _change_pass_form {
401 0     0     my($self, @args) = @_;
402 0 0         $self->{page_form_error} = shift @args if @args;
403 0   0       return $self->_compile_template('change_pass_form') || <<"PASS_FORM";
404             qq~
405             $self->{page_form_error}
406              
407            
408             method = "post"
409             >
410              
411            
412             cellpadding = "0"
413             cellspacing = "0"
414             >
415            
416            
417            
418             cellpadding = "4"
419             cellspacing = "1"
420             >
421            
422            
423             colspan = "3"
424             >
425             Enter a password between 3 and 32 characters
426             and no spaces allowed!
427            
428            
429            
430            
431             Enter your new password:
432            
433            
434            
435             name = "$self->{cookie_id}_new"
436             />
437            
438            
439             align="right"
440             >
441            
442             name = "submit"
443             value = "Change Password"
444             />
445            
446             name = "change_password"
447             value = "ok"
448             />
449            
450            
451             name = "$self->{changep_param}"
452             value = "1"
453             />
454            
455             $self->{hidden}
456            
457            
458            
459            
460            
461            
462             PASS_FORM
463             }
464              
465             sub logoff_link {
466 0     0 1   my $self = shift;
467 0 0         my $query = $self->{hidden_q} ? q{&} . $self->{hidden_q} : EMPTY_STRING;
468 0 0         if ( $self->{logged_in} ) {
469 0   0       return $self->_compile_template('logoff_link') || <<"TEMPLATE";
470            
471             [
472             Log-off
473             -
474             Change password
475             ]
476            
477             TEMPLATE
478             }
479 0           return EMPTY_STRING;
480             }
481              
482             # For form errors
483             sub _error {
484 0     0     my $self = shift;
485 0           my $error = shift;
486 0           return $self->_screen(
487             content => qq~$error~,
488             title => $self->_get_title('error'),
489             );
490             }
491              
492             sub _screen {
493 0     0     my($self, @args) = @_;
494 0 0         my %p = @args % 2 ? () : @args;
495 0 0         my @cookie = $p{cookie} ? (-cookie => $p{cookie}) : ();
496              
497 0           my $refresh_url;
498 0 0         if ( $self->{hidden_q} ) {
499 0           $refresh_url = "$self->{program}?$self->{hidden_q}";
500             }
501             else {
502 0           my @qs;
503 0           foreach my $p ( $self->{cgi}->param ) {
504 0 0 0       next if $p eq $self->{logoff_param}
      0        
      0        
505             || $p eq $self->{changep_param}
506             || $p eq $self->{cookie_id}
507             || $p eq $self->{cookie_id} . '_new';
508 0           push @qs, $p . q{=} . $self->{cgi}->param( $p );
509             }
510 0           my $url = $self->{program};
511 0 0         if ( @qs ) {
512 0           $url =~ s{\?}{}xmsg;
513 0           $url .= q{?} . join q{&}, @qs;
514             }
515 0           $refresh_url = $url;
516             }
517              
518             # Set template vars
519 0           $self->{page_logoff_link} = $self->logoff_link;
520 0           $self->{page_content} = $p{content};
521 0           $self->{page_title} = $p{title};
522 0 0         $self->{page_refresh} = $p{forward}
523             ? qq~~
524             : EMPTY_STRING
525             ;
526 0 0         $self->{page_inline_refresh} = $p{forward}
527             ? qq~»~
528             : EMPTY_STRING
529             ;
530 0   0       my $out = $self->_compile_template('screen') || <<"MAIN_TEMPLATE";
531            
532            
533             $self->{page_refresh}
534             $self->{page_title}
535            
544            
545            
546             $self->{'page_logoff_link'}
547             $self->{'page_content'}
548             $self->{'page_inline_refresh'}
549            
550            
551             MAIN_TEMPLATE
552 0           my $header = $self->{cgi}->header(
553             -charset => $self->{http_charset},
554             @cookie
555             );
556 0           my $pok = print $header . $out;
557 0           return $self->_exit_program;
558             }
559              
560             sub fatal_header {
561 0     0 1   my($self, @args) = @_;
562 0 0         $FATAL_HEADER = shift @args if @args;
563 0   0       return $FATAL_HEADER || qq~Content-Type: text/html; charset=ISO-8859-1\n\n~;
564             }
565              
566             # Trap deadly errors
567             sub _fatal {
568 0     0     my $self = shift;
569 0   0       my $error = shift || EMPTY_STRING;
570 0           my @rep = caller 0;
571 0           my @caller = caller 1;
572 0           $rep[1] =~ s{.*[\\/]}{}xms;
573 0           $caller[1] =~ s{.*[\\/]}{}xms;
574 0           my $class = ref $self;
575 0           my $fatal = $self->fatal_header;
576 0           $fatal .= <<"FATAL";
577            
578            
579             Flawless Victory
580            
585            
586            
587            

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