File Coverage

blib/lib/CGI/AuthRegister.pm
Criterion Covered Total %
statement 26 1026 2.5
branch 1 402 0.2
condition 0 99 0.0
subroutine 8 61 13.1
pod 4 45 8.8
total 39 1633 2.3


line stmt bran cond sub pod time code
1             # file: AuthRegister.pm
2             # CGI::AuthRegister - AuthRegister Module for Simple CGI Authentication and
3             # Registration in Perl
4             # (c) 2012-20 Vlado Keselj http://vlado.ca
5              
6             package CGI::AuthRegister;
7 1     1   5766 use strict;
  1         2  
  1         35  
8 1     1   5 use vars qw($NAME $ABSTRACT $VERSION);
  1         2  
  1         85  
9             $NAME = 'AuthRegister';
10             $ABSTRACT = 'AuthRegister Module for Simple CGI Authentication and '.
11             'Registration in Perl';
12             $VERSION = '1.402'; # Last update: 2020-11-09
13              
14 1     1   969 use CGI qw(:standard);
  1         35478  
  1         8  
15             # Useful diagnostics:
16             # use CGI qw(:standard :Carp -debug);
17             # use CGI::Carp 'fatalsToBrowser';
18             # use diagnostics; # verbose error messages
19             # use strict; # check for mistakes
20 1     1   3867 use Carp;
  1         2  
  1         115  
21             require Exporter;
22 1     1   7 use vars qw(@ISA @EXPORT);
  1         2  
  1         145  
23             @ISA = qw(Exporter);
24             @EXPORT = qw($AddAuthenticatedUser $DebugLevel $Error $SessionId
25             $SiteId $SiteName $User $UserEmail $UserId $SendLogs $LogReport
26             $LDAPuse $LDAPserver $LDAPdn $LDAPaddUsers $LinkForgotpwd
27             $GenCasPageCustom
28             analyze_cookie header_delete_cookie header_session_cookie
29             import_dir_and_config login logout
30             require_https require_login run_cas send_email_reminder
31             get_user get_user_by_userid send_email_to_admin
32             set_new_session store_log
33             );
34              
35 1         3574 use vars qw( $AddAuthenticatedUser
36             $DBdir $DBusers $DBpwd $DBsessions $DBusersCas $DBpwdCas
37             $DBsessionsCas $DBcasTokens $DebugLevel
38             $Email_admin $Email_from $Email_bcc $Error $ErrorInternal
39             $GenCasPageCustom $Header $LogReport
40             $LDAPuse $LDAPserver $LDAPdn $LDAPaddUsers $LinkForgotpwd
41             $Sendmail $Session $SessionId $SiteId $SiteName $Ticket
42 1     1   7 $User $UserEmail $UserId $SendLogs $SecretSalt);
  1         2  
43             $AddAuthenticatedUser = ''; # If user is authenticated and not in database,
44             # add user to the database. (it should replace $LDAPaddUsers)!!!
45             $DBdir = 'db'; # directory for stored data (822 db, sessions)
46             $DBusers = 'users.db'; # Users db
47             $DBusersCas = 'users-cas.db'; # CAS users db
48             $DBpwd = 'passwords'; # Passwords file
49             $DBpwdCas = 'passwords-cas'; # CAS passwords
50             $DBsessions = 'sessions.d'; # Sessions
51             $DBsessionsCas = 'sessions-cas.d'; # CAS sessions
52             $DBcasTokens = 'cas-tokens.db'; # CAS Tokens
53             # $Error = ''; # Appended error messages, OK to be sent to user
54             # $ErrorInternal = ''; # Appended internal error messages, intended
55             # for administrator
56             # $Header # Keeps the latest prepared HTTP header, if not printed
57             # $LogReport = ''; # Collecting some important log events if needed
58             $SecretSalt = &random_name; # Secret salt for generating secrets (e.g. tokens)
59             # $Session = ''; # Session data structure
60             # $SessionId = ''; # Session identifier, generated
61             $SiteId = 'Site'; # Site identifier, used in cookies and emails
62             $SiteName = 'Site'; # Site name, can include spaces
63             # $Ticket = ''; # Session ticket for security, generated
64             # $User = ''; # User data structure
65             # $UserEmail = ''; # User email address
66             # $SendLogs = ''; # If true, send logs by email to admin ($Email_bcc)
67              
68             $Email_from = ''; # Example: $SiteId.' ';
69             $Email_bcc = ''; # Example: $SiteId.' Bcc ';
70              
71             $Sendmail = "/usr/lib/sendmail"; # Sendmail with full path
72              
73             # Some function prototypes
74             sub putfile($@);
75              
76             ########################################################################
77             # Section: Configuration
78             # sets site id as the base directory name; imports configuration.pl if exists
79             sub import_dir_and_config {
80 0     0 1 0 my $base = `pwd`; $base =~ /\/([^\/]*)$/; $base = $1; $base =~ s/\s+$//;
  0         0  
  0         0  
  0         0  
81 0         0 $SiteId = $SiteName = $base;
82 0 0       0 if (-r 'configuration.pl') { package main; require 'configuration.pl'; }
  0         0  
83             }
84              
85             ########################################################################
86             # Section: HTTPS Connection and Cookies Management
87              
88             # Check that the connection is HTTPS and if not, redirect to HTTPS.
89             # It must be done before script produces any output.
90             sub require_https {
91 0 0   0 1 0 if ($ENV{'HTTPS'} ne 'on') {
92 0         0 print "Status: 301 Moved Permanently\n".
93             "Location: https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}\n\n";
94 0         0 exit 0; }
95             }
96              
97             # Used to run a CAS service. If not logged in, ask for userid and password.
98             # On success, offer to pass confirmation back to the site; on fail offer retry
99             # or go back to the site. If site not given, stay. If previously logged in
100             # offer to pass confirmation to the site. Handles ?logout requests.
101             # Allows parentheses in userid's for login, which are removed. This allows
102             # users to use auxiliary comments with userid, so that browser can distinguish
103             # passwords.
104             sub run_cas {
105 0     0 0 0 my %params = @_;
106 0         0 my $querystring = $ENV{QUERY_STRING};
107 0         0 $DBusers = $DBusersCas; $DBpwd = $DBpwdCas; $DBsessions = $DBsessionsCas;
  0         0  
  0         0  
108 0         0 &import_dir_and_config; &require_https;
  0         0  
109 0 0 0     0 if ($querystring eq '' && param('querystring')) {
110 0         0 $querystring=param('querystring') }
111 0 0       0 if ($querystring eq 'cas-all.css') { &deliver('cas-all.css') }
  0         0  
112 0 0       0 if ($querystring eq 'cas-mobile.css') { &deliver('cas-mobile.css') }
  0         0  
113              
114 0 0 0     0 if (param('rt') ne '' && param('rt') eq 'verify') {
115 0         0 my $username = param('username'); my $stoken = param('stoken');
  0         0  
116 0         0 my $r = &_db8_find_first("$DBdir/$DBcasTokens", 'k=stoken', $stoken);
117 0         0 my $ans = 'fail';
118 0 0 0     0 if ($r ne '' and $r->{stoken} eq $stoken and $r->{userid} eq $username) {
      0        
119 0         0 $ans = 'ok';
120 0 0       0 if ($DebugLevel > 5) { $LogReport .= "CAS verification OK for ".
  0         0  
121 0         0 "username($username) stoken($stoken)"; &store_log; }
122             }
123 0 0       0 if ($ans ne 'ok') {
124 0         0 print header(), "answer:fail\n";
125 0 0       0 if ($DebugLevel > 5) { $LogReport .= "CAS verify failed for ".
  0         0  
126             "username($username) stoken($stoken)"; }
127 0         0 &store_log; exit(); }
  0         0  
128 0         0 &_db8_remove("$DBdir/$DBcasTokens", 'k=stoken', $stoken);
129 0         0 print header(), "answer:ok\n"; exit();
  0         0  
130             }
131            
132 0         0 my $redirect_uri;
133 0 0       0 if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }
  0 0       0  
134 0         0 elsif (param('r') ne '') { $redirect_uri = param('r') }
135              
136             ### Helper functions: finishGeneral, finishWithPageBack
137              
138             local *finishGeneral = sub {
139 0     0   0 my $page = &gen_cas_page;
140 0 0       0 if ($redirect_uri ne '') {
141 0         0 my $h = "
142             "value=\"$redirect_uri\">";
143 0         0 $page=~ s//$h\n$&/;
144 0         0 my $t = "CAS Authentication requested by the following site:
\n".
145             "".&htmlquote($redirect_uri)."";
146 0         0 $page =~ s/(.*?\n\n/\n/s;
160 0         0 $page =~ s/.*?\n\n/\n/s;
161 0 0       0 if ($redirect_uri ne '') {
162 0         0 my $stoken = &gen_secret; $userid=~s/["<>]//g;
  0         0  
163 0         0 my $f = "$DBdir/$DBcasTokens";
164 0 0 0     0 if (!-f $f && !&check_db_files) { $LogReport.=$Error; &store_log;
  0         0  
  0         0  
165 0         0 print "Error: $Error"; exit; }
  0         0  
166 0 0       0 if (!-f $f) { putfile $f, ''; chmod 0600, $f; }
  0         0  
  0         0  
167 0         0 &_db8_append($f, "userid:$userid\nstoken:$stoken" );
168 0 0       0 if ($Error ne '') { $LogReport.=$Error; &store_log;
  0         0  
  0         0  
169 0         0 print "Error: $Error"; exit; }
  0         0  
170 0         0 my $h = "";
171 0         0 $page=~ s//$h\n$&/;
172 0         0 $h = "";
173 0         0 $page=~ s//$h\n$&/;
174 0         0 $page =~ s/(
175 0         0 my $r = &encodeuri($redirect_uri);
176 0         0 $page =~ s/(
177 0         0 } else { $page =~ s///s; }
178 0         0 print $page;
179             # Log out user so that they have to login every time they use the service
180 0         0 logout();
181 0         0 exit;
182 0         0 };
183             ### End of helper functions
184            
185             # Check redirect_uri
186 0 0 0     0 if ($redirect_uri ne '' &&
      0        
187             $redirect_uri !~ /^https:\/\/(\w|[-.~\/])+/i &&
188             $redirect_uri !~ /^http:\/\/(\w|[-.~\/:])+/i ## This is temporary for a student project
189             ## It is probably is too relaxed.
190             ) {
191 0         0 my $page = &gen_cas_page;
192 0         0 my $h = 'redirect_uri Error!';
193 0         0 my $t = "URI of the requesting site is not in an acceptable format:
\n".
194             "".&htmlquote($redirect_uri)."
\n".
195             "Please check with the CAS maintainer if you think that this URI ".
196             "should be accepted. The rules include a requirement that the URI ".
197             "starts with 'https://' (including uppercase), and can have only some ".
198             "standard characters. It is possible that more characters should be ".
199             "allowed.";
200 0         0 $page =~ s/(.*?//s;
203 0         0 print header(), $page; exit;
  0         0  
204             }
205              
206 0 0 0     0 if ($querystring eq 'forgotpwd' or param('rt') eq 'forgotpwd') {
207 0 0       0 if ($LinkForgotpwd) { print CGI::redirect(-uri=>$LinkForgotpwd); exit; }
  0         0  
  0         0  
208 0         0 my $page = &gen_cas_page; my $h = 'Send Password';
  0         0  
209 0         0 my $t = "Enter your UserID or Email to have password reset and sent to ".
210             "you by email.\nIf you do not receive email, it may mean that you are ".
211             "not registered in the system, and you should contanct the administrator.";
212 0         0 $page =~ s/(.*?\n\n/\n/s;
215 0         0 $page =~ s/(
216 0         0 print header(), $page; exit;
  0         0  
217             }
218            
219 0         0 my $title = "Login Page for Site: $CGI::AuthRegister::SiteName";
220 0         0 my $HTMLstart = "$title

$title

\n";
221 0         0 my $Formstart = "";
222 0         0 my $LoginForm = "

Please login with your DalFCS Account userid and password:
\n".$Formstart.

223             hidden('querystring',$querystring).
224             "\n\n".
CS Userid:".
225             textfield(-name=>"csuserid")."
".
226             "Password:".password_field(-name=>"password")."
227             '
 '.
228             "
\n";
229              
230             # $LoginForm.="
LogReport:\n$CGI::AuthRegister::LogReport\nError=$CGI::AuthRegister::Error\n";
231              
232 0         0 &analyze_cookie;
233              
234             # Logout from CAS
235 0 0 0     0 if ($CGI::AuthRegister::SessionId ne '' && param('keywords') eq 'logout') {
236 0         0 CGI::AuthRegister::logout(); print header(); &finishGeneral; }
  0         0  
  0         0  
237            
238 0 0       0 if ($SessionId ne '') { print header(); &finishWithPageBack; }
  0         0  
  0         0  
239              
240 0         0 my $Request_type = param('request_type');
241              
242 0 0       0 if ($Request_type eq 'Login') {
    0          
243 0         0 my $username = param('username'); my $password = param('password');
  0         0  
244 0         0 $username =~ s/\(.*\)//g; $username =~ s/\s+$//; $username =~ s/^\s+//;
  0         0  
  0         0  
245              
246 0 0       0 if (! &login($username, $password) ) {
247 0         0 my $page = &gen_cas_page;
248 0         0 my $t = "Unsuccessful login!
\n";
249 0 0       0 if ($redirect_uri ne '') {
250 0         0 my $h = "
251             "value=\"$redirect_uri\">";
252 0         0 $page=~ s//$h\n$&/;
253 0         0 $t.= "CAS Authentication requested by the following site:
\n".
254             "".&htmlquote($redirect_uri).""; }
255 0         0 $page =~ s/(.*?//s; # remove the form
270 0         0 print header(), $page;
271 0         0 $LogReport.=$Error; &store_log;
  0         0  
272 0         0 exit;
273             }
274             else { # should be: $Request_type eq ''
275 0         0 print header(); &finishGeneral; }
  0         0  
276 0         0 die; # Not supposed to be reached
277             }
278              
279              
280             # If not logged in, ask for userid/email and password. Catches ?logout
281             # request as well. Allows parentheses in userid/email for login, which are
282             # removed. This allows users to use auxiliary comments with userid, so that
283             # browser can distinguish passwords.
284             sub require_login {
285 0 0   0 0 0 my %args = @_; return &_require_login_using_cas(@_) if exists($args{-cas});
  0         0  
286 0         0 my $title = "Login Page for Site: $SiteId";
287 0         0 my $HTMLstart = "$title

$title

\n";
288 0         0 my $Formstart = "
";
289 0         0 my $Back = "Click here for the main page.\n";
290 0         0 my $LoginForm = "

Please log in to access the site:
\n".$Formstart.

291             "\n\n".
Userid or email:".
292             textfield(-name=>"userid")."
".
293             "Password:".password_field(-name=>"password")."
294             '
 '.
295             "
\n";
296 0         0 my $SendResetForm = "

If you forgot your password, it may be possible to ".

297             "retrieve it by email:
\n".$Formstart."Email: ".
298             textfield(-name=>"email_pw_send")."\n".
299             ''.
300             "\n".
301             "Or, you can reqest password to be reset and sent to you:
\n".
302             $Formstart."Email: ".textfield(-name=>"email_reset")."\n".
303             ''.
304             "\n";
305              
306 0         0 &analyze_cookie;
307 0 0 0     0 if ($SessionId ne '' && param('keywords') eq 'logout') {
308 0         0 logout(); print header_delete_cookie(),$HTMLstart,
  0         0  
309 0         0 "

You are logged out.\n", $LoginForm, $SendResetForm; exit; }

310              
311 0 0       0 if ($SessionId ne '') { print header(); return 1; }
  0         0  
  0         0  
312              
313 0         0 my $Request_type = param('request_type');
314              
315 0 0       0 if ($Request_type eq 'Login') {
    0          
    0          
316 0         0 my $email = param('userid'); my $password = param('password');
  0         0  
317 0         0 $email =~ s/\(.*\)//g; $email =~ s/\s+$//; $email =~ s/^\s+//;
  0         0  
  0         0  
318              
319 0 0       0 if (! &login($email, $password) ) { # checks for userid and email
320 0         0 print header(), $HTMLstart, "Unsuccessful login!\n";
321 0         0 print $LoginForm, $SendResetForm; exit;
  0         0  
322             }
323 0         0 else { print header_session_cookie(); return 1; }
  0         0  
324             }
325             elsif ($Request_type eq 'Send_Password') {
326 0         0 &send_email_reminder(param('email_pw_send'), 'raw');
327 0         0 print header(), $HTMLstart, "You should receive password reminder if ".
328             "your email is registered at this site.\n".
329             "If you do not receive remider, you can contact the administrator.\n",
330             $LoginForm, $SendResetForm;
331 0         0 $LogReport.=$Error; &store_log;
  0         0  
332 0         0 exit;
333             }
334             elsif ($Request_type eq 'Reset_Password') {
335 0         0 &reset_and_send_email_reminder(param('email_reset'), 'raw');
336 0         0 print header(), $HTMLstart, "You should receive new password if ".
337             "your email is registered at this site.\n".
338             "If you do not receive remider, you can contact the administrator.\n",
339 0         0 $LoginForm, $SendResetForm; exit;
340             }
341             else { # should be: $Request_type eq ''
342 0         0 print header(), $HTMLstart, $LoginForm, $SendResetForm; exit; }
  0         0  
343            
344 0         0 die; # Not supposed to be reached
345             }
346              
347             # parameters:
348             # -return_status=>1 rather than exiting on failure, return status
349             # return status values: 'logged out', 1, 'not logged in' 'login failed'
350             # If we want that user gets a suggestion to use CAS to login, then
351             # this option should not be used.
352             #
353             # -header_no_print=> do not print header on success, but keep in $Header
354             sub _require_login_using_cas {
355 0     0   0 my %args = @_; my $casurl = $args{-cas};
  0         0  
356 0         0 my $header_no_print = $args{-header_no_print};
357 0         0 my $retStatus;
358 0 0       0 $retStatus = $args{-return_status} if exists($args{-return_status});
359 0         0 my $title = "Login Page for Site: $SiteId";
360 0         0 my $HTMLstart = "$title

$title

\n";
361 0         0 my $casurl_r = "$casurl?r=".url();
362 0         0 my $LoginMsg = "

Please use CAS ".

363             "to login.\n";
364              
365 0         0 &analyze_cookie;
366 0 0 0     0 if ($SessionId ne '' && param('keywords') eq 'logout') {
367 0         0 logout(); print header_delete_cookie();
  0         0  
368 0 0       0 if ($retStatus) { return 'logged out' }
  0         0  
369 0         0 print $HTMLstart, "

You are logged out.\n", $LoginMsg; exit; }

  0         0  
370              
371 0 0       0 if ($SessionId ne '') {
372 0         0 my $header = header();
373 0 0       0 if ($header_no_print) { $Header=$header; return 1; }
  0         0  
  0         0  
374 0         0 print $header; return 1; }
  0         0  
375              
376 0         0 my $request_type = param('request_type');
377 0 0       0 if ($request_type ne 'Proceed') {
378 0 0       0 if ($retStatus) { print header(); return 'not logged in' }
  0         0  
  0         0  
379 0         0 print CGI::redirect(-uri=>$casurl_r);
380 0         0 exit; }
381 0         0 my $username = param('username'); my $stoken = param('stoken');
  0         0  
382 0 0 0     0 if ($username eq '' or $stoken eq '') {
383 0 0       0 print header(); if ($retStatus) { return 'not logged in' }
  0         0  
  0         0  
384 0         0 print $HTMLstart, $LoginMsg; exit; }
  0         0  
385              
386 0 0       0 if ($casurl !~ /^https:\/\//i) {
387 0         0 my $u = CGI::url(); $u=~ s/\/[^\/]+$//; $casurl = "$u/$casurl"; }
  0         0  
  0         0  
388              
389 0         0 require LWP::UserAgent; require HTTP::Request; require Mozilla::CA;
  0         0  
  0         0  
390 0         0 my $ua = LWP::UserAgent->new();
391 1     1   763 use HTTP::Request::Common qw(POST);
  1         23105  
  1         9408  
392 0         0 my $req = POST $casurl, [ rt=>'verify', username=>$username, stoken=>$stoken ];
393 0         0 my $resp = $ua->request($req);
394 0         0 my $result = 'fail';
395 0 0       0 if ($resp->is_success) {
396 0         0 my $message = $resp->decoded_content; $message =~ s/\s//g;
  0         0  
397 0 0       0 if ($message eq 'answer:ok') { $result = 'ok'; &_dbg383; }
  0         0  
  0         0  
398 0         0 else { $Error.=" message=($message);" }
399             } else {
400 0         0 $Error.= "HTTP POST error code: ". $resp->code. "\n".
401             "HTTP POST error message: ".$resp->message."\n";
402             }
403 0 0       0 if ($result ne 'ok') {
404 0         0 $Error.="ERR-401:verify failed, result=($result) casurl=($casurl)\n";
405 0         0 print header(); $LogReport.=$Error; &store_log;
  0         0  
  0         0  
406 0 0       0 if ($retStatus) { return 'login failed'; }
  0         0  
407 0         0 print $HTMLstart, "Unsuccessful login!\n"; exit; }
  0         0  
408 0 0       0 my $u = ($AddAuthenticatedUser ? &get_user_by_userid_or_add($username) :
409             &get_user_unique('userid', $username));
410 0 0       0 if ($u eq '') {
411 0         0 $Error.="408-ERR: no userid ($username)\n";
412 0         0 $LogReport.=$Error; &store_log;
  0         0  
413 0 0       0 print header(); if ($retStatus) { return 'login failed'; }
  0         0  
  0         0  
414 0         0 print $HTMLstart, "Unsuccessful login!\n"; &store_log; exit; }
  0         0  
  0         0  
415 0         0 $User = $u; &set_new_session($User);
  0         0  
416 0         0 $LogReport.="User $UserEmail logged in.\n"; &store_log;
  0         0  
417 0         0 print header_session_cookie(); return 1;
  0         0  
418             }
419              
420             # Requires session (i.e., to be logged in). Otherwise, makes redirection.
421             sub require_session {
422 0     0 1 0 my %args=@_; my $defaultcgi = 'index.cgi';
  0         0  
423 0 0 0     0 if (exists($args{-redirect}) && $args{-redirect} ne '' &&
      0        
424             $args{-redirect} ne $ENV{SCRIPT_NAME})
425 0         0 { $defaultcgi = $args{-redirect} }
426 0 0 0     0 if (exists($args{-back}) && $args{-back}) {
427 0         0 $defaultcgi.="?goto=$args{-back}";
428             }
429 0         0 &analyze_cookie;
430 0 0       0 if ($SessionId eq '') {
431 0 0       0 if ($ENV{SCRIPT_NAME} eq $defaultcgi) {
432 0         0 print CGI::header(), CGI::start_html, CGI::h1("159-ERR:Login required");
433 0         0 exit; }
434 0         0 print CGI::redirect(-uri=>$defaultcgi); exit;
  0         0  
435             }
436             }
437              
438             # Prepare HTTP header. If SessionId is not empty, generate cookie with
439             # the sessionid and ticket.
440             sub header_session_cookie {
441 0     0 0 0 my %args=@_; my $redirect=$args{-redirect};
  0         0  
442 0 0       0 if ($redirect ne '') {
443 0 0       0 if ($SessionId eq '') { return redirect(-uri=>$redirect) }
  0         0  
444             else {
445 0         0 return redirect(-uri=>$redirect,-cookie=>
446             cookie(-name=>$SiteId,
447             -value=>"$SessionId $Ticket"));
448             }
449             } else {
450 0 0       0 if ($SessionId eq '') { return header } else
  0         0  
451 0         0 { return header(-cookie=>cookie(-name=>$SiteId,
452             -value=>"$SessionId $Ticket")) }
453             }
454             }
455              
456             # Delete cookie after logging out. Return string.
457             sub header_delete_cookie {
458 0     0 0 0 return header(-cookie=>cookie(-name=>$SiteId, -value=>'', -expires=>"now")) }
459              
460             # Analyze cookie to detect session, and check the ticket as well. It
461             # should be called at the beginning of a script. $SessionId and
462             # $Ticket are set to empty string if not successful. The information
463             # about the session is stored in $DBdir/$DBsessions/$SessionId/session.info
464             # file. The structures $Session and $User are set if successful.
465             sub analyze_cookie {
466 0     0 1 0 my $c = cookie(-name=>$SiteId); # sessionid and ticket
467 0 0       0 if ($DebugLevel > 5) { $LogReport.="cookie:$SiteId:$c\n"; &store_log; }
  0         0  
  0         0  
468 0 0       0 if ($c eq '') { $SessionId = $Ticket = ''; return; }
  0         0  
  0         0  
469 0         0 ($SessionId, $Ticket) = split(/\s+/, $c);
470 0 0 0     0 if ($SessionId !~ /^[\w.:-]+$/ or $Ticket !~ /^\w+$/)
471 0         0 { $User = $SessionId = $Ticket = ''; return; }
  0         0  
472              
473             # check validity of session and set user variables
474 0         0 my $sessioninfofile = "$DBdir/$DBsessions/$SessionId/session.info";
475 0 0       0 if (!-f $sessioninfofile) { $SessionId = $Ticket = ''; return; }
  0         0  
  0         0  
476 0         0 my $se = &read_db_record("file=$sessioninfofile");
477 0 0 0     0 if (!ref($se) or $Ticket ne $se->{'Ticket'})
478 0         0 { $User = $SessionId = $Ticket = ''; return; }
  0         0  
479 0         0 $Session = $se;
480 0         0 $UserEmail = $se->{email}; $UserId = $se->{userid};
  0         0  
481 0 0       0 if ($UserEmail =~ /@/) { $User = &get_user_unique('email', $UserEmail) }
  0 0       0  
482 0         0 elsif ($UserId ne '') { $User = &get_user_unique('userid', $UserId) }
483 0         0 else { $Error.="435-ERR: Could not identify the user.\n"; goto E; }
  0         0  
484 0 0 0     0 if ($UserId ne '' && $User->{userid} ne $UserId) {
485 0         0 $Error.="437-ERR: Non-matching userid.\n"; goto E; }
  0         0  
486 0 0       0 if ($Error ne '') { goto E }
  0         0  
487 0         0 return 1;
488             E:
489 0 0       0 if ($Error ne '') { $LogReport.=$Error; &store_log; }
  0         0  
  0         0  
490 0         0 $User = $SessionId = $Ticket = ''; return;
  0         0  
491             }
492              
493             ########################################################################
494             # Section: Session Management
495              
496             # params: $email, opt: pwstore type: md5 raw
497             sub reset_password {
498 0 0   0 0 0 my $email = shift; my $pwstore = shift; $pwstore = 'md5' if $pwstore eq '';
  0         0  
  0         0  
499 0         0 my $password = &random_password(6); my $pwdf = "$DBdir/$DBpwd";
  0         0  
500 0 0       0 if (!-f $pwdf) { putfile $pwdf, ''; chmod 0600, $pwdf }
  0         0  
  0         0  
501 0 0       0 if (!&lock_mkdir($pwdf)) { $Error.="378-ERR:\n"; return ''; }
  0         0  
  0         0  
502 0 0       0 local *PH; open(PH, $pwdf) or croak($!);
  0         0  
503 0         0 my $content = '';
504 0         0 while () {
505 0         0 my ($e,$p) = split;
506 0 0       0 $content .= $_ if $e ne $email;
507             }
508 0         0 close(PH);
509 0         0 $content .= "$email ";
510 0 0       0 if ($pwstore eq 'raw') { $content.="raw:$password" }
  0 0       0  
511 0         0 elsif($pwstore eq 'md5') { $content.="md5:".md5_base64($password) }
512             #else { $content.="md5:".md5_base64($password) }
513 0         0 else { $content.="raw:$password" }
514 0         0 $content .= "\n";
515 0         0 putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);
  0         0  
  0         0  
516 0         0 return $password;
517             }
518              
519             sub md5_base64 {
520 0     0 0 0 my $arg=shift; require Digest::MD5; return Digest::MD5::md5_base64($arg); }
  0         0  
  0         0  
521              
522             sub random_password {
523 0 0   0 0 0 my $n = shift; $n = 8 unless $n > 0;
  0         0  
524 0         0 my @chars = (2..9, 'a'..'k', 'm'..'z', 'A'..'N', 'P'..'Z',
525             qw(, . / ? ; : - = + ! @ $ % *) );
526 0         0 return join('', map { $chars[rand($#chars+1)] } (1..$n));
  0         0  
527             }
528              
529             # removes session file and return the appropriate HTTP header
530             sub logout {
531 0 0   0 0 0 if ($Session eq '') { $Error.= "481-ERR: No session to log out\n"; return; }
  0         0  
  0         0  
532 0 0       0 if (!-d "$DBdir/$DBsessions/$SessionId") { $Error.="482-ERR: No session dir\n" }
  0         0  
533             else {
534 0         0 unlink(<$DBdir/$DBsessions/$SessionId/*>);
535 0         0 rmdir("$DBdir/$DBsessions/$SessionId"); }
536 0         0 $LogReport.=$Error."User UserId:$UserId UserEmail:$UserEmail logged out.\n";
537 0         0 &store_log; $Session = $SessionId = $Ticket = '';
  0         0  
538 0         0 return 1;
539             }
540              
541             # The first parameter can be an userid and email. (diff by @)
542             sub login {
543 0     0 0 0 my $email = shift; my $password = shift;
  0         0  
544 0         0 $email = lc $email; my $userid;
  0         0  
545 0 0       0 if ($email !~ /@/) { $userid=$email; $email=''; }
  0         0  
  0         0  
546 0 0       0 if ($email ne '') {
547 0 0       0 if (!&emailcheckok($email)) {
548 0         0 $Error.="402-ERR:Incorrect email address format"; return; }
  0         0  
549             #my $u = &get_user_by_email($email);
550 0         0 my $u = &get_user_unique('email', $email);
551 0 0       0 if ($u eq '') { $Error.='405-ERR:Email not registered'; return; }
  0         0  
  0         0  
552 0         0 $userid = $u->{userid};
553 0         0 $User = $u;
554             } else {
555 0 0       0 if ($userid eq '') { $Error.="409-ERR:Empty userid"; return; }
  0         0  
  0         0  
556 0 0 0     0 if ($LDAPuse and $LDAPaddUsers) {
557 0         0 return _login_ldap_add($userid, $password); }
558 0         0 my $u = &get_user_unique('userid', $userid);
559 0 0       0 if ($u eq '') { $Error.='531-ERR:Not exist-unique'; &store_log; return; }
  0         0  
  0         0  
  0         0  
560 0         0 $email = $u->{email};
561 0         0 $User = $u;
562             }
563             # Randomize more salt
564 0         0 $SecretSalt = md5_base64("$SecretSalt $password");
565              
566 0 0       0 if (!password_check($User, $password)) {
567 0         0 $Error.="418:Invalid password\n"; return ''; }
  0         0  
568              
569 0         0 &set_new_session($User);
570 0         0 $LogReport.="User $UserEmail logged in.\n"; &store_log;
  0         0  
571 0         0 return 1;
572             }
573              
574             sub _login_ldap_add {
575 0     0   0 my $userid = shift; my $password = shift;
  0         0  
576 0 0       0 if (!&password_check_ldap($userid, $password)) {
577 0         0 $Error.="570-ERR:Invalid password for LDAP\n"; return ''; }
  0         0  
578 0         0 my $u = &get_user_by_userid_or_add($userid);
579 0 0       0 if ($u eq '') { $Error.="572-ERR:\n"; &store_log; return; }
  0         0  
  0         0  
  0         0  
580 0         0 $User = $u;
581             # Randomize more salt
582 0         0 $SecretSalt = md5_base64("$SecretSalt $password");
583 0         0 &set_new_session($User);
584 0         0 $LogReport.="User userid:$userid logged in.\n"; &store_log;
  0         0  
585 0         0 return 1;
586             }
587              
588             sub set_new_session {
589 0     0 0 0 my $u = shift;
590 0         0 my $email = $u->{email};
591 0         0 my $userid = $u->{userid};
592 0 0 0     0 if ($email !~ /@/ && $userid !~ /\w/) {
593 0         0 $Error .= "586-ERR: No email nor userid\n"; return ''; }
  0         0  
594 0         0 my $sDir = "$DBdir/$DBsessions";
595 0 0 0     0 if (!-d $sDir && !&check_db_files) { return ''; }
  0         0  
596              
597 0         0 $^T =~ /\d{6}$/; my $sessionid = 't'.$&.'_';
  0         0  
598 0         0 my $a = $userid.'_'.$email,'______';
599 0         0 $a =~ /.*?(\w).*?(\w).*?(\w).*?(\w).*?(\w).*?(\w)/;
600 0         0 $sessionid.= $1.$2.$3.$4.$5;
601 0 0       0 if (! mkdir("$sDir/$sessionid", 0700)) {
602 0   0     0 my $cnt=1; for(;$cnt<100 and !mkdir("$sDir/${sessionid}_$cnt", 0700); ++$cnt) {}
  0         0  
603 0 0       0 croak "Cannot create sessions!" if $cnt == 100;
604 0         0 $sessionid = "${sessionid}_$cnt";
605             }
606 0         0 $SessionId = $sessionid; $Ticket = &gen_secret;
  0         0  
607 0         0 my $sessionrecord = "SessionId:$SessionId\nTicket:$Ticket\n";
608 0 0       0 $sessionrecord.="email:$email\n" if $email ne '';
609 0 0       0 $sessionrecord.="userid:$userid\n" if $userid ne '';
610 0         0 my $sessioninfofile = "$sDir/$SessionId/session.info";
611 0         0 putfile($sessioninfofile, $sessionrecord);
612 0         0 $UserEmail = $email; $UserId = $userid; $User = $u;
  0         0  
  0         0  
613 0         0 $Session = &read_db_record("file=$sessioninfofile");
614 0 0       0 die unless ref($Session);
615 0         0 return $SessionId;
616             }
617              
618             # Return 1 if OK, '' otherwise
619             sub password_check {
620 0     0 0 0 my $u = shift; my $password = shift;
  0         0  
621 0 0       0 if ($LDAPuse) { return &password_check_ldap($u->{userid}, $password); }
  0         0  
622 0         0 my $pwstored = &find_password($u->{email});
623 0 0       0 if ($pwstored =~ /^raw:/) {
624 0 0       0 $pwstored=$'; return ( ($pwstored eq $password) ? 1 : '' ); }
  0         0  
625 0 0       0 if ($pwstored =~ /^md5:/) {
626 0 0       0 $pwstored=$'; return ( ($pwstored eq md5_base64($password)) ? 1 : ''); }
  0         0  
627 0         0 $Error.="316-ERR:PWCheck error($pwstored)\n"; $ErrorInternal="AuthRegister:$Error"; return '';
  0         0  
  0         0  
628             }
629              
630             # Modifying for LDAP; Return 1 if OK, '' otherwise
631             sub password_check_ldap {
632 0     0 0 0 my $username = shift; my $password = shift;
  0         0  
633 0         0 $username =~ s/[^a-zA-Z0-9._+=-]//g;
634 0 0 0     0 if ($username eq '' or $LDAPserver eq '' or $LDAPdn eq '') { return '' }
  0   0     0  
635             #use Net::LDAP;
636 0         0 eval "require Net::LDAP;";
637 0 0       0 if ($@) { $Error.="643-ERR: Net::LDAP module required for LDAP ".
  0         0  
638 0         0 "functionality\n"; return ''; }
639 0         0 my $dn = "uid=$username,$LDAPdn";
640 0 0       0 my $ldap = Net::LDAP->new("ldaps://$LDAPserver") or die "$@";
641 0         0 my $mesg = $ldap->bind($dn, password => $password);
642 0 0       0 if ($mesg->code == 0) {
643             # Password correct
644 0         0 $ldap->unbind; $ldap->disconnect;
  0         0  
645 0         0 return 1;
646             }
647             # else invalid password
648 0         0 $ldap->unbind;
649 0         0 $ldap->disconnect;
650 0         0 return '';
651             }
652              
653             sub find_password {
654 0     0 0 0 my $email = shift; my $pwfile = "$DBdir/$DBpwd";
  0         0  
655 0         0 $email = lc $email;
656 0 0 0     0 if (!-f $pwfile && !&check_db_files) { return '' }
  0         0  
657 0 0       0 if (!&lock_mkdir($pwfile)) { $Error.="431-ERR:\n"; return ''; }
  0         0  
  0         0  
658 0 0       0 local *PH; if (!open(PH,$pwfile)) { &unlock_mkdir($pwfile);
  0         0  
  0         0  
659 0         0 $Error.="433-ERR: Cannot open ($pwfile):$!\n"; return ''; }
  0         0  
660 0         0 while () {
661 0         0 my ($e,$p) = split; $e = lc $e;
  0         0  
662 0 0       0 if ($e eq $email) { close(PH); &unlock_mkdir($pwfile); return $p; }
  0         0  
  0         0  
  0         0  
663             }
664 0         0 $Error.="NOTFOUND($email)";
665 0         0 close(PH); &unlock_mkdir($pwfile); return '';
  0         0  
  0         0  
666             }
667              
668             # Try to generate a secure random secret
669             # The best option is to use Math::Random::Secure if available
670             # This implementation uses its own additional randomization
671             sub gen_secret {
672 0 0   0 0 0 my $n = shift; $n = 10 unless $n > 0; my $ret;
  0         0  
  0         0  
673 0         0 while (length($ret) < $n) {
674 0         0 $SecretSalt.= md5_base64($SecretSalt.rand);
675 0         0 my $a=md5_base64($SecretSalt.rand); $a=~ s/[+\/]//g; $ret.=$a;
  0         0  
  0         0  
676             }
677 0         0 return substr($ret, 0, $n);
678             }
679              
680             sub random_name {
681 1 50   1 0 3 my $n = shift; $n = 8 unless $n > 0;
  1         6  
682 1         10 my @chars = (0..9, 'a'..'z', 'A'..'Z');
683 1         3 return join('', map { $chars[rand($#chars+1)] } (1..$n));
  8         71  
684             }
685              
686             sub store_log {
687 0 0   0 0   if($#_>=-1) { $LogReport.=$_[0] }
  0            
688 0 0         return if $LogReport eq '';
689 0 0         if ($SendLogs) { &send_email_to_admin('Log entry', $LogReport); }
  0            
690 0           $LogReport = '';
691             }
692              
693             ########################################################################
694             # Section: Email communication
695              
696             # params: $email, opt: 'raw' or 'md5' to generate passord
697             sub reset_and_send_email_reminder {
698 0     0 0   my $email = shift; my $pwstore = shift;
  0            
699 0           $email=lc $email; $email =~ s/\s/ /g;
  0            
700 0 0         if ($email eq '') {
701 0           $Error.="328-ERR:No e-mail provided to send password\n"; return; }
  0            
702 0 0         if (!emailcheckok($email)) {
703 0           $Error.="330-ERR:Invalid e-mail address provided($email)\n"; return; }
  0            
704 0           my $user = get_user_unique('email',$email);
705 0 0         if ($user eq '') {
706 0           $Error.="333-ERR: No user with email ($email)\n"; return; }
  0            
707 0           my $pw = &reset_password($email, $pwstore);
708 0           &send_email_reminder1($email, $pw);
709 0           return 1;
710             }
711              
712             # params: $email, opt: 'raw' or 'md5' to generate new password if not found
713             sub send_email_reminder {
714 0     0 0   my $email = shift; my $pwstore = shift;
  0            
715 0           $email=lc $email; $email =~ s/\s/ /g;
  0            
716 0 0         if ($email eq '') {
717 0           $Error.="505-ERR:No e-mail provided to send password\n"; return; }
  0            
718 0           my $user;
719 0 0         if ($email =~ /@/) { $user = &get_user_unique('email', $email) }
  0            
720 0           else { $user = &get_user_unique('userid', $email) }
721 0 0         if ($user eq '') {
722 0           $Error.="510-ERR: No user with userid/email ($email)\n"; return; }
  0            
723 0           $email = $user->{email};
724 0 0         if (!emailcheckok($email)) {
725 0           $Error.="513-ERR:Invalid e-mail address ($email)\n"; return; }
  0            
726 0           my $pw = find_password($email);
727 0 0         if ($pw =~ /^raw:/) { $pw = $' }
  0 0          
728 0           elsif ($pw ne '') { $Error.="516-ERR:Cannot retrieve password\n"; return; }
  0            
729 0           else { $pw = &reset_password($email, $pwstore) }
730              
731 0           &send_email_reminder1($email, $pw);
732 0           return 1;
733             }
734              
735             sub send_email_reminder1 {
736 0     0 0   my $email = shift; my $pw = shift;
  0            
737 0           my $httpslogin = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";
738              
739 0           my $msg = "Hi,\n\nYour email and password for the $SiteId site is:\n\n".
740             "Email: $email\nPassword: $pw\n\n".
741             "You can log in at:\n\n$httpslogin\n\n\n".
742             # "$HttpsBaseLink/login.cgi\n\n\n".
743             "Best regards,\n$SiteId Admin\n";
744 0           &send_email_to($email, "Subject: $SiteId Password Reminder", $msg);
745             }
746              
747             sub send_email_to_admin {
748 0     0 0   my $subject = shift; my $msg1 = shift;
  0            
749 0           $subject =~ s/\s+/ /g;
750 0           $subject = "Subject: [$SiteId System Report] $subject";
751 0 0         return if $Email_bcc eq '';
752 0           my $msg = '';
753 0 0         $msg.="From: $Email_from\n" unless $Email_from eq '';
754 0           $msg.="To: $Email_bcc\n";
755 0           $msg.="$subject\n\n$msg1";
756 0           &_send_email($msg);
757             }
758              
759             sub send_email_to {
760 0 0   0 0   my $email = shift; croak unless &emailcheckok($email);
  0            
761 0           my $subject = shift; $subject =~ s/[\n\r]/ /g;
  0            
762 0 0         if ($subject !~ /^Subject: /) { $subject = "Subject: $subject" }
  0            
763 0           my $msg1 = shift;
764              
765 0           my $msg = '';
766 0 0         $msg.="From: $Email_from\n" unless $Email_from eq '';
767 0           $msg.="To: $email\n";
768 0 0         $msg.="Bcc: $Email_bcc\n" unless $Email_bcc eq '';
769 0           $msg.="$subject\n\n$msg1";
770 0           &_send_email($msg);
771             }
772              
773             sub _send_email {
774 0     0     my $fullmessage = shift;
775 0 0         if (! -x $Sendmail) {
776 0           $Error.="390-ERR:No sendmail ($Sendmail)\n"; return ''; }
  0            
777 0           local *S;
778 0 0         if (!open(S,"|$Sendmail -ti")) {
779 0           $Error.="393-ERR:Cannot run sendmail:$!\n"; return ''; }
  0            
780 0           print S $fullmessage; close(S);
  0            
781             }
782              
783             ########################################################################
784             # Section: Data checks and transformations
785              
786             # encode string into a \w* sequence
787             sub encode_w {
788 0     0 0   local $_ = shift;
789 0           s/[\Wx]/'x'.uc unpack("H2",$&)/ge;
  0            
790 0           return $_;
791             }
792              
793             sub decode_w {
794 0     0 0   local $_ = shift;
795 0           s/x([0-9A-Fa-f][0-9A-Fa-f])/pack("c",hex($1))/ge;
  0            
796 0           return $_;
797             }
798              
799             sub encodeuri($) {
800 0     0 0   local $_ = shift;
801 0           s/[^-A-Za-z0-9_.~:\/?=]/"%".uc unpack("H2",$1)/ge;
  0            
802 0           return $_;
803             }
804              
805             # Prepare for HTML display by quoting meta characters.
806 0     0 0   sub htmlquote($) { local $_ = shift; s/&/&/g; s/
  0            
  0            
  0            
807              
808             sub emailcheckok {
809 0     0 0   my $email = shift;
810 0 0         if ($email =~ /^[a-zA-Z][\w\.+-]*[a-zA-Z0-9+-]@
811             [a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$/x)
812 0           { return 1 }
813 0           return '';
814             }
815              
816             sub useridcheckok {
817 0 0   0 0   my $userid = shift; return 1 if $userid=~/^[a-zA-Z0-9-]+$/; return ''; }
  0            
  0            
818              
819             # DB related functions
820              
821             sub read_users_db {
822 0     0 0   my $f = "$DBdir/$DBusers";
823 0 0         if (!-f $f) { $Error.= "636-ERR: no file $f\n"; return; }
  0            
  0            
824 0           return &read_db("file=$f") }
825              
826             sub _db8_find_first {
827 0     0     my $dbf = shift; my $k = shift; my $v = shift;
  0            
  0            
828 0 0         die unless $k =~ /^k=/; $k = $';
  0            
829 0           my $db_ref = &read_db("file=$dbf");
830 0 0         if (ref($db_ref) ne 'ARRAY') {
831 0           $Error.="745-ERR: Could not read db file ($dbf)"; return ''; }
  0            
832 0           my @db = @{ $db_ref };
  0            
833 0           for my $r (@db) {
834 0 0 0       if (exists($r->{$k}) && $v eq $r->{$k}) { $Error.="FOUND\n"; return $r } }
  0            
  0            
835 0           return '';
836             }
837              
838             sub get_user {
839 0     0 0   my $k = shift; my $v = shift;
  0            
840 0           my $db_ref = &read_users_db;
841 0 0         if (ref($db_ref) ne 'ARRAY') {
842 0           $Error.="AuthERR-836: Could not get users data (file system problem?)\n";
843 0           return $User='';
844             }
845 0           my @db = @{ $db_ref };
  0            
846 0           for my $r (@db)
847 0 0 0       { if (exists($r->{$k}) && $v eq $r->{$k}) { return $User=$r } }
  0            
848 0           $Error.="AuthERR-842: no user with key=($k) v=($v)\n"; return $User='';
  0            
849             }
850              
851             sub get_user_by_email {
852 0     0 0   my $email = shift;
853 0           my $db_ref = &read_users_db;
854 0 0         if (ref($db_ref) ne 'ARRAY') {
855 0           $Error.="657-ERR: Could not get users data (file system problem?)";
856 0           return $User=''; }
857 0           my @db = @{ $db_ref };
  0            
858 0 0         for my $r (@db) { if (lc($email) eq lc($r->{email})) { return $User=$r } }
  0            
  0            
859 0           $Error.="661-ERR: no user with email ($email)\n"; return $User='';
  0            
860             }
861              
862 0     0 0   sub get_user_by_userid { return &get_user('userid', $_[0]) }
863              
864             # Get user by userid, or add userid if does not exist
865             sub get_user_by_userid_or_add {
866 0     0 0   my $userid = shift; my $f = "$DBdir/$DBusers";
  0            
867 0 0 0       if (!-f $f && !&check_db_files) { return '' }
  0            
868 0           my @db = @{ &read_db("file=$f") };
  0            
869 0           my $u = '';
870 0           for my $r (@db) {
871 0 0         next unless exists($r->{userid}); my $v1 = $r->{userid};
  0            
872 0           $v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;
  0            
  0            
  0            
873 0 0         next unless $v1 eq $userid;
874 0 0         if ($u eq '') { $u = $r; next; }
  0            
  0            
875 0           $Error.= "819-ERR: double userid ($userid)\n"; return '';
  0            
876             }
877 0 0         return $User=$u unless $u eq '';
878 0           $userid =~ s/\s//g; &_db8_append($f, "userid:$userid");
  0            
879 0           return get_user_by_userid($userid);
880             }
881              
882             # Get user by a key,value, but make sure there is exactly one such user
883             # Normalizes whitespace and case insensitive
884             sub get_user_unique {
885 0     0 0   my $k = shift; my $v = shift; my $f = "$DBdir/$DBusers";
  0            
  0            
886 0 0 0       if (!-f $f && !&check_db_files) { return '' }
  0            
887 0           my @db = @{ &read_db("file=$f") };
  0            
888 0           $v=~s/^\s+//; $v=~s/\s+$//; $v=~s/\s+/ /g; $v = lc $v;
  0            
  0            
  0            
889 0 0 0       if ($k eq '' or $v eq '')
890 0           { $Error.="669-ERR:Empty k or v ($k:$v)\n"; return ''; }
  0            
891 0           my $u = '';
892 0           for my $r (@db) {
893 0 0         next unless exists($r->{$k}); my $v1 = $r->{$k};
  0            
894 0           $v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;
  0            
  0            
  0            
895 0 0         next unless $v eq $v1;
896 0 0         if ($u eq '') { $u = $r; next; }
  0            
  0            
897 0           $Error.= "676-ERR: double user key ($k:$v)\n"; return '';
  0            
898             }
899 0 0         return $User=$u unless $u eq '';
900 0           $Error.="894-ERR: no user with key ($k:$v)\n"; return '';
  0            
901             }
902              
903             sub check_db_files {
904 0     0 0   my $ret; my $pwfile = "$DBdir/$DBpwd";
  0            
905 0 0         if (!-d $DBdir) { $ret = mkdir($DBdir, 0700);
  0            
906 0 0         if (!$ret) { $Error.="687-ERR: Could not create dir '$DBdir'"; return ''; }}
  0            
  0            
907 0 0         if (!-f $pwfile) { putfile $pwfile, ''; chmod 0600, $pwfile; }
  0            
  0            
908 0 0         if (!-f $pwfile) { $Error.="689-ERR: Could not create $pwfile file";
  0            
909 0           return ''; }
910 0           my $f = "$DBdir/$DBusers";
911 0 0         if (!-f $f) { putfile $f, "#userid:someid\n#email:email\@domain.com\n";
  0            
912 0           chmod 0600, $f; }
913 0 0         if (!-f $f) { $Error.="694-ERR: Could not create $f file"; return ''; }
  0            
  0            
914 0           $f = "$DBdir/$DBsessions";
915 0 0         if (!-d $f) { $ret = mkdir($f, 0700);
  0            
916 0 0         if (!$ret) { $Error.="708-ERR: Could not create dir '$f'"; return ''; }}
  0            
  0            
917              
918 0           return 1;
919             }
920              
921             sub _db8_remove {
922 0     0     my $dbf = shift; my $kdel = shift; my $vdel = shift;
  0            
  0            
923 0 0         die unless $kdel =~ /^k=/; $kdel = $';
  0            
924 0 0         if (!&lock_mkdir($dbf)) { $Error.="793-ERR"; return '' }
  0            
  0            
925 0 0         local *F; if (!open(F, $dbf)) { &unlock_mkdir($dbf);
  0            
  0            
926 0           $Error.="795-ERR: opening file $dbf: $!"; return ''; }
  0            
927 0           my $arg = join('',); close(F);
  0            
928              
929 0           my $arg_save = $arg; my $dbi = 0; my $argcopy = '';
  0            
  0            
930 0           while ($arg) {
931 0           my $prologue;
932 0 0         if ($arg =~ /^([ \t\r]*(#.*)?\n)+/) { $prologue = $&; $arg = $'; }
  0            
  0            
933 0           $argcopy.=$prologue;
934 0 0         last if $arg eq ''; my $record; my $record_save;
  0            
935 0 0         if ($arg =~ /([ \t\r]*\n){2,}/) {
936 0           $record = "$`\n"; $arg = $'; $record_save = "$`$&"; }
  0            
  0            
937 0           else { $record_save = $record = $arg; $arg = ''; }
  0            
938 0           my $r = {};
939 0           while ($record) {
940 0 0         $record =~ /^[ \t]*([^\n:]*?)[ \t]*:/ or die "db8: no attribute";
941 0           my $k = $1; $record = $';
  0            
942 0           while ($record =~ /^(.*)(\\\r?\n|\r?\n[ \t]+)(\S.*)/)
943 0           { $record = "$1 $3$'" }
944 0 0         $record =~ /^[ \t]*(.*?)[ \t\r]*\n/ or die;
945 0           my $v = $1; $record = $';
  0            
946 0 0         if (exists($r->{$k})) {
947 0           my $c = 0;
948 0           while (exists($r->{"$k-$c"})) { ++$c }
  0            
949 0           $k = "$k-$c";
950             }
951 0           $r->{$k} = $v;
952             }
953 0 0 0       if (exists($r->{$kdel}) && $r->{$kdel} eq $vdel) {}
954 0           else { $argcopy .= $record_save }
955             }
956              
957 0 0         if ($argcopy ne $arg_save) {
958 0 0         if (!open(F, ">$dbf.lock/new")) { &unlock_mkdir($dbf);
  0            
959 0           $Error.="828-ERR: opening file $dbf.lock/new: $!"; return ''; }
  0            
960 0           print F $argcopy; close(F); chmod 0600, "$dbf.lock/new"; unlink($dbf);
  0            
  0            
  0            
961 0           rename("$dbf.lock/new", $dbf); }
962 0           &unlock_mkdir($dbf);
963             } # end of _db8_remove
964              
965             # Read DB records in the RFC822-like style (to add reference).
966             sub read_db {
967 0     0 0   my $arg = shift;
968 0 0         if ($arg =~ /^file=/) {
969 0 0         my $f = $'; if (!&lock_mkdir($f)) { return '' }
  0            
  0            
970 0           local *F;
971 0 0         if (!open(F, $f)) {
972 0           $Error.="ERR-945: $f: $!"; &unlock_mkdir($f); return ''; }
  0            
  0            
973 0           $arg = join('', ); close(F); &unlock_mkdir($f);
  0            
  0            
974             }
975              
976 0           my $db = [];
977 0           while ($arg) {
978 0           $arg =~ s/^\s*(#.*\s*)*//; # allow comments betwen records
979 0           my $record;
980 0 0         if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }
  0            
  0            
981 0           else { $record = $arg; $arg = ''; }
  0            
982 0           my $r = {};
983 0           while ($record) {
984 0 0         if ($record =~ /^#.*\n?/) { $record=$'; next; }
  0            
  0            
985 0           while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)
986 0           { $record = "$1 $3$'" }
987 0 0         $record =~ /^([^\n:]*):(.*)\n/ or die;
988 0           my $k = $1; my $v = $2; $record = $';
  0            
  0            
989 0 0         if (exists($r->{$k})) {
990 0           my $c = 0;
991 0           while (exists($r->{"$k-$c"})) { ++$c }
  0            
992 0           $k = "$k-$c";
993             }
994 0           $r->{$k} = $v;
995             }
996 0           push @{ $db }, $r;
  0            
997             }
998 0           return $db;
999             }
1000              
1001             # Append a record or records to db8
1002             # Assumes that the file is in a good format
1003             sub _db8_append {
1004 0     0     my $fdb=shift;
1005 0 0         if (!&lock_mkdir($fdb)) { $Error.="ERR-975: $!"; return '' }
  0            
  0            
1006 0 0         local *F; if (!open(F, ">>$fdb")) { &unlock_mkdir($fdb);
  0            
  0            
1007 0           $Error.="ERR-977: write file $fdb: $!"; return ''; }
  0            
1008 0           while (@_) { my $r=shift; $r =~ s/\s*$/\n/s; print F "\n$r"; }
  0            
  0            
  0            
1009 0           &unlock_mkdir($fdb);
1010             }
1011              
1012             # Read one DB record in the RFC822-like style (to add reference).
1013             sub read_db_record {
1014 0     0 0   my $arg = shift;
1015 0 0         if ($arg =~ /^file=/) {
1016 0 0         my $f = $'; local *F; open(F, $f) or die "cannot open $f:$!";
  0            
  0            
1017 0           $arg = join('', ); close(F);
  0            
1018             }
1019              
1020 0           while ($arg =~ s/^(\s*|\s*#.*)\n//) {} # allow comments before record
1021 0           my $record;
1022 0 0         if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }
  0            
  0            
1023 0           else { $record = $arg; $arg = ''; }
  0            
1024 0           my $r = {};
1025 0           while ($record) {
1026 0           while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)
1027 0           { $record = "$1 $3$'" }
1028 0 0         $record =~ /^([^\n:]*):(.*)\n/ or die;
1029 0           my $k = $1; my $v = $2; $record = $';
  0            
  0            
1030 0 0         if (exists($r->{$k})) {
1031 0           my $c = 0;
1032 0           while (exists($r->{"$k-$c"})) { ++$c }
  0            
1033 0           $k = "$k-$c";
1034             }
1035 0           $r->{$k} = $v;
1036             }
1037 0           return $r;
1038             }
1039              
1040             sub putfile($@) {
1041 0     0 0   my $f = shift; local *F;
  0            
1042 0 0         if (!open(F, ">$f")) { $Error.="325-ERR:Cannot write ($f):$!\n"; return; }
  0            
  0            
1043 0           for (@_) { print F } close(F);
  0            
  0            
1044             }
1045              
1046             ########################################################################
1047             # Section: Simple file locking using mkdir
1048              
1049             # Exlusive locking using mkdir
1050             # lock_mkdir($fname); # return 1=success ''=fail
1051             sub lock_mkdir {
1052 0     0 0   my $fname = shift; my $lockd = "$fname.lock"; my $locked;
  0            
  0            
1053             # First, hopefully most usual case
1054 0 0 0       if (!-e $lockd && ($locked = mkdir($lockd,0700))) { return $locked }
  0            
1055 0           my $tryfor=10; #sec
1056 0           $locked = ''; # flag
1057 0           for (my $i=0; $i<2*$tryfor; ++$i) {
1058 0           select(undef,undef,undef,0.5); # wait for 0.5 sec
1059 0 0         !-e $lockd && ($locked = mkdir($lockd,0700));
1060 0 0         if ($locked) { return $locked }
  0            
1061             }
1062 0           $Error.="393-ERR:Could not lock file ($fname)\n"; return $locked;
  0            
1063             }
1064              
1065             # Unlock using mkdir
1066             # unlock_mkdir($fname); # return 1=success ''=fail or no lock
1067             sub unlock_mkdir {
1068 0     0 0   my $fname = shift; my $lockd = "$fname.lock";
  0            
1069 0 0         if (!-e $lockd) { $Error.="400-ERR:No lock on ($fname)\n"; return '' }
  0            
  0            
1070 0 0         if (-d $lockd) { return rmdir($lockd) }
  0            
1071 0 0 0       if (-f $lockd or -l $lockd) { unlink($lockd) }
  0            
1072 0           $Error.="403-ERR:Unknown error"; return '';
  0            
1073             }
1074              
1075             ########################################################################
1076             # Section: Prepackaged HTML and CSS files
1077              
1078             sub gen_cas_page {
1079 0     0 0   my $ret;
1080             #
1081             # echo "\$ret=<<'EOT';\n${c}EOT"; !>#+
1082 0           $ret=<<'EOT';
1083            
1084             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1085            
1086             CAS - Central Authentication Service
1087            
1088            
1089            
1090            
1091            
1092             media="handheld, only screen and (max-device-width: 480px)" type="text/css">
1093              
1094            
1099              
1100            
1105            
1106              
1107            
1108            
1109            

CAS – Central Authentication

1110             Service
1111              
1112            
1113              
1114            
1115            
1116            
 
1117            
1118            

Login Required

1119            

CAS Authentication

1120            

1121              
1122            
1123            

UserID:
1124            
1125            
1126             size="20" autocomplete="off" type="text">
1127            
1128              
1129            
1130            
1131            

Password:
1132            
1133            
1134             value="" size="20" autocomplete="off" type="password">
1135            
1136              
1137            
 
1138            
1139            
1140            
1141             name="request_type">
1142              
1143            
1144              
1145            

Please note
1146             Before entering your userid and password, verify that the URL
1147             for this page begins with:
1148             _THIS_URL_
1149            

1150             To protect your privacy, quit your web browser when you
1151             are done accessing services that require authentication.
1152            

1153            
1154            
1155            
1156              
1157            
1158            
1159            
1160            
1161            
1162            
1163            
1164            
1165            
1166              
1167            
1168            
1169            
1170            
1171            
1172            
1173              
1174            
1175            
1176            
1177             EOT#-
1178             #+
1179             $ret=<<'EOT';
1180            
1181             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1182            
1183             CAS - Central Authentication Service
1184            
1185            
1186            
1187            
1188            
1189             media="handheld, only screen and (max-device-width: 480px)" type="text/css">
1190              
1191            
1196              
1197            
1202            
1203              
1204            
1205            
1206            

CAS – Central Authentication

1207             Service
1208              
1209            
1210              
1211            
1212            
1213            
 
1214            
1215            

Login Required

1216            

CAS Authentication

1217            

1218              
1219            
1220            

UserID:
1221            
1222            
1223             size="20" autocomplete="off" type="text">
1224            
1225              
1226            
1227            
1228            

Password:
1229            
1230            
1231             value="" size="20" autocomplete="off" type="password">
1232            
1233              
1234            
 
1235            
1236            
1237            
1238             name="request_type">
1239              
1240            
1241              
1242            

Please note
1243             Before entering your userid and password, verify that the URL
1244             for this page begins with:
1245             _THIS_URL_
1246            

1247             To protect your privacy, quit your web browser when you
1248             are done accessing services that require authentication.
1249            

1250            
1251            
1252            
1253              
1254            
1255            
1256            
1257            
1258            
1259            
1260            
1261            
1262            
1263              
1264            
1265            
1266            
1267            
1268            
1269            
1270              
1271            
1272            
1273            
1274             EOT
1275             #-
1276 0 0         if ($GenCasPageCustom ne '') { $ret = $GenCasPageCustom }
  0            
1277            
1278 0           my $cssCasAll = $ENV{SCRIPT_NAME}.'?cas-all.css';
1279 0           my $cssCasMobile = $ENV{SCRIPT_NAME}.'?cas-mobile.css';
1280 0           $ret=~ s/href="cas-all.css"/href="$cssCasAll"/;
1281 0           $ret=~ s/href="cas-mobile.css"/href="$cssCasMobile"/;
1282              
1283 0           my $redirect_uri;
1284 0 0         if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }
  0 0          
1285 0           elsif (param('r') ne '') { $redirect_uri = param('r') }
1286            
1287             # Remove "Before entering" unless there is a URL to show (todo, for now,
1288             # just remove)
1289 0           $ret=~ s/.*?(<\/p>)/$1/s;
1290              
1291 0           my $forgotpassword = 1; # include link, todo for exclusion
1292 0           my $removerighthandside = 1;
1293 0 0         if ($forgotpassword) {
1294 0           $removerighthandside=''; $ret=~s//$1/g; }
  0            
1295 0 0         if ($SessionId ne '') { $ret=~s//$1/g; }
  0            
1296            
1297 0           $ret=~s///g;
1298              
1299             # Remove righthand side
1300 0 0         if($removerighthandside) {
1301 0           $ret =~
1302             s/(
)(.*?)(<\/div>)/$1$3/s;
1303             }
1304             else { # remove "hideinMobile"
1305 0           $ret =~ s///; }
1306            
1307 0           return $ret;
1308             }
1309              
1310             sub deliver {
1311 0     0 0   my $par = shift;
1312 0 0         if ($par eq 'cas-all.css') {
    0          
1313 0           print "Content-Type: text/css; charset=UTF-8\n\n".
1314             #
1315             # echo "<<'EOT';\n${c}EOT\n;"; !>#+
1316             <<'EOT';
1317             body {
1318             background-color: #D1AF55; /*#76A9DC;*/
1319             color: #444;
1320             font-family: "Times New Roman", Times, serif;
1321             margin: 30px;
1322             padding: 5px;
1323             }
1324              
1325             a:link { text-decoration: none; }
1326             a:visited { text-decoration: none; }
1327             a:active { text-decoration: none; }
1328             a:hover { text-decoration: underline; }
1329             .hide { display: none; }
1330              
1331             .shadow {
1332             box-shadow: 5px 5px 5px #ccc;
1333             -moz-box-shadow: 5px 5px 5px #ccc;
1334             -webkit-box-shadow: 5px 5px 5px #ccc;
1335             }
1336              
1337             #pagebox {
1338             background: #fff;
1339             border: 1px solid #000;
1340             box-shadow: 10px 10px 10px #444;
1341             -moz-box-shadow: 10px 10px 10px #444;
1342             -webkit-box-shadow: 10px 10px 20px #444;
1343             margin: 0px auto;
1344             width: 788px;
1345             height: 491px;
1346             }
1347              
1348             #headerBox {
1349             background: #A17F25;
1350             border-bottom: 1px solid #916F15;
1351             border-left: 1px solid #916F15;
1352             border-right: 1px solid #916F15;
1353             border-top: 1px solid #916F15;
1354             clear: both;
1355             height: 82px;
1356             width: 786px;
1357             text-align:center;
1358             color: #ffffff;
1359             }
1360              
1361             #content-left {
1362             background: #fff;
1363             border-right: 1px solid #0F4D92;
1364             clear: both;
1365             float: left;
1366             height: 377px;
1367             margin: 0px;
1368             padding: 15px;
1369             width: 530px;
1370             }
1371              
1372             #content-right {
1373             background: #fafae8;
1374             border: 0px;
1375             float: right;
1376             height: 377px;
1377             margin: 0px;
1378             padding: 15px;
1379             width: 197px;
1380             }
1381              
1382             #content-left h1 {
1383             font-family: "Times New Roman", Times, serif;
1384             font-size: 20px;
1385             font-weight: normal;
1386             margin: 0px 0px 5px 0px;
1387             }
1388              
1389             #content-left h2 {
1390             font-family: "Times New Roman", Times, serif;
1391             font-size: 20px;
1392             font-weight: normal;
1393             margin: 5px 0px 5px 0px;
1394             }
1395              
1396             #content-left p.formLabel {
1397             color: #5F5F5F;
1398             font-family: "Times New Roman", Times, serif;
1399             font-size: 16px;
1400             font-weight: normal;
1401             margin: 6px 0px 0px 0px;
1402             text-align: right;
1403             }
1404            
1405             #content-left p.sans {
1406             color: #5F5F5F;
1407             font-family: Verdana, Arial, Helvetica, sans;
1408             font-size: 11px;
1409             font-weight: normal;
1410             line-height: 1.7em;
1411             margin: 5px 0px 5px 0px;
1412             }
1413            
1414             #content-left p.sansURL {
1415             color: #4e6d98;
1416             font-family: Verdana, Arial, Helvetica, sans;
1417             font-size: 11px;
1418             font-weight: normal;
1419             line-height: 1em;
1420             margin: 15px 0px 5px 0px;
1421             }
1422              
1423             #content ul.plain, ul.plain a {
1424             color: #1A3E6F;
1425             font-family: Verdana, Geneva, Arial, sans-serif;
1426             font-size: 14px;
1427             line-height: 1.5em;
1428             list-style: none;
1429             margin: .4em 0em .2em 0em;
1430             padding: 0em 0em 0em 0em;
1431             text-indent: 0em;
1432             }
1433            
1434             #content ul.plain li, ul.plain li a {
1435             padding-bottom: 0.8em;
1436             }
1437            
1438             #content ul.plain li.disabled {
1439             color: #bbb;
1440             }
1441            
1442            
1443             #content ul.plain-serif, ul.plain-serif a {
1444             color: #1A3E6F;
1445             font-family: "Times New Roman", Times, serif;
1446             font-size: 14px;
1447             line-height: 1.2em;
1448             list-style: none;
1449             margin: 30px 0px 0px 0px;
1450             padding: 0px 0px 0px 0px;
1451             text-indent: 0em;
1452             }
1453            
1454             #content ul.plain-serif li, ul.plain-serif li a {
1455             padding-bottom: 0.8em;
1456             }
1457            
1458             #content ol {
1459             font-family: Verdana, Arial, Helvetica, sans;
1460             font-size: 11px;
1461             font-weight: normal;
1462             line-height: 1.8em;
1463             margin: 0px 0px 0px 20px;
1464             padding: 0px 0px 0px 0px;
1465             text-indent: 0em;
1466             }
1467            
1468             #content ol li, ol li a { padding-bottom: 0.8em; }
1469             EOT
1470             ;#-
1471             #+
1472 0           <<'EOT';
1473             body {
1474             background-color: #D1AF55; /*#76A9DC;*/
1475             color: #444;
1476             font-family: "Times New Roman", Times, serif;
1477             margin: 30px;
1478             padding: 5px;
1479             }
1480              
1481             a:link { text-decoration: none; }
1482             a:visited { text-decoration: none; }
1483             a:active { text-decoration: none; }
1484             a:hover { text-decoration: underline; }
1485             .hide { display: none; }
1486              
1487             .shadow {
1488             box-shadow: 5px 5px 5px #ccc;
1489             -moz-box-shadow: 5px 5px 5px #ccc;
1490             -webkit-box-shadow: 5px 5px 5px #ccc;
1491             }
1492              
1493             #pagebox {
1494             background: #fff;
1495             border: 1px solid #000;
1496             box-shadow: 10px 10px 10px #444;
1497             -moz-box-shadow: 10px 10px 10px #444;
1498             -webkit-box-shadow: 10px 10px 20px #444;
1499             margin: 0px auto;
1500             width: 788px;
1501             height: 491px;
1502             }
1503              
1504             #headerBox {
1505             background: #A17F25;
1506             border-bottom: 1px solid #916F15;
1507             border-left: 1px solid #916F15;
1508             border-right: 1px solid #916F15;
1509             border-top: 1px solid #916F15;
1510             clear: both;
1511             height: 82px;
1512             width: 786px;
1513             text-align:center;
1514             color: #ffffff;
1515             }
1516              
1517             #content-left {
1518             background: #fff;
1519             border-right: 1px solid #0F4D92;
1520             clear: both;
1521             float: left;
1522             height: 377px;
1523             margin: 0px;
1524             padding: 15px;
1525             width: 530px;
1526             }
1527              
1528             #content-right {
1529             background: #fafae8;
1530             border: 0px;
1531             float: right;
1532             height: 377px;
1533             margin: 0px;
1534             padding: 15px;
1535             width: 197px;
1536             }
1537              
1538             #content-left h1 {
1539             font-family: "Times New Roman", Times, serif;
1540             font-size: 20px;
1541             font-weight: normal;
1542             margin: 0px 0px 5px 0px;
1543             }
1544              
1545             #content-left h2 {
1546             font-family: "Times New Roman", Times, serif;
1547             font-size: 20px;
1548             font-weight: normal;
1549             margin: 5px 0px 5px 0px;
1550             }
1551              
1552             #content-left p.formLabel {
1553             color: #5F5F5F;
1554             font-family: "Times New Roman", Times, serif;
1555             font-size: 16px;
1556             font-weight: normal;
1557             margin: 6px 0px 0px 0px;
1558             text-align: right;
1559             }
1560            
1561             #content-left p.sans {
1562             color: #5F5F5F;
1563             font-family: Verdana, Arial, Helvetica, sans;
1564             font-size: 11px;
1565             font-weight: normal;
1566             line-height: 1.7em;
1567             margin: 5px 0px 5px 0px;
1568             }
1569            
1570             #content-left p.sansURL {
1571             color: #4e6d98;
1572             font-family: Verdana, Arial, Helvetica, sans;
1573             font-size: 11px;
1574             font-weight: normal;
1575             line-height: 1em;
1576             margin: 15px 0px 5px 0px;
1577             }
1578              
1579             #content ul.plain, ul.plain a {
1580             color: #1A3E6F;
1581             font-family: Verdana, Geneva, Arial, sans-serif;
1582             font-size: 14px;
1583             line-height: 1.5em;
1584             list-style: none;
1585             margin: .4em 0em .2em 0em;
1586             padding: 0em 0em 0em 0em;
1587             text-indent: 0em;
1588             }
1589            
1590             #content ul.plain li, ul.plain li a {
1591             padding-bottom: 0.8em;
1592             }
1593            
1594             #content ul.plain li.disabled {
1595             color: #bbb;
1596             }
1597            
1598            
1599             #content ul.plain-serif, ul.plain-serif a {
1600             color: #1A3E6F;
1601             font-family: "Times New Roman", Times, serif;
1602             font-size: 14px;
1603             line-height: 1.2em;
1604             list-style: none;
1605             margin: 30px 0px 0px 0px;
1606             padding: 0px 0px 0px 0px;
1607             text-indent: 0em;
1608             }
1609            
1610             #content ul.plain-serif li, ul.plain-serif li a {
1611             padding-bottom: 0.8em;
1612             }
1613            
1614             #content ol {
1615             font-family: Verdana, Arial, Helvetica, sans;
1616             font-size: 11px;
1617             font-weight: normal;
1618             line-height: 1.8em;
1619             margin: 0px 0px 0px 20px;
1620             padding: 0px 0px 0px 0px;
1621             text-indent: 0em;
1622             }
1623            
1624             #content ol li, ol li a { padding-bottom: 0.8em; }
1625             EOT
1626             ;
1627             #-
1628             }
1629             elsif ($par eq 'cas-mobile.css') {
1630 0           print "Content-Type: text/css; charset=UTF-8\n\n".
1631             #
1632             # echo "<<'EOT';\n${c}EOT\n;"; !>#+
1633             <<'EOT';
1634             body {
1635             background-color: #fff;
1636             color: #444;
1637             font-family: "Times New Roman", Times, serif;
1638             margin: 0px;
1639             padding: 0px;
1640             }
1641              
1642             a:link { text-decoration: none; }
1643             a:visited { text-decoration: none; }
1644             a:active { text-decoration: none; }
1645             a:hover { text-decoration: underline; }
1646             .hide { display: none; }
1647             .hideInMobile { display: none; }
1648              
1649             #pagebox {
1650             border: 0px;
1651             background: #fff;
1652             margin: 0px;
1653             width: auto;
1654             height: auto;
1655             box-shadow: none;
1656             -moz-box-shadow: none;
1657             -webkit-box-shadow: none;
1658             }
1659            
1660             #headerBox {
1661             border: 0px;
1662             background: #A17F25;
1663             overflow: hidden;
1664             width: auto;
1665             height: auto;
1666             }
1667              
1668             #headerBox h1 { font-size: 14pt; }
1669              
1670             #content-left {
1671             background: #fff;
1672             border: 0px;
1673             margin: 0px;
1674             padding: 15px;
1675             width: auto;
1676             height: auto;
1677             float: none;
1678             }
1679            
1680             #content-right {
1681             background: #fff;
1682             border: 0px;
1683             width: auto;
1684             height: auto;
1685             float: none;
1686             margin-left: 85px;
1687             }
1688              
1689             #form-layout { width: auto; }
1690              
1691             #login_form input {
1692             background: #f8f8f8;
1693             border: 1px solid #aaa;
1694             color: #555;
1695             font-family: Verdana, Arial, Helvetica, sans;
1696             font-weight: normal;
1697             margin: 0px 0px 0px 0px;
1698             font-size: 16px;
1699             padding: 5px;
1700             }
1701            
1702             #login_form input.inputButton {
1703             background: #F5F091;
1704             border: 1px solid #aaa;
1705             color: #555;
1706             font-family: Georgia, "Times New Roman", Times, serif;
1707             font-weight: normal;
1708             margin: 10px 0px 10px 0px;
1709             font-size: 18px;
1710             }
1711              
1712             #login_form input.formInput {
1713             width: 170px;
1714             float: none;
1715             }
1716              
1717             h1.mobileTitle { display: none; }
1718            
1719             #content-left h1 {
1720             color: #883F0A;
1721             font-family: Georgia, "Times New Roman", Times, serif;
1722             font-weight: bold;
1723             margin: 0px 0px 5px 0px;
1724             font-size: 19px;
1725             }
1726            
1727             #content-left h2 { display: none; }
1728             #content-left p.sans { display: none; }
1729             #content-left p.sansURL { display: none; }
1730             #content-left p.mobile-tight { margin: 0; }
1731              
1732             #content ul.plain, ul.plain a {
1733             color: #1A3E6F;
1734             font-family: Verdana, Geneva, Arial, sans-serif;
1735             line-height: 1.3em;
1736             list-style: none;
1737             margin: .4em 0em .2em 0em;
1738             padding: 0em 0em 0em 0em;
1739             text-indent: 0em;
1740             font-size: 14px;
1741             }
1742            
1743             #content ul.plain li, ul.plain li a {
1744             padding-bottom: 0.8em;
1745             }
1746            
1747             #content ul.plain li.disabled {
1748             color: #bbb;
1749             }
1750              
1751             #content ul.plain-serif, ul.plain-serif a {
1752             display: none;
1753             }
1754            
1755             #content ul.plain-serif li, ul.plain-serif li a {
1756             padding-bottom: 0.8em;
1757             }
1758            
1759             #content ol {
1760             color: #5F5F5F;
1761             font-family: Verdana, Arial, Helvetica, sans;
1762             font-size: 11px;
1763             font-weight: normal;
1764             line-height: 1.8em;
1765             margin: 0px 0px 0px 20px;
1766             padding: 0px 0px 0px 0px;
1767             text-indent: 0em;
1768             }
1769              
1770             #content ol li, ol li a {
1771             padding-bottom: 0.8em;
1772             }
1773             EOT
1774             ;#-
1775             #+
1776 0           <<'EOT';
1777             body {
1778             background-color: #fff;
1779             color: #444;
1780             font-family: "Times New Roman", Times, serif;
1781             margin: 0px;
1782             padding: 0px;
1783             }
1784              
1785             a:link { text-decoration: none; }
1786             a:visited { text-decoration: none; }
1787             a:active { text-decoration: none; }
1788             a:hover { text-decoration: underline; }
1789             .hide { display: none; }
1790             .hideInMobile { display: none; }
1791              
1792             #pagebox {
1793             border: 0px;
1794             background: #fff;
1795             margin: 0px;
1796             width: auto;
1797             height: auto;
1798             box-shadow: none;
1799             -moz-box-shadow: none;
1800             -webkit-box-shadow: none;
1801             }
1802            
1803             #headerBox {
1804             border: 0px;
1805             background: #A17F25;
1806             overflow: hidden;
1807             width: auto;
1808             height: auto;
1809             }
1810              
1811             #headerBox h1 { font-size: 14pt; }
1812              
1813             #content-left {
1814             background: #fff;
1815             border: 0px;
1816             margin: 0px;
1817             padding: 15px;
1818             width: auto;
1819             height: auto;
1820             float: none;
1821             }
1822            
1823             #content-right {
1824             background: #fff;
1825             border: 0px;
1826             width: auto;
1827             height: auto;
1828             float: none;
1829             margin-left: 85px;
1830             }
1831              
1832             #form-layout { width: auto; }
1833              
1834             #login_form input {
1835             background: #f8f8f8;
1836             border: 1px solid #aaa;
1837             color: #555;
1838             font-family: Verdana, Arial, Helvetica, sans;
1839             font-weight: normal;
1840             margin: 0px 0px 0px 0px;
1841             font-size: 16px;
1842             padding: 5px;
1843             }
1844            
1845             #login_form input.inputButton {
1846             background: #F5F091;
1847             border: 1px solid #aaa;
1848             color: #555;
1849             font-family: Georgia, "Times New Roman", Times, serif;
1850             font-weight: normal;
1851             margin: 10px 0px 10px 0px;
1852             font-size: 18px;
1853             }
1854              
1855             #login_form input.formInput {
1856             width: 170px;
1857             float: none;
1858             }
1859              
1860             h1.mobileTitle { display: none; }
1861            
1862             #content-left h1 {
1863             color: #883F0A;
1864             font-family: Georgia, "Times New Roman", Times, serif;
1865             font-weight: bold;
1866             margin: 0px 0px 5px 0px;
1867             font-size: 19px;
1868             }
1869            
1870             #content-left h2 { display: none; }
1871             #content-left p.sans { display: none; }
1872             #content-left p.sansURL { display: none; }
1873             #content-left p.mobile-tight { margin: 0; }
1874              
1875             #content ul.plain, ul.plain a {
1876             color: #1A3E6F;
1877             font-family: Verdana, Geneva, Arial, sans-serif;
1878             line-height: 1.3em;
1879             list-style: none;
1880             margin: .4em 0em .2em 0em;
1881             padding: 0em 0em 0em 0em;
1882             text-indent: 0em;
1883             font-size: 14px;
1884             }
1885            
1886             #content ul.plain li, ul.plain li a {
1887             padding-bottom: 0.8em;
1888             }
1889            
1890             #content ul.plain li.disabled {
1891             color: #bbb;
1892             }
1893              
1894             #content ul.plain-serif, ul.plain-serif a {
1895             display: none;
1896             }
1897            
1898             #content ul.plain-serif li, ul.plain-serif li a {
1899             padding-bottom: 0.8em;
1900             }
1901            
1902             #content ol {
1903             color: #5F5F5F;
1904             font-family: Verdana, Arial, Helvetica, sans;
1905             font-size: 11px;
1906             font-weight: normal;
1907             line-height: 1.8em;
1908             margin: 0px 0px 0px 20px;
1909             padding: 0px 0px 0px 0px;
1910             text-indent: 0em;
1911             }
1912              
1913             #content ol li, ol li a {
1914             padding-bottom: 0.8em;
1915             }
1916             EOT
1917             ;
1918             #-
1919              
1920             }
1921 0           exit;
1922             } # end of sub deliver
1923              
1924             ########################################################################
1925             # Section: Debug Functions
1926              
1927 0 0   0     sub _dbg383 { return unless $DebugLevel > 5;
1928 0           $LogReport.="CAS client: Verification successful.\n"; &store_log; }
  0            
1929              
1930             ########################################################################
1931             # Section: End of code; Documentation
1932              
1933             1;
1934              
1935             __END__