File Coverage

blib/lib/CGI/AuthRegister.pm

Criterion	Covered	Total	%
statement	26	1250	2.0
branch	1	490	0.2
condition	0	123	0.0
subroutine	8	69	11.5
pod	4	50	8.0
total	39	1982	1.9

\n"; };

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

6 package CGI::AuthRegister;

7 1 1 5699 use strict;

1 2

1 53

8 1 1 7 use vars qw($NAME $ABSTRACT $VERSION);

1 2

1 129

9 $NAME = 'AuthRegister';

10 $ABSTRACT = 'AuthRegister Module for Simple CGI Authentication and '.

11 'Registration in Perl';

12 $VERSION = '1.403'; # Last update: 2021-04-19

14 1 1 3462 use CGI qw(:standard);

1 35567

1 7

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 3813 use Carp;

1 3

1 101

21 require Exporter;

22 1 1 6 use vars qw(@ISA @EXPORT);

1 2

1 138

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 );

35 1 3792 use vars qw( $AddAuthenticatedUser $AllowSignup

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 $AllowSignup = ''; # 1 to allow new user signup

46 $DBdir = 'db'; # directory for stored data (822 db, sessions)

47 $DBusers = 'users.db'; # Users db

48 $DBusersCas = 'users-cas.db'; # CAS users db

49 $DBpwd = 'passwords'; # Passwords file

50 $DBpwdCas = 'passwords-cas'; # CAS passwords

51 $DBsessions = 'sessions.d'; # Sessions

52 $DBsessionsCas = 'sessions-cas.d'; # CAS sessions

53 $DBcasTokens = 'cas-tokens.db'; # CAS Tokens

54 # $Error = ''; # Appended error messages, OK to be sent to user

55 # $ErrorInternal = ''; # Appended internal error messages, intended

56 # for administrator

57 # $Header # Keeps the latest prepared HTTP header, if not printed

58 # $LogReport = ''; # Collecting some important log events if needed

59 $SecretSalt = &random_name; # Secret salt for generating secrets (e.g. tokens)

60 # $Session = ''; # Session data structure

61 # $SessionId = ''; # Session identifier, generated

62 $SiteId = 'Site'; # Site identifier, used in cookies and emails

63 $SiteName = 'Site'; # Site name, can include spaces

64 # $Ticket = ''; # Session ticket for security, generated

65 # $User = ''; # User data structure

66 # $UserEmail = ''; # User email address

67 # $SendLogs = ''; # If true, send logs by email to admin ($Email_bcc)

69 $Email_from = ''; # Example: $SiteId.' ';

70 $Email_bcc = ''; # Example: $SiteId.' Bcc ';

72 $Sendmail = "/usr/lib/sendmail"; # Sendmail with full path

74 # Some function prototypes

75 sub putfile($@);

77 ########################################################################

78 # Section: Configuration

79 # sets site id as the base directory name; imports configuration.pl if exists

80 sub import_dir_and_config {

81 0 0 1 0 my $base = `pwd`; $base =~ /\/([^\/]*)$/; $base = $1; $base =~ s/\s+$//;

0 0

82 0 0 $SiteId = $SiteName = $base;

83 0 0 0 if (-r 'configuration.pl') { package main; require 'configuration.pl'; }

0 0

84 }

86 ########################################################################

87 # Section: HTTPS Connection and Cookies Management

89 # Check that the connection is HTTPS and if not, redirect to HTTPS.

90 # It must be done before script produces any output.

91 sub require_https {

92 0 0 0 1 0 if ($ENV{'HTTPS'} ne 'on') {

93 0 0 print "Status: 301 Moved Permanently\n".

94 "Location: https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}\n\n";

95 0 0 exit 0; }

96 }

98 # Used to run a CAS service. If not logged in, ask for userid and password.

99 # On success, offer to pass confirmation back to the site; on fail offer retry

100 # or go back to the site. If site not given, stay. If previously logged in

101 # offer to pass confirmation to the site. Handles ?logout requests.

102 # Allows parentheses in userid's for login, which are removed. This allows

103 # users to use auxiliary comments with userid, so that browser can distinguish

104 # passwords.

105 sub run_cas {

106 0 0 0 0 my %params = @_;

107 0 0 my $querystring = $ENV{QUERY_STRING};

108 0 0 $DBusers = $DBusersCas; $DBpwd = $DBpwdCas; $DBsessions = $DBsessionsCas;

0 0

109 0 0 &import_dir_and_config; &require_https;

0 0

110 0 0 0 0 if ($querystring eq '' && param('querystring')) {

111 0 0 $querystring=param('querystring') }

112 0 0 0 if ($querystring eq 'cas-all.css') { &deliver('cas-all.css') }

0 0

113 0 0 0 if ($querystring eq 'cas-mobile.css') { &deliver('cas-mobile.css') }

0 0

114

115 0 0 0 0 if (param('rt') ne '' && param('rt') eq 'verify') {

116 0 0 my $username = param('username'); my $stoken = param('stoken');

0 0

117 0 0 my $r = &_db8_find_first("$DBdir/$DBcasTokens", 'k=stoken', $stoken);

118 0 0 my $ans = 'fail';

119 0 0 0 0 if ($r ne '' and $r->{stoken} eq $stoken and $r->{userid} eq $username) {

120 0 0 $ans = 'ok';

121 0 0 0 if ($DebugLevel > 5) { $LogReport .= "CAS verification OK for ".

0 0

122 0 0 "username($username) stoken($stoken)"; &store_log; }

123 }

124 0 0 0 if ($ans ne 'ok') {

125 0 0 print header(), "answer:fail\n";

126 0 0 0 if ($DebugLevel > 5) { $LogReport .= "CAS verify failed for ".

0 0

127 "username($username) stoken($stoken)"; }

128 0 0 &store_log; exit(); }

0 0

129 0 0 &_db8_remove("$DBdir/$DBcasTokens", 'k=stoken', $stoken);

130 0 0 print header(), "answer:ok\n"; exit();

0 0

131 }

132

133 0 0 my $redirect_uri;

134 0 0 0 if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }

0 0 0

135 0 0 elsif (param('r') ne '') { $redirect_uri = param('r') }

136

137 ### Helper functions: finishGeneral, finishWithPageBack

138

139 local *finishGeneral = sub {

140 0 0 0 my $page = &gen_cas_page;

141 0 0 0 if ($redirect_uri ne '') {

142 0 0 my $h = "

143 "value=\"$redirect_uri\">";

144 0 0 $page=~ s//$h\n$&/;

145 0 0 my $t = "CAS Authentication requested by the following site:
\n".

146 "".&htmlquote($redirect_uri)."";

147 0 0 $page =~ s/(.*?\n\n/\n/s;

161 0 0 $page =~ s/.*?\n\n/\n/s;

162 0 0 0 if ($redirect_uri ne '') {

163 0 0 my $stoken = &gen_secret; $userid=~s/["<>]//g;

0 0

164 0 0 my $f = "$DBdir/$DBcasTokens";

165 0 0 0 0 if (!-f $f && !&check_db_files) { $LogReport.=$Error; &store_log;

0 0

166 0 0 print "Error: $Error"; exit; }

0 0

167 0 0 0 if (!-f $f) { putfile $f, ''; chmod 0600, $f; }

0 0

168 0 0 &_db8_append($f, "userid:$userid\nstoken:$stoken" );

169 0 0 0 if ($Error ne '') { $LogReport.=$Error; &store_log;

0 0

170 0 0 print "Error: $Error"; exit; }

0 0

171 0 0 my $h = "";

172 0 0 $page=~ s//$h\n$&/;

173 0 0 $h = "";

174 0 0 $page=~ s//$h\n$&/;

175 0 0 $page =~ s/(

176 0 0 my $r = &encodeuri($redirect_uri);

177

$page =~ s/(

178 0 0 } else { $page =~ s///s; }

179 0 0 print $page;

180 # Log out user so that they have to login every time they use the service

181 0 0 logout();

182 0 0 exit;

183 0 0 };

184 ### End of helper functions

185

186 # Check redirect_uri

187 0 0 0 0 if ($redirect_uri ne '' &&

188 $redirect_uri !~ /^https:\/\/(\w|[-.~\/])+/i &&

189 $redirect_uri !~ /^http:\/\/(\w|[-.~\/:])+/i ## This is temporary for a student project

190 ## It is probably is too relaxed.

191 ) {

192 0 0 my $page = &gen_cas_page;

193 0 0 my $h = 'redirect_uri Error!';

194 0 0 my $t = "URI of the requesting site is not in an acceptable format:
\n".

195 "".&htmlquote($redirect_uri)."
\n".

196 "Please check with the CAS maintainer if you think that this URI ".

197 "should be accepted. The rules include a requirement that the URI ".

198 "starts with 'https://' (including uppercase), and can have only some ".

199 "standard characters. It is possible that more characters should be ".

200 "allowed.";

201 0 0 $page =~ s/(.*?//s;

204 0 0 print header(), $page; exit;

0 0

205 }

206

207 0 0 0 0 if ($querystring eq 'forgotpwd' or param('rt') eq 'forgotpwd') {

208 0 0 0 if ($LinkForgotpwd) { print CGI::redirect(-uri=>$LinkForgotpwd); exit; }

0 0

209 0 0 my $page = &gen_cas_page; my $h = 'Send Password';

0 0

210 0 0 my $t = "Enter your UserID or Email to have password reset and sent to ".

211 "you by email.\nIf you do not receive email, it may mean that you are ".

212 "not registered in the system, and you should contanct the administrator.";

213 0 0 $page =~ s/(.*?\n\n/\n/s;

216 0 0 $page =~ s/(

217 0 0 print header(), $page; exit;

0 0

218 }

219

220 0 0 my $title = "Login Page for Site: $CGI::AuthRegister::SiteName";

221

my $HTMLstart = "$title

$title

\n";

222 0 0 my $Formstart = "";

223

my $LoginForm = "

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

224 hidden('querystring',$querystring).

225

"\n\n".

CS Userid:	".
226		textfield(-name=>"csuserid")."
".
227		"Password:	".password_field(-name=>"password")."
228		'
	'.
229		"

\n";

230

231

# $LoginForm.="

LogReport:\n$CGI::AuthRegister::LogReport\nError=$CGI::AuthRegister::Error\n";

232

233 0 0 &analyze_cookie;

234

235 # Logout from CAS

236 0 0 0 0 if ($CGI::AuthRegister::SessionId ne '' && param('keywords') eq 'logout') {

237 0 0 CGI::AuthRegister::logout(); print header(); &finishGeneral; }

0 0

238

239 0 0 0 if ($SessionId ne '') { print header(); &finishWithPageBack; }

0 0

240

241 0 0 my $Request_type = param('request_type');

242

243 0 0 0 if ($Request_type eq 'Login') {

244 0 0 my $username = param('username'); my $password = param('password');

0 0

245 0 0 $username =~ s/$.*$//g; $username =~ s/\s+$//; $username =~ s/^\s+//;

0 0

246

247 0 0 0 if (! &login($username, $password) ) {

248 0 0 my $page = &gen_cas_page;

249 0 0 my $t = "Unsuccessful login!
\n";

250 0 0 0 if ($redirect_uri ne '') {

251 0 0 my $h = "

252 "value=\"$redirect_uri\">";

253 0 0 $page=~ s//$h\n$&/;

254 0 0 $t.= "CAS Authentication requested by the following site:
\n".

255 "".&htmlquote($redirect_uri).""; }

256 0 0 $page =~ s/(.*?//s; # remove the form

271 0 0 print header(), $page;

272 0 0 $LogReport.=$Error; &store_log;

0 0

273 0 0 exit;

274 }

275 else { # should be: $Request_type eq ''

276 0 0 print header(); &finishGeneral; }

0 0

277 0 0 die; # Not supposed to be reached

278 }

279

280

281 # If not logged in, ask for userid/email and password. Catches ?logout

282 # request as well. Allows parentheses in userid/email for login, which are

283 # removed. This allows users to use auxiliary comments with userid, so that

284 # browser can distinguish passwords.

285 sub require_login {

286 0 0 0 0 0 my %args = @_; return &_require_login_using_cas(@_) if exists($args{-cas});

0 0

287 0 0 my $title = "Login Page for Site: $SiteId";

288

my $HTMLstart = "$title

$title

\n";

289

my $Formstart = "

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

291 0 0 0 0 local *tr = sub { my($a,$b) = @_; return "

$a: ".

0 0

292 ($a=~/password/i?password_field(-name=>$b):textfield(-name=>$b)).

293 0 0 "

294

my $LoginForm = "

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

295

"\n".&tr('Userid or email','userid').

296		&tr('Password','password').
297		'
	'.
298		"

\n";

299

my $SendResetForm = "

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

300 "retrieve it by email:
\n".$Formstart."Email: ".

301 textfield(-name=>"email_pw_send")."\n".

302 ''.

303 "\n".

304 "Or, you can reqest password to be reset and sent to you:
\n".

305 $Formstart."Email: ".textfield(-name=>"email_reset")."\n".

306 ''.

307 "\n".

308 ($AllowSignup?("".

309 "Register new user\n"):'');

310 0 0 my $RegistrationForm = $Formstart.

311

"\n".&tr('Userid','reg_userid').&tr('Email','reg_email').

312		&tr('Password','reg_password').&tr('Confirm password','reg_password2').
313		'
	'.
314		"

\n";

315

316 0 0 &analyze_cookie;

317 0 0 0 0 if ($SessionId ne '' && param('keywords') eq 'logout') {

318 0 0 logout(); print header_delete_cookie(),$HTMLstart,

0 0

319

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

320

321 0 0 0 if ($SessionId ne '') { print header(); return 1; }

0 0

322

323 0 0 0 0 if (param('keywords') eq 'signup' && $AllowSignup) {

324

print header(), $HTMLstart, "

New Registration

\n",

325 0 0 $RegistrationForm; exit; }

326 elsif (param('confirmation_code')) {

327

print header(), $HTMLstart, "

Email Confirmation

\n";

328 0 0 &email_confirmation(param('confirmation_code')); exit;

0 0

329 }

330

331 0 0 my $Request_type = param('request_type');

332

333 0 0 0 0 if ($Request_type eq 'Login') {

334 0 0 my $email = param('userid'); my $password = param('password');

0 0

335 0 0 $email =~ s/$.*$//g; $email =~ s/\s+$//; $email =~ s/^\s+//;

0 0

336

337 0 0 0 if (! &login($email, $password) ) { # checks for userid and email

338 0 0 print header(), $HTMLstart, "Unsuccessful login!\n";

339 0 0 print $LoginForm, $SendResetForm; exit;

0 0

340 }

341 0 0 else { print header_session_cookie(); return 1; }

0 0

342 }

343 elsif ($Request_type eq 'Send_Password') {

344 0 0 &send_email_reminder(param('email_pw_send'), 'raw');

345 0 0 print header(), $HTMLstart, "You should receive password reminder if ".

346 "your email is registered at this site.\n".

347 "If you do not receive remider, you can contact the administrator.\n",

348 $LoginForm, $SendResetForm;

349 0 0 $LogReport.=$Error; &store_log;

0 0

350 0 0 exit;

351 }

352 elsif ($Request_type eq 'Reset_Password') {

353 0 0 &reset_and_send_email_reminder(param('email_reset'), 'raw');

354 0 0 print header(), $HTMLstart, "You should receive new password if ".

355 "your email is registered at this site.\n".

356 "If you do not receive remider, you can contact the administrator.\n",

357 0 0 $LoginForm, $SendResetForm; exit;

358 }

359 elsif ($Request_type eq 'Register' && $AllowSignup) {

360 0 0 $|=1; print header(), $HTMLstart;

0 0

361 0 0 ®ister_new_user;

362 0 0 exit;

363 }

364 else { # should be: $Request_type eq ''

365 0 0 print header(), $HTMLstart, $LoginForm, $SendResetForm; exit; }

0 0

366

367 0 0 die; # Not supposed to be reached

368 }

369

370 # parameters:

371 # -return_status=>1 rather than exiting on failure, return status

372 # return status values: 'logged out', 1, 'not logged in' 'login failed'

373 # If we want that user gets a suggestion to use CAS to login, then

374 # this option should not be used.

375 #

376 # -header_no_print=> do not print header on success, but keep in $Header

377 sub _require_login_using_cas {

378 0 0 0 my %args = @_; my $casurl = $args{-cas};

0 0

379 0 0 my $header_no_print = $args{-header_no_print};

380 0 0 my $retStatus;

381 0 0 0 $retStatus = $args{-return_status} if exists($args{-return_status});

382 0 0 my $title = "Login Page for Site: $SiteId";

383

my $HTMLstart = "$title

$title

\n";

384 0 0 my $casurl_r = "$casurl?r=".url();

385

my $LoginMsg = "

Please use CAS ".

386 "to login.\n";

387

388 0 0 &analyze_cookie;

389 0 0 0 0 if ($SessionId ne '' && param('keywords') eq 'logout') {

390 0 0 logout(); print header_delete_cookie();

0 0

391 0 0 0 if ($retStatus) { return 'logged out' }

0 0

392

print $HTMLstart, "

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

0 0

393

394 0 0 0 if ($SessionId ne '') {

395 0 0 my $header = header();

396 0 0 0 if ($header_no_print) { $Header=$header; return 1; }

0 0

397 0 0 print $header; return 1; }

0 0

398

399 0 0 my $request_type = param('request_type');

400 0 0 0 if ($request_type ne 'Proceed') {

401 0 0 0 if ($retStatus) { print header(); return 'not logged in' }

0 0

402 0 0 print CGI::redirect(-uri=>$casurl_r);

403 0 0 exit; }

404 0 0 my $username = param('username'); my $stoken = param('stoken');

0 0

405 0 0 0 0 if ($username eq '' or $stoken eq '') {

406 0 0 0 print header(); if ($retStatus) { return 'not logged in' }

0 0

407 0 0 print $HTMLstart, $LoginMsg; exit; }

0 0

408

409 0 0 0 if ($casurl !~ /^https:\/\//i) {

410 0 0 my $u = CGI::url(); $u=~ s/\/[^\/]+$//; $casurl = "$u/$casurl"; }

0 0

411

412 0 0 require LWP::UserAgent; require HTTP::Request; require Mozilla::CA;

0 0

413 0 0 my $ua = LWP::UserAgent->new();

414 1 1 697 use HTTP::Request::Common qw(POST);

1 23094

1 11362

415 0 0 my $req = POST $casurl, [ rt=>'verify', username=>$username, stoken=>$stoken ];

416 0 0 my $resp = $ua->request($req);

417 0 0 my $result = 'fail';

418 0 0 0 if ($resp->is_success) {

419 0 0 my $message = $resp->decoded_content; $message =~ s/\s//g;

0 0

420 0 0 0 if ($message eq 'answer:ok') { $result = 'ok'; &_dbg383; }

0 0

421 0 0 else { $Error.=" message=($message);" }

422 } else {

423 0 0 $Error.= "HTTP POST error code: ". $resp->code. "\n".

424 "HTTP POST error message: ".$resp->message."\n";

425 }

426 0 0 0 if ($result ne 'ok') {

427 0 0 $Error.="ERR-401:verify failed, result=($result) casurl=($casurl)\n";

428 0 0 print header(); $LogReport.=$Error; &store_log;

0 0

429 0 0 0 if ($retStatus) { return 'login failed'; }

0 0

430 0 0 print $HTMLstart, "Unsuccessful login!\n"; exit; }

0 0

431 0 0 0 my $u = ($AddAuthenticatedUser ? &get_user_by_userid_or_add($username) :

432 &get_user_unique('userid', $username));

433 0 0 0 if ($u eq '') {

434 0 0 $Error.="411-ERR: no userid ($username) in users.db\n";

435 0 0 $LogReport.=$Error; &store_log;

0 0

436 0 0 0 print header(); if ($retStatus) { return 'login failed'; }

0 0

437 0 0 print $HTMLstart,

438 "Unsuccessful login! (username not in users.db, ERR-414)\n";

439 0 0 &store_log; exit; }

0 0

440 0 0 $User = $u; &set_new_session($User);

0 0

441 0 0 $LogReport.="User $UserEmail logged in.\n"; &store_log;

0 0

442 0 0 print header_session_cookie(); return 1;

0 0

443 }

444

445 # Requires session (i.e., to be logged in). Otherwise, makes redirection.

446 sub require_session {

447 0 0 1 0 my %args=@_; my $defaultcgi = 'index.cgi';

0 0

448 0 0 0 0 if (exists($args{-redirect}) && $args{-redirect} ne '' &&

449 $args{-redirect} ne $ENV{SCRIPT_NAME})

450 0 0 { $defaultcgi = $args{-redirect} }

451 0 0 0 0 if (exists($args{-back}) && $args{-back}) {

452 0 0 $defaultcgi.="?goto=$args{-back}";

453 }

454 0 0 &analyze_cookie;

455 0 0 0 if ($SessionId eq '') {

456 0 0 0 if ($ENV{SCRIPT_NAME} eq $defaultcgi) {

457 0 0 print CGI::header(), CGI::start_html, CGI::h1("159-ERR:Login required");

458 0 0 exit; }

459 0 0 print CGI::redirect(-uri=>$defaultcgi); exit;

0 0

460 }

461 }

462

463 # Prepare HTTP header. If SessionId is not empty, generate cookie with

464 # the sessionid and ticket.

465 sub header_session_cookie {

466 0 0 0 0 my %args=@_; my $redirect=$args{-redirect};

0 0

467 0 0 0 if ($redirect ne '') {

468 0 0 0 if ($SessionId eq '') { return redirect(-uri=>$redirect) }

0 0

469 else {

470 0 0 return redirect(-uri=>$redirect,-cookie=>

471 cookie(-name=>$SiteId,

472 -value=>"$SessionId $Ticket"));

473 }

474 } else {

475 0 0 0 if ($SessionId eq '') { return header } else

0 0

476 0 0 { return header(-cookie=>cookie(-name=>$SiteId,

477 -value=>"$SessionId $Ticket")) }

478 }

479 }

480

481 # Delete cookie after logging out. Return string.

482 sub header_delete_cookie {

483 0 0 0 0 return header(-cookie=>cookie(-name=>$SiteId, -value=>'', -expires=>"now")) }

484

485 # Analyze cookie to detect session, and check the ticket as well. It

486 # should be called at the beginning of a script. $SessionId and

487 # $Ticket are set to empty string if not successful. The information

488 # about the session is stored in $DBdir/$DBsessions/$SessionId/session.info

489 # file. The structures $Session and $User are set if successful.

490 sub analyze_cookie {

491 0 0 1 0 my $c = cookie(-name=>$SiteId); # sessionid and ticket

492 0 0 0 if ($DebugLevel > 5) { $LogReport.="cookie:$SiteId:$c\n"; &store_log; }

0 0

493 0 0 0 if ($c eq '') { $SessionId = $Ticket = ''; return; }

0 0

494 0 0 ($SessionId, $Ticket) = split(/\s+/, $c);

495 0 0 0 0 if ($SessionId !~ /^[\w.:-]+$/ or $Ticket !~ /^\w+$/)

496 0 0 { $User = $SessionId = $Ticket = ''; return; }

0 0

497

498 # check validity of session and set user variables

499 0 0 my $sessioninfofile = "$DBdir/$DBsessions/$SessionId/session.info";

500 0 0 0 if (!-f $sessioninfofile) { $SessionId = $Ticket = ''; return; }

0 0

501 0 0 my $se = &read_db_record("file=$sessioninfofile");

502 0 0 0 0 if (!ref($se) or $Ticket ne $se->{'Ticket'})

503 0 0 { $User = $SessionId = $Ticket = ''; return; }

0 0

504 0 0 $Session = $se;

505 0 0 $UserEmail = $se->{email}; $UserId = $se->{userid};

0 0

506 0 0 0 if ($UserEmail =~ /@/) { $User = &get_user_unique('email', $UserEmail) }

0 0 0

507 0 0 elsif ($UserId ne '') { $User = &get_user_unique('userid', $UserId) }

508 0 0 else { $Error.="435-ERR: Could not identify the user.\n"; goto E; }

0 0

509 0 0 0 0 if ($UserId ne '' && $User->{userid} ne $UserId) {

510 0 0 $Error.="437-ERR: Non-matching userid.\n"; goto E; }

0 0

511 0 0 0 if ($Error ne '') { goto E }

0 0

512 0 0 return 1;

513 E:

514 0 0 0 if ($Error ne '') { $LogReport.=$Error; &store_log; }

0 0

515 0 0 $User = $SessionId = $Ticket = ''; return;

0 0

516 }

517

518 ########################################################################

519 # Section: User Management

520

521 sub register_new_user {

522 0 0 0 0 my $reg_userid = param('reg_userid'); my $reg_email = param('reg_email');

0 0

523 0 0 my $reg_password = param('reg_password');

524 0 0 my $reg_password2 = param('reg_password2');

525 0 0 0 if ($reg_userid !~ /^(\w|[.-])+$/) {

526 0 0 $Error = "Userid must consist of \w . or - characters.";

527 0 0 print $Error; exit; }

0 0

528 0 0 0 if (!&emailcheckok($reg_email)) { print "Invalid email."; exit; }

0 0

529 0 0 0 if ($reg_password eq '') { print "Empty password."; exit; }

0 0

530 0 0 0 if ($reg_password ne $reg_password2) {

531 0 0 print "Passwords do not match."; exit; }

0 0

532 0 0 my $confirmation_code = &random_string(12,'0'..'9','A'..'Z','a'..'z');

533 0 0 my $dbf = "$DBdir/$DBusers";

534 0 0 0 0 if (!-f $dbf && !&check_db_files) { print "No db file."; exit; }

0 0

535 0 0 0 if (!&lock_mkdir($dbf)) { print "DB lock fail."; exit; }

0 0

536 0 0 my $dbfc = getfile($dbf); my $db_ref = &read_db($dbfc);

0 0

537 0 0 0 if (ref($db_ref) ne 'ARRAY') {

538 0 0 print "ERR-540: Cound not read db file."; &unlock_mkdir($dbf); exit; }

0 0

539 0 0 my @db = @{ $db_ref };

0 0

540 0 0 0 local *fin = sub { my $url="https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";

541 0 0 print "\nUser browser back button to edit data, or click ".

542 0 0 "Home.\n"; &unlock_mkdir($dbf); exit; };

0 0

543 0 0 for my $u (@db) {

544 0 0 0 if ($u->{userid} eq $reg_userid) { print "Userid already exists."; &fin; }

0 0

545 0 0 0 if ($u->{email} eq $reg_email) { print "Email already exists."; &fin; }

0 0

546 }

547 0 0 $dbfc =~ s/\n+$/\n/s;

548 0 0 $dbfc.="\nuserid:$reg_userid\nemail:$reg_email\n".

549 "status:disabled, waiting for confirmation code $confirmation_code\n";

550 0 0 putfile($dbf,$dbfc);

551 0 0 &unlock_mkdir($dbf);

552 0 0 &password_set($reg_email,$reg_password,'md5');

553 0 0 0 if ($Error) { print "Error: $Error"; exit; }

0 0

554 0 0 print "New user registered.\n";

555 0 0 print "
An email is being sent to confirm your email ".

556 "address...\n";

557 0 0 my $httpsconfirm = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}?".

558 "confirmation_code=$confirmation_code";

559 0 0 my $msg = "Hi,\n\nPlease click or visit the following link to confirm ".

560 "your registration at the site $SiteId:\n\n".

561 "$httpsconfirm\n\nBest regards,\n$SiteId Admin\n";

562 0 0 &send_email_to($reg_email, "Subject: $SiteId Email Confirmation", $msg);

563 0 0 print "
Email sent. Use the sent link to confirm your email.\n";

564 }

565

566 sub email_confirmation {

567 0 0 0 0 my $confirmation_code = shift;

568 0 0 my $dbf = "$DBdir/$DBusers";

569 0 0 0 0 if (!-f $dbf && !&check_db_files) { print "No db file."; exit; }

0 0

570 0 0 0 if (!&lock_mkdir($dbf)) { print "DB lock fail."; exit; }

0 0

571 0 0 my $dbfc = getfile($dbf); my $db_ref = &read_db($dbfc);

0 0

572 0 0 0 if (ref($db_ref) ne 'ARRAY') {

573 0 0 print "ERR-540: Cound not read db file."; &unlock_mkdir($dbf); exit; }

0 0

574 0 0 my @db = @{ $db_ref }; my $flag = '';

0 0

575 0 0 for my $u (@db) {

576 0 0 0 0 if (defined($u->{status}) and

577 $u->{status} =~ /^disabled, waiting for confirmation code (\S+)/ and

578 $1 eq $confirmation_code) {

579 $u->{status} =~

580 0 0 s/^disabled, waiting for confirmation code (\S+)/email confirmed/;

581 0 0 $flag = 1; last; } }

0 0

582 0 0 0 if (!$flag) { print "Invalid confirmation code.\n"; &unlock_mkdir($dbf);

0 0

583 0 0 return; }

584 0 0 _db8_update("file=$dbf", \@db);

585 0 0 &unlock_mkdir($dbf);

586 0 0 print "Email confirmed.\n

587 "$ENV{SCRIPT_NAME}\">Login page\n";

588 }

589

590 ########################################################################

591 # Section: Session Management

592

593 # params: $email, opt: pwstore type: md5 raw

594 sub reset_password {

595 0 0 0 0 0 my $email = shift; my $pwstore = shift; $pwstore = 'md5' if $pwstore eq '';

0 0

596 0 0 my $password = &random_password(6); my $pwdf = "$DBdir/$DBpwd";

0 0

597 0 0 0 if (!-f $pwdf) { putfile $pwdf, ''; chmod 0600, $pwdf }

0 0

598 0 0 0 if (!&lock_mkdir($pwdf)) { $Error.="378-ERR:\n"; return ''; }

0 0

599 0 0 0 local *PH; open(PH, $pwdf) or croak($!);

0 0

600 0 0 my $content = '';

601 0 0 while () {

602 0 0 my ($e,$p) = split;

603 0 0 0 $content .= $_ if $e ne $email;

604 }

605 0 0 close(PH);

606 0 0 $content .= "$email ";

607 0 0 0 if ($pwstore eq 'raw') { $content.="raw:$password" }

0 0 0

608 0 0 elsif($pwstore eq 'md5') { $content.="md5:".md5_base64($password) }

609 0 0 else { $content.="raw:$password" }

610 0 0 $content .= "\n";

611 0 0 putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);

0 0

612 0 0 return $password;

613 }

614

615 # $pwstoretype:md5,raw

616 sub password_set {

617 0 0 0 0 my $email = shift; my $pwd = shift; my $pwstoretype = shift;

0 0

618 0 0 0 $pwstoretype = 'md5' if $pwstoretype eq '';

619 0 0 my $pwdf = "$DBdir/$DBpwd";

620 0 0 0 if (!&check_db_files) { $Error.="AuthERR-587:\n"; return '' }

0 0

621 0 0 0 if (!&lock_mkdir($pwdf)) { $Error.="AuthErr-588:\n"; return ''; }

0 0

622 0 0 0 local *PH; open(PH, $pwdf) or croak($!);

0 0

623 0 0 my $newrow = "$email ";

624 0 0 0 if ($pwstoretype eq 'md5') { $newrow.="md5:".md5_base64($pwd)."\n" }

0 0

625 0 0 else { $newrow.="raw:$pwd\n" }

626 0 0 my $content = '';

627 0 0 while () {

628 0 0 my ($e,$p) = split;

629 0 0 0 if ($e eq $email) { $content.=$newrow; $newrow=''; }

0 0

630 0 0 else { $content.=$_ }

631 }

632 0 0 $content.=$newrow; $newrow=''; close(PH);

0 0

633 0 0 putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);

0 0

634 0 0 return 1;

635 }

636

637 sub md5_base64 {

638 0 0 0 0 my $arg=shift; require Digest::MD5; return Digest::MD5::md5_base64($arg); }

0 0

639

640 sub random_password {

641 0 0 0 0 0 my $n = shift; $n = 8 unless $n > 0;

0 0

642 0 0 my @chars = (2..9, 'a'..'k', 'm'..'z', 'A'..'N', 'P'..'Z',

643 qw(, . / ? ; : - = + ! @ $ % *) );

644 0 0 return join('', map { $chars[rand($#chars+1)] } (1..$n));

0 0

645 }

646

647 # removes session file and return the appropriate HTTP header

648 sub logout {

649 0 0 0 0 0 if ($Session eq '') { $Error.= "481-ERR: No session to log out\n"; return; }

0 0

650 0 0 0 if (!-d "$DBdir/$DBsessions/$SessionId") { $Error.="482-ERR: No session dir\n" }

0 0

651 else {

652 0 0 unlink(<$DBdir/$DBsessions/$SessionId/*>);

653 0 0 rmdir("$DBdir/$DBsessions/$SessionId"); }

654 0 0 $LogReport.=$Error."User UserId:$UserId UserEmail:$UserEmail logged out.\n";

655 0 0 &store_log; $Session = $SessionId = $Ticket = '';

0 0

656 0 0 return 1;

657 }

658

659 # The first parameter can be an userid and email. (diff by @)

660 sub login {

661 0 0 0 0 my $email = shift; my $password = shift;

0 0

662 0 0 $email = lc $email; my $userid;

0 0

663 0 0 0 if ($email !~ /@/) { $userid=$email; $email=''; }

0 0

664 0 0 0 if ($email ne '') {

665 0 0 0 if (!&emailcheckok($email)) {

666 0 0 $Error.="402-ERR:Incorrect email address format"; return; }

0 0

667 #my $u = &get_user_by_email($email);

668 0 0 my $u = &get_user_unique('email', $email);

669 0 0 0 if ($u eq '') { $Error.='405-ERR:Email not registered'; return; }

0 0

670 0 0 $userid = $u->{userid};

671 0 0 $User = $u;

672 } else {

673 0 0 0 if ($userid eq '') { $Error.="409-ERR:Empty userid"; return; }

0 0

674 0 0 0 0 if ($LDAPuse and $LDAPaddUsers) {

675 0 0 return _login_ldap_add($userid, $password); }

676 0 0 my $u = &get_user_unique('userid', $userid);

677 0 0 0 if ($u eq '') { $Error.='531-ERR:Not exist-unique'; &store_log; return; }

0 0

678 0 0 $email = $u->{email};

679 0 0 $User = $u;

680 }

681 # Randomize more salt

682 0 0 $SecretSalt = md5_base64("$SecretSalt $password");

683

684 0 0 0 if (!password_check($User, $password)) {

685 0 0 $Error.="418:Invalid password\n"; return ''; }

0 0

686

687 0 0 &set_new_session($User);

688 0 0 $LogReport.="User $UserEmail logged in.\n"; &store_log;

0 0

689 0 0 return 1;

690 }

691

692 sub _login_ldap_add {

693 0 0 0 my $userid = shift; my $password = shift;

0 0

694 0 0 0 if (!&password_check_ldap($userid, $password)) {

695 0 0 $Error.="570-ERR:Invalid password for LDAP\n"; return ''; }

0 0

696 0 0 my $u = &get_user_by_userid_or_add($userid);

697 0 0 0 if ($u eq '') { $Error.="572-ERR:\n"; &store_log; return; }

0 0

698 0 0 $User = $u;

699 # Randomize more salt

700 0 0 $SecretSalt = md5_base64("$SecretSalt $password");

701 0 0 &set_new_session($User);

702 0 0 $LogReport.="User userid:$userid logged in.\n"; &store_log;

0 0

703 0 0 return 1;

704 }

705

706 sub set_new_session {

707 0 0 0 0 my $u = shift;

708 0 0 my $email = $u->{email};

709 0 0 my $userid = $u->{userid};

710 0 0 0 0 if ($email !~ /@/ && $userid !~ /\w/) {

711 0 0 $Error .= "586-ERR: No email nor userid\n"; return ''; }

0 0

712 0 0 my $sDir = "$DBdir/$DBsessions";

713 0 0 0 0 if (!-d $sDir && !&check_db_files) { return ''; }

0 0

714

715 0 0 $^T =~ /\d{6}$/; my $sessionid = 't'.$&.'_';

0 0

716 0 0 my $a = $userid.'_'.$email,'______';

717 0 0 $a =~ /.*?(\w).*?(\w).*?(\w).*?(\w).*?(\w).*?(\w)/;

718 0 0 $sessionid.= $1.$2.$3.$4.$5;

719 0 0 0 if (! mkdir("$sDir/$sessionid", 0700)) {

720 0 0 0 my $cnt=1; for(;$cnt<100 and !mkdir("$sDir/${sessionid}_$cnt", 0700); ++$cnt) {}

0 0

721 0 0 0 croak "Cannot create sessions!" if $cnt == 100;

722 0 0 $sessionid = "${sessionid}_$cnt";

723 }

724 0 0 $SessionId = $sessionid; $Ticket = &gen_secret;

0 0

725 0 0 my $sessionrecord = "SessionId:$SessionId\nTicket:$Ticket\n";

726 0 0 0 $sessionrecord.="email:$email\n" if $email ne '';

727 0 0 0 $sessionrecord.="userid:$userid\n" if $userid ne '';

728 0 0 my $sessioninfofile = "$sDir/$SessionId/session.info";

729 0 0 putfile($sessioninfofile, $sessionrecord);

730 0 0 $UserEmail = $email; $UserId = $userid; $User = $u;

0 0

731 0 0 $Session = &read_db_record("file=$sessioninfofile");

732 0 0 0 die unless ref($Session);

733 0 0 return $SessionId;

734 }

735

736 # Return 1 if OK, '' otherwise

737 sub password_check {

738 0 0 0 0 my $u = shift; my $password = shift;

0 0

739 0 0 0 0 if (defined($u->{status}) and $u->{status}=~/^\s*disabled\b/)

740 0 0 { return '' }

741 0 0 0 if ($LDAPuse) { return &password_check_ldap($u->{userid}, $password); }

0 0

742 0 0 my $pwstored = &find_password($u->{email});

743 0 0 0 if ($pwstored =~ /^raw:/) {

744 0 0 0 $pwstored=$'; return ( ($pwstored eq $password) ? 1 : '' ); }

0 0

745 0 0 0 if ($pwstored =~ /^md5:/) {

746 0 0 0 $pwstored=$'; return ( ($pwstored eq md5_base64($password)) ? 1 : ''); }

0 0

747 0 0 $Error.="316-ERR:PWCheck error($pwstored)\n"; $ErrorInternal="AuthRegister:$Error"; return '';

0 0

748 }

749

750 # Modifying for LDAP; Return 1 if OK, '' otherwise

751 sub password_check_ldap {

752 0 0 0 0 my $username = shift; my $password = shift;

0 0

753 0 0 $username =~ s/[^a-zA-Z0-9._+=-]//g;

754 0 0 0 0 if ($username eq '' or $LDAPserver eq '' or $LDAPdn eq '') { return '' }

0 0 0

755 #use Net::LDAP;

756 0 0 eval "require Net::LDAP;";

757 0 0 0 if ($@) { $Error.="643-ERR: Net::LDAP module required for LDAP ".

0 0

758 0 0 "functionality\n"; return ''; }

759 0 0 my $dn = "uid=$username,$LDAPdn";

760 0 0 0 my $ldap = Net::LDAP->new("ldaps://$LDAPserver") or die "$@";

761 0 0 my $mesg = $ldap->bind($dn, password => $password);

762 0 0 0 if ($mesg->code == 0) {

763 # Password correct

764 0 0 $ldap->unbind; $ldap->disconnect;

0 0

765 0 0 return 1;

766 }

767 # else invalid password

768 0 0 $ldap->unbind;

769 0 0 $ldap->disconnect;

770 0 0 return '';

771 }

772

773 sub find_password {

774 0 0 0 0 my $email = shift; my $pwfile = "$DBdir/$DBpwd";

0 0

775 0 0 $email = lc $email;

776 0 0 0 0 if (!-f $pwfile && !&check_db_files) { return '' }

0 0

777 0 0 0 if (!&lock_mkdir($pwfile)) { $Error.="431-ERR:\n"; return ''; }

0 0

778 0 0 0 local *PH; if (!open(PH,$pwfile)) { &unlock_mkdir($pwfile);

0 0

779 0 0 $Error.="433-ERR: Cannot open ($pwfile):$!\n"; return ''; }

0 0

780 0 0 while () {

781 0 0 my ($e,$p) = split; $e = lc $e;

0 0

782 0 0 0 if ($e eq $email) { close(PH); &unlock_mkdir($pwfile); return $p; }

0 0

783 }

784 0 0 $Error.="NOTFOUND($email)";

785 0 0 close(PH); &unlock_mkdir($pwfile); return '';

0 0

786 }

787

788 # Try to generate a secure random secret

789 # The best option is to use Math::Random::Secure if available

790 # This implementation uses its own additional randomization

791 sub gen_secret {

792 0 0 0 0 0 my $n = shift; $n = 10 unless $n > 0; my $ret;

0 0

793 0 0 while (length($ret) < $n) {

794 0 0 $SecretSalt.= md5_base64($SecretSalt.rand);

795 0 0 my $a=md5_base64($SecretSalt.rand); $a=~ s/[+\/]//g; $ret.=$a;

0 0

796 }

797 0 0 return substr($ret, 0, $n);

798 }

799

800 sub random_name {

801 1 50 1 0 2 my $n = shift; $n = 8 unless $n > 0;

1 6

802 1 9 my @chars = (0..9, 'a'..'z', 'A'..'Z');

803 1 3 return join('', map { $chars[rand($#chars+1)] } (1..$n));

8 68

804 }

805

806 sub store_log {

807 0 0 0 0 if($#_>=-1) { $LogReport.=$_[0] }

808 0 0 return if $LogReport eq '';

809 0 0 if ($SendLogs) { &send_email_to_admin('Log entry', $LogReport); }

810 0 $LogReport = '';

811 }

812

813 ########################################################################

814 # Section: Email communication

815

816 # params: $email, opt: 'raw' or 'md5' to generate passord

817 sub reset_and_send_email_reminder {

818 0 0 0 my $email = shift; my $pwstore = shift;

819 0 $email=lc $email; $email =~ s/\s/ /g;

820 0 0 if ($email eq '') {

821 0 $Error.="328-ERR:No e-mail provided to send password\n"; return; }

822 0 0 if (!emailcheckok($email)) {

823 0 $Error.="330-ERR:Invalid e-mail address provided($email)\n"; return; }

824 0 my $user = get_user_unique('email',$email);

825 0 0 if ($user eq '') {

826 0 $Error.="333-ERR: No user with email ($email)\n"; return; }

827 0 my $pw = &reset_password($email, $pwstore);

828 0 &send_email_reminder1($email, $pw);

829 0 return 1;

830 }

831

832 # params: $email, opt: 'raw' or 'md5' to generate new password if not found

833 sub send_email_reminder {

834 0 0 0 my $email = shift; my $pwstore = shift;

835 0 $email=lc $email; $email =~ s/\s/ /g;

836 0 0 if ($email eq '') {

837 0 $Error.="505-ERR:No e-mail provided to send password\n"; return; }

838 0 my $user;

839 0 0 if ($email =~ /@/) { $user = &get_user_unique('email', $email) }

840 0 else { $user = &get_user_unique('userid', $email) }

841 0 0 if ($user eq '') {

842 0 $Error.="510-ERR: No user with userid/email ($email)\n"; return; }

843 0 $email = $user->{email};

844 0 0 if (!emailcheckok($email)) {

845 0 $Error.="513-ERR:Invalid e-mail address ($email)\n"; return; }

846 0 my $pw = find_password($email);

847 0 0 if ($pw =~ /^raw:/) { $pw = $' }

848 0 elsif ($pw ne '') { $Error.="516-ERR:Cannot retrieve password\n"; return; }

849 0 else { $pw = &reset_password($email, $pwstore) }

850

851 0 &send_email_reminder1($email, $pw);

852 0 return 1;

853 }

854

855 sub send_email_reminder1 {

856 0 0 0 my $email = shift; my $pw = shift;

857 0 my $httpslogin = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";

858

859 0 my $msg = "Hi,\n\nYour email and password for the $SiteId site is:\n\n".

860 "Email: $email\nPassword: $pw\n\n".

861 "You can log in at:\n\n$httpslogin\n\n\n".

862 # "$HttpsBaseLink/login.cgi\n\n\n".

863 "Best regards,\n$SiteId Admin\n";

864 0 &send_email_to($email, "Subject: $SiteId Password Reminder", $msg);

865 }

866

867 sub send_email_to_admin {

868 0 0 0 my $subject = shift; my $msg1 = shift;

869 0 $subject =~ s/\s+/ /g;

870 0 $subject = "Subject: [$SiteId System Report] $subject";

871 0 0 return if $Email_bcc eq '';

872 0 my $msg = '';

873 0 0 $msg.="From: $Email_from\n" unless $Email_from eq '';

874 0 $msg.="To: $Email_bcc\n";

875 0 $msg.="$subject\n\n$msg1";

876 0 &_send_email($msg);

877 }

878

879 sub send_email_to {

880 0 0 0 0 my $email = shift; croak unless &emailcheckok($email);

881 0 my $subject = shift; $subject =~ s/[\n\r]/ /g;

882 0 0 if ($subject !~ /^Subject: /) { $subject = "Subject: $subject" }

883 0 my $msg1 = shift;

884

885 0 my $msg = '';

886 0 0 $msg.="From: $Email_from\n" unless $Email_from eq '';

887 0 $msg.="To: $email\n";

888 0 0 $msg.="Bcc: $Email_bcc\n" unless $Email_bcc eq '';

889 0 $msg.="$subject\n\n$msg1";

890 0 &_send_email($msg);

891 }

892

893 sub _send_email {

894 0 0 my $fullmessage = shift;

895 0 0 if (! -x $Sendmail) {

896 0 $Error.="390-ERR:No sendmail ($Sendmail)\n"; return ''; }

897 0 local *S;

898 0 0 if (!open(S,"|$Sendmail -ti")) {

899 0 $Error.="393-ERR:Cannot run sendmail:$!\n"; return ''; }

900 0 print S $fullmessage; close(S);

901 }

902

903 ########################################################################

904 # Section: Data checks and transformations

905

906 # encode string into a \w* sequence

907 sub encode_w {

908 0 0 0 local $_ = shift;

909 0 s/[\Wx]/'x'.uc unpack("H2",$&)/ge;

910 0 return $_;

911 }

912

913 sub decode_w {

914 0 0 0 local $_ = shift;

915 0 s/x([0-9A-Fa-f][0-9A-Fa-f])/pack("c",hex($1))/ge;

916 0 return $_;

917 }

918

919 sub encodeuri($) {

920 0 0 0 local $_ = shift;

921 0 s/[^-A-Za-z0-9_.~:\/?=]/"%".uc unpack("H2",$1)/ge;

922 0 return $_;

923 }

924

925 # Prepare for HTML display by quoting meta characters.

926 0 0 0 sub htmlquote($) { local $_ = shift; s/&/&/g; s/

927

928 sub emailcheckok {

929 0 0 0 my $email = shift;

930 0 0 if ($email =~ /^[a-zA-Z][\w\.+-]*[a-zA-Z0-9+-]@

931 [a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$/x)

932 0 { return 1 }

933 0 return '';

934 }

935

936 sub useridcheckok {

937 0 0 0 0 my $userid = shift; return 1 if $userid=~/^[a-zA-Z0-9-]+$/; return ''; }

938

939 # DB related functions

940

941 sub read_users_db {

942 0 0 0 my $f = "$DBdir/$DBusers";

943 0 0 if (!-f $f) { $Error.= "636-ERR: no file $f\n"; return; }

944 0 return &read_db("file=$f") }

945

946 sub _db8_find_first {

947 0 0 my $dbf = shift; my $k = shift; my $v = shift;

948 0 0 die unless $k =~ /^k=/; $k = $';

949 0 my $db_ref = &read_db("file=$dbf");

950 0 0 if (ref($db_ref) ne 'ARRAY') {

951 0 $Error.="745-ERR: Could not read db file ($dbf)"; return ''; }

952 0 my @db = @{ $db_ref };

953 0 for my $r (@db) {

954 0 0 0 if (exists($r->{$k}) && $v eq $r->{$k}) { $Error.="FOUND\n"; return $r } }

955 0 return '';

956 }

957

958 sub get_user {

959 0 0 0 my $k = shift; my $v = shift;

960 0 my $db_ref = &read_users_db;

961 0 0 if (ref($db_ref) ne 'ARRAY') {

962 0 $Error.="AuthERR-836: Could not get users data (file system problem?)\n";

963 0 return $User='';

964 }

965 0 my @db = @{ $db_ref };

966 0 for my $r (@db)

967 0 0 0 { if (exists($r->{$k}) && $v eq $r->{$k}) { return $User=$r } }

968 0 $Error.="AuthERR-842: no user with key=($k) v=($v)\n"; return $User='';

969 }

970

971 sub get_user_by_email {

972 0 0 0 my $email = shift;

973 0 my $db_ref = &read_users_db;

974 0 0 if (ref($db_ref) ne 'ARRAY') {

975 0 $Error.="657-ERR: Could not get users data (file system problem?)";

976 0 return $User=''; }

977 0 my @db = @{ $db_ref };

978 0 0 for my $r (@db) { if (lc($email) eq lc($r->{email})) { return $User=$r } }

979 0 $Error.="661-ERR: no user with email ($email)\n"; return $User='';

980 }

981

982 0 0 0 sub get_user_by_userid { return &get_user('userid', $_[0]) }

983

984 # Get user by userid, or add userid if does not exist

985 sub get_user_by_userid_or_add {

986 0 0 0 my $userid = shift; my $f = "$DBdir/$DBusers";

987 0 0 0 if (!-f $f && !&check_db_files) { return '' }

988 0 my @db = @{ &read_db("file=$f") };

989 0 my $u = '';

990 0 for my $r (@db) {

991 0 0 next unless exists($r->{userid}); my $v1 = $r->{userid};

992 0 $v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;

993 0 0 next unless $v1 eq $userid;

994 0 0 if ($u eq '') { $u = $r; next; }

995 0 $Error.= "819-ERR: double userid ($userid)\n"; return '';

996 }

997 0 0 return $User=$u unless $u eq '';

998 0 $userid =~ s/\s//g; &_db8_append($f, "userid:$userid");

999 0 return get_user_by_userid($userid);

1000 }

1001

1002 # Get user by a key,value, but make sure there is exactly one such user

1003 # Normalizes whitespace and case insensitive

1004 sub get_user_unique {

1005 0 0 0 my $k = shift; my $v = shift; my $f = "$DBdir/$DBusers";

1006 0 0 0 if (!-f $f && !&check_db_files) { return '' }

1007 0 my @db = @{ &read_db("file=$f") };

1008 0 $v=~s/^\s+//; $v=~s/\s+$//; $v=~s/\s+/ /g; $v = lc $v;

1009 0 0 0 if ($k eq '' or $v eq '')

1010 0 { $Error.="669-ERR:Empty k or v ($k:$v)\n"; return ''; }

1011 0 my $u = '';

1012 0 for my $r (@db) {

1013 0 0 next unless exists($r->{$k}); my $v1 = $r->{$k};

1014 0 $v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;

1015 0 0 next unless $v eq $v1;

1016 0 0 if ($u eq '') { $u = $r; next; }

1017 0 $Error.= "676-ERR: double user key ($k:$v)\n"; return '';

1018 }

1019 0 0 return $User=$u unless $u eq '';

1020 0 $Error.="894-ERR: no user with key ($k:$v)\n"; return '';

1021 }

1022

1023 sub check_db_files {

1024 0 0 0 my $ret; my $pwfile = "$DBdir/$DBpwd";

1025 0 0 if (!-d $DBdir) { $ret = mkdir($DBdir, 0700);

1026 0 0 if (!$ret) { $Error.="687-ERR: Could not create dir '$DBdir'"; return ''; }}

1027 0 0 if (!-f $pwfile) { putfile $pwfile, ''; chmod 0600, $pwfile; }

1028 0 0 if (!-f $pwfile) { $Error.="689-ERR: Could not create $pwfile file";

1029 0 return ''; }

1030 0 my $f = "$DBdir/$DBusers";

1031 0 0 if (!-f $f) { putfile $f, "#userid:someid\n#email:email\@domain.com\n";

1032 0 chmod 0600, $f; }

1033 0 0 if (!-f $f) { $Error.="694-ERR: Could not create $f file"; return ''; }

1034 0 $f = "$DBdir/$DBsessions";

1035 0 0 if (!-d $f) { $ret = mkdir($f, 0700);

1036 0 0 if (!$ret) { $Error.="708-ERR: Could not create dir '$f'"; return ''; }}

1037

1038 0 return 1;

1039 }

1040

1041 # _db8_update - updates given db with minimal changes

1042 # Usage: db8_update($strOrFile, $db)

1043 # 2013-2017 Vlado Keselj, version 1.4; documentation in DB822.txt

1044 # Example: &db8_update("file=$filename", $db);

1045 sub _db8_update {

1046 0 0 my $arg = shift; my $db=shift; my $file='';

1047 0 0 if ($arg =~ /^file=/) {

1048 0 0 $file = $'; die "file=''!?" if $file eq '';

1049 0 0 local *F; open(F, $file) or die "cannot open $file:$!";

1050 0 $arg = join('', );

1051 0 close(F);

1052 }

1053

1054 0 my $arg_save = $arg; my $dbi = 0; my $argcopy = '';

1055 0 while ($arg) {

1056 # allow comments and space betwen records

1057 0 0 if ($arg =~ /^(\s*\n|[ \t]*#.*\n)*/) { $argcopy.=$&; $arg = $'; }

1058 0 my $record;

1059 0 0 if ($arg =~ /\n(\n+)/) { $record = "$`\n"; $arg = $1.$'; }

1060 0 else { $record = $arg; $arg = ''; }

1061 0 0 if ($dbi > $#{$db}) { last }

1062 0 my $r = {}; my %savedkeys = ();

1063 0 while ($record) {

1064 0 my $avpair = '';

1065 0 0 if ($record =~ /^.*/) { $avpair = $& }

1066 0 while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)

1067 0 { $record = "$1 $3$'"; $avpair.= $2.$3; }

1068 0 0 $record =~ /^([^\n:]*):(.*)\n/ or die;

1069 0 my $k = $1; my $v = $2; $record = $';

1070 0 $avpair .= "\n";

1071 0 0 if (exists($r->{$k})) {

1072 0 my $c = 0;

1073 0 while (exists($r->{"$k-$c"})) { ++$c }

1074 0 $k = "$k-$c";

1075 }

1076 0 $r->{$k} = $v;

1077 0 0 0 if (exists($db->[$dbi]->{$k}) && $db->[$dbi]->{$k} eq $v)

1078 0 { $argcopy .= $avpair }

1079 elsif (exists($db->[$dbi]->{$k})) {

1080 0 my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved

1081 0 $argcopy .= "$k:$newv\n";

1082 } # else skip it

1083 0 $savedkeys{$k} = 1;

1084 }

1085 0 for my $k (keys %{ $db->[$dbi] }) {

1086 0 0 if (!exists($savedkeys{$k})) {

1087 0 my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved

1088 0 $argcopy .= "$k:$newv\n";

1089 }

1090 }

1091 0 ++$dbi;

1092 }

1093

1094 0 while ($dbi <= $#{$db}) {

1095 0 $argcopy .= "\n";

1096 0 for my $k (sort(keys(%{ $db->[$dbi] }))) {

1097 0 my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved

1098 0 $argcopy .= "$k:$newv\n";

1099 }

1100 0 ++$dbi;

1101 }

1102

1103 0 0 if ($file ne '') {

1104 0 0 if ($argcopy ne $arg_save) {

1105 #rename($file, "$file.bak");

1106 0 local *F; open(F,">$file"); print F $argcopy; close(F);

1107 }

1108 0 return;

1109 0 } else { return $argcopy }

1110 } # end of _db8_update

1111

1112 sub _db8_remove {

1113 0 0 my $dbf = shift; my $kdel = shift; my $vdel = shift;

1114 0 0 die unless $kdel =~ /^k=/; $kdel = $';

1115 0 0 if (!&lock_mkdir($dbf)) { $Error.="793-ERR"; return '' }

1116 0 0 local *F; if (!open(F, $dbf)) { &unlock_mkdir($dbf);

1117 0 $Error.="795-ERR: opening file $dbf: $!"; return ''; }

1118 0 my $arg = join('',); close(F);

1119

1120 0 my $arg_save = $arg; my $dbi = 0; my $argcopy = '';

1121 0 while ($arg) {

1122 0 my $prologue;

1123 0 0 if ($arg =~ /^([ \t\r]*(#.*)?\n)+/) { $prologue = $&; $arg = $'; }

1124 0 $argcopy.=$prologue;

1125 0 0 last if $arg eq ''; my $record; my $record_save;

1126 0 0 if ($arg =~ /([ \t\r]*\n){2,}/) {

1127 0 $record = "$`\n"; $arg = $'; $record_save = "$`$&"; }

1128 0 else { $record_save = $record = $arg; $arg = ''; }

1129 0 my $r = {};

1130 0 while ($record) {

1131 0 0 $record =~ /^[ \t]*([^\n:]*?)[ \t]*:/ or die "db8: no attribute";

1132 0 my $k = $1; $record = $';

1133 0 while ($record =~ /^(.*)(\\\r?\n|\r?\n[ \t]+)(\S.*)/)

1134 0 { $record = "$1 $3$'" }

1135 0 0 $record =~ /^[ \t]*(.*?)[ \t\r]*\n/ or die;

1136 0 my $v = $1; $record = $';

1137 0 0 if (exists($r->{$k})) {

1138 0 my $c = 0;

1139 0 while (exists($r->{"$k-$c"})) { ++$c }

1140 0 $k = "$k-$c";

1141 }

1142 0 $r->{$k} = $v;

1143 }

1144 0 0 0 if (exists($r->{$kdel}) && $r->{$kdel} eq $vdel) {}

1145 0 else { $argcopy .= $record_save }

1146 }

1147

1148 0 0 if ($argcopy ne $arg_save) {

1149 0 0 if (!open(F, ">$dbf.lock/new")) { &unlock_mkdir($dbf);

1150 0 $Error.="828-ERR: opening file $dbf.lock/new: $!"; return ''; }

1151 0 print F $argcopy; close(F); chmod 0600, "$dbf.lock/new"; unlink($dbf);

1152 0 rename("$dbf.lock/new", $dbf); }

1153 0 &unlock_mkdir($dbf);

1154 } # end of _db8_remove

1155

1156 # Read DB records in the RFC822-like style (to add reference).

1157 sub read_db {

1158 0 0 0 my $arg = shift;

1159 0 0 if ($arg =~ /^file=/) {

1160 0 0 my $f = $'; if (!&lock_mkdir($f)) { return '' }

1161 0 local *F;

1162 0 0 if (!open(F, $f)) {

1163 0 $Error.="ERR-945: $f: $!"; &unlock_mkdir($f); return ''; }

1164 0 $arg = join('', ); close(F); &unlock_mkdir($f);

1165 }

1166

1167 0 my $db = [];

1168 0 while ($arg) {

1169 0 $arg =~ s/^\s*(#.*\s*)*//; # allow comments betwen records

1170 0 my $record;

1171 0 0 if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }

1172 0 else { $record = $arg; $arg = ''; }

1173 0 my $r = {};

1174 0 while ($record) {

1175 0 0 if ($record =~ /^#.*\n?/) { $record=$'; next; }

1176 0 while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)

1177 0 { $record = "$1 $3$'" }

1178 0 0 $record =~ /^([^\n:]*):(.*)\n/ or die;

1179 0 my $k = $1; my $v = $2; $record = $';

1180 0 0 if (exists($r->{$k})) {

1181 0 my $c = 0;

1182 0 while (exists($r->{"$k-$c"})) { ++$c }

1183 0 $k = "$k-$c";

1184 }

1185 0 $r->{$k} = $v;

1186 }

1187 0 push @{ $db }, $r;

1188 }

1189 0 return $db;

1190 }

1191

1192 # Append a record or records to db8

1193 # Assumes that the file is in a good format

1194 sub _db8_append {

1195 0 0 my $fdb=shift;

1196 0 0 if (!&lock_mkdir($fdb)) { $Error.="ERR-975: $!"; return '' }

1197 0 0 local *F; if (!open(F, ">>$fdb")) { &unlock_mkdir($fdb);

1198 0 $Error.="ERR-977: write file $fdb: $!"; return ''; }

1199 0 while (@_) { my $r=shift; $r =~ s/\s*$/\n/s; print F "\n$r"; }

1200 0 &unlock_mkdir($fdb);

1201 }

1202

1203 # Read one DB record in the RFC822-like style (to add reference).

1204 sub read_db_record {

1205 0 0 0 my $arg = shift;

1206 0 0 if ($arg =~ /^file=/) {

1207 0 0 my $f = $'; local *F; open(F, $f) or die "cannot open $f:$!";

1208 0 $arg = join('', ); close(F);

1209 }

1210

1211 0 while ($arg =~ s/^(\s*|\s*#.*)\n//) {} # allow comments before record

1212 0 my $record;

1213 0 0 if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }

1214 0 else { $record = $arg; $arg = ''; }

1215 0 my $r = {};

1216 0 while ($record) {

1217 0 while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)

1218 0 { $record = "$1 $3$'" }

1219 0 0 $record =~ /^([^\n:]*):(.*)\n/ or die;

1220 0 my $k = $1; my $v = $2; $record = $';

1221 0 0 if (exists($r->{$k})) {

1222 0 my $c = 0;

1223 0 while (exists($r->{"$k-$c"})) { ++$c }

1224 0 $k = "$k-$c";

1225 }

1226 0 $r->{$k} = $v;

1227 }

1228 0 return $r;

1229 }

1230

1231 # parameters: $n - sequence length; @_ domain elements

1232 sub random_string {

1233 0 0 0 my $n = shift;

1234 0 0 return '' if $n < 1;

1235 0 my @r = map { $_[rand($#_+1)] } (1..$n);

1236 0 return join('',@r);

1237 }

1238

1239 sub putfile($@) {

1240 0 0 0 my $f = shift; local *F;

1241 0 0 if (!open(F, ">$f")) { $Error.="325-ERR:Cannot write ($f):$!\n"; return; }

1242 0 for (@_) { print F } close(F);

1243 }

1244

1245 sub getfile($) {

1246 0 0 0 my $f = shift; local *F;

1247 0 0 if (!open(F, "<$f")) {

1248 0 $Error.="ERR-1099:getfile:cannot open $f:$!"; return; }

1249 0 my @r = ; close(F);

1250 0 0 return wantarray ? @r : join ('', @r);

1251 }

1252

1253 ########################################################################

1254 # Section: Simple file locking using mkdir

1255

1256 # Exlusive locking using mkdir

1257 # lock_mkdir($fname); # return 1=success ''=fail

1258 sub lock_mkdir {

1259 0 0 0 my $fname = shift; my $lockd = "$fname.lock"; my $locked;

1260 # First, hopefully most usual case

1261 0 0 0 if (!-e $lockd && ($locked = mkdir($lockd,0700))) { return $locked }

1262 0 my $tryfor=10; #sec

1263 0 $locked = ''; # flag

1264 0 for (my $i=0; $i<2*$tryfor; ++$i) {

1265 0 select(undef,undef,undef,0.5); # wait for 0.5 sec

1266 0 0 !-e $lockd && ($locked = mkdir($lockd,0700));

1267 0 0 if ($locked) { return $locked }

1268 }

1269 0 $Error.="393-ERR:Could not lock file ($fname)\n"; return $locked;

1270 }

1271

1272 # Unlock using mkdir

1273 # unlock_mkdir($fname); # return 1=success ''=fail or no lock

1274 sub unlock_mkdir {

1275 0 0 0 my $fname = shift; my $lockd = "$fname.lock";

1276 0 0 if (!-e $lockd) { $Error.="400-ERR:No lock on ($fname)\n"; return '' }

1277 0 0 if (-d $lockd) { return rmdir($lockd) }

1278 0 0 0 if (-f $lockd or -l $lockd) { unlink($lockd) }

1279 0 $Error.="403-ERR:Unknown error"; return '';

1280 }

1281

1282 ########################################################################

1283 # Section: Prepackaged HTML and CSS files

1284

1285 sub gen_cas_page {

1286 0 0 0 my $ret;

1287 #

1288 # echo "\$ret=<<'EOT';\n${c}EOT"; !>#+

1289 0 $ret=<<'EOT';

1290

1291 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

1292

1293 CAS - Central Authentication Service

1294

1295

1296

1297

1298

1299 media="handheld, only screen and (max-device-width: 480px)" type="text/css">

1300

1301

1306

1307

1312

1313

1314

1315

1316

CAS – Central Authentication

1317 Service

1318

1319

1320

1321

1322

1323

1324
1325							Login Required
1326							CAS Authentication
1327
1328
1329

1330							UserID:
1331
1332
1333							size="20" autocomplete="off" type="text">
1334
1335
1336
1337

1338							Password:
1339
1340
1341							value="" size="20" autocomplete="off" type="password">
1342
1343
1344

1345
1346
1347
1348							name="request_type">
1349
1350

1351
1352							Please note
1353							Before entering your userid and password, verify that the URL
1354							for this page begins with:
1355							_THIS_URL_
1356
1357							To protect your privacy, quit your web browser when you
1358							are done accessing services that require authentication.
1359
1360
1361

1362

1363

1364

1365

1366

1367

1368

1369

1370

1371

1372

1373

1374

1375

1376

1377

1378

1379

1380

1381

1382

1383

1384 EOT#-

1385 #+

1386 $ret=<<'EOT';

1387

1388 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

1389

1390 CAS - Central Authentication Service

1391

1392

1393

1394

1395

1396 media="handheld, only screen and (max-device-width: 480px)" type="text/css">

1397

1398

1403

1404

1409

1410

1411

1412

1413

CAS – Central Authentication

1414 Service

1415

1416

1417

1418

1419

1420

1421
1422							Login Required
1423							CAS Authentication
1424
1425
1426

1427							UserID:
1428
1429
1430							size="20" autocomplete="off" type="text">
1431
1432
1433
1434

1435							Password:
1436
1437
1438							value="" size="20" autocomplete="off" type="password">
1439
1440
1441

1442
1443
1444
1445							name="request_type">
1446
1447

1448
1449							Please note
1450							Before entering your userid and password, verify that the URL
1451							for this page begins with:
1452							_THIS_URL_
1453
1454							To protect your privacy, quit your web browser when you
1455							are done accessing services that require authentication.
1456
1457
1458

1459

1460

1461

1462

1463

1464

1465

1466

1467

1468

1469

1470

1471

1472

1473

1474

1475

1476

1477

1478

1479

1480

1481 EOT

1482 #-

1483 0 0 if ($GenCasPageCustom ne '') { $ret = $GenCasPageCustom }

1484

1485 0 my $cssCasAll = $ENV{SCRIPT_NAME}.'?cas-all.css';

1486 0 my $cssCasMobile = $ENV{SCRIPT_NAME}.'?cas-mobile.css';

1487 0 $ret=~ s/href="cas-all.css"/href="$cssCasAll"/;

1488 0 $ret=~ s/href="cas-mobile.css"/href="$cssCasMobile"/;

1489

1490 0 my $redirect_uri;

1491 0 0 if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }

1492 0 elsif (param('r') ne '') { $redirect_uri = param('r') }

1493

1494 # Remove "Before entering" unless there is a URL to show (todo, for now,

1495 # just remove)

1496 0 $ret=~ s/.*?(<\/p>)/$1/s;

1497

1498 0 my $forgotpassword = 1; # include link, todo for exclusion

1499 0 my $removerighthandside = 1;

1500 0 0 if ($forgotpassword) {

1501 0 $removerighthandside=''; $ret=~s//$1/g; }

1502 0 0 if ($SessionId ne '') { $ret=~s//$1/g; }

1503

1504 0 $ret=~s///g;

1505

1506 # Remove righthand side

1507 0 0 if($removerighthandside) {

1508 0 $ret =~

1509

s/(

)(.*?)(<\/div>)/$1$3/s;

1510 }

1511 else { # remove "hideinMobile"

1512 0 $ret =~ s///; }

1513

1514 0 return $ret;

1515 }

1516

1517 sub deliver {

1518 0 0 0 my $par = shift;

1519 0 0 if ($par eq 'cas-all.css') {

1520 0 print "Content-Type: text/css; charset=UTF-8\n\n".

1521 #

1522 # echo "<<'EOT';\n${c}EOT\n;"; !>#+

1523 <<'EOT';

1524 body {

1525 background-color: #D1AF55; /*#76A9DC;*/

1526 color: #444;

1527 font-family: "Times New Roman", Times, serif;

1528 margin: 30px;

1529 padding: 5px;

1530 }

1531

1532 a:link { text-decoration: none; }

1533 a:visited { text-decoration: none; }

1534 a:active { text-decoration: none; }

1535 a:hover { text-decoration: underline; }

1536 .hide { display: none; }

1537

1538 .shadow {

1539 box-shadow: 5px 5px 5px #ccc;

1540 -moz-box-shadow: 5px 5px 5px #ccc;

1541 -webkit-box-shadow: 5px 5px 5px #ccc;

1542 }

1543

1544 #pagebox {

1545 background: #fff;

1546 border: 1px solid #000;

1547 box-shadow: 10px 10px 10px #444;

1548 -moz-box-shadow: 10px 10px 10px #444;

1549 -webkit-box-shadow: 10px 10px 20px #444;

1550 margin: 0px auto;

1551 width: 788px;

1552 height: 491px;

1553 }

1554

1555 #headerBox {

1556 background: #A17F25;

1557 border-bottom: 1px solid #916F15;

1558 border-left: 1px solid #916F15;

1559 border-right: 1px solid #916F15;

1560 border-top: 1px solid #916F15;

1561 clear: both;

1562 height: 82px;

1563 width: 786px;

1564 text-align:center;

1565 color: #ffffff;

1566 }

1567

1568 #content-left {

1569 background: #fff;

1570 border-right: 1px solid #0F4D92;

1571 clear: both;

1572 float: left;

1573 height: 377px;

1574 margin: 0px;

1575 padding: 15px;

1576 width: 530px;

1577 }

1578

1579 #content-right {

1580 background: #fafae8;

1581 border: 0px;

1582 float: right;

1583 height: 377px;

1584 margin: 0px;

1585 padding: 15px;

1586 width: 197px;

1587 }

1588

1589 #content-left h1 {

1590 font-family: "Times New Roman", Times, serif;

1591 font-size: 20px;

1592 font-weight: normal;

1593 margin: 0px 0px 5px 0px;

1594 }

1595

1596 #content-left h2 {

1597 font-family: "Times New Roman", Times, serif;

1598 font-size: 20px;

1599 font-weight: normal;

1600 margin: 5px 0px 5px 0px;

1601 }

1602

1603 #content-left p.formLabel {

1604 color: #5F5F5F;

1605 font-family: "Times New Roman", Times, serif;

1606 font-size: 16px;

1607 font-weight: normal;

1608 margin: 6px 0px 0px 0px;

1609 text-align: right;

1610 }

1611

1612 #content-left p.sans {

1613 color: #5F5F5F;

1614 font-family: Verdana, Arial, Helvetica, sans;

1615 font-size: 11px;

1616 font-weight: normal;

1617 line-height: 1.7em;

1618 margin: 5px 0px 5px 0px;

1619 }

1620

1621 #content-left p.sansURL {

1622 color: #4e6d98;

1623 font-family: Verdana, Arial, Helvetica, sans;

1624 font-size: 11px;

1625 font-weight: normal;

1626 line-height: 1em;

1627 margin: 15px 0px 5px 0px;

1628 }

1629

1630 #content ul.plain, ul.plain a {

1631 color: #1A3E6F;

1632 font-family: Verdana, Geneva, Arial, sans-serif;

1633 font-size: 14px;

1634 line-height: 1.5em;

1635 list-style: none;

1636 margin: .4em 0em .2em 0em;

1637 padding: 0em 0em 0em 0em;

1638 text-indent: 0em;

1639 }

1640

1641 #content ul.plain li, ul.plain li a {

1642 padding-bottom: 0.8em;

1643 }

1644

1645 #content ul.plain li.disabled {

1646 color: #bbb;

1647 }

1648

1649

1650 #content ul.plain-serif, ul.plain-serif a {

1651 color: #1A3E6F;

1652 font-family: "Times New Roman", Times, serif;

1653 font-size: 14px;

1654 line-height: 1.2em;

1655 list-style: none;

1656 margin: 30px 0px 0px 0px;

1657 padding: 0px 0px 0px 0px;

1658 text-indent: 0em;

1659 }

1660

1661 #content ul.plain-serif li, ul.plain-serif li a {

1662 padding-bottom: 0.8em;

1663 }

1664

1665 #content ol {

1666 font-family: Verdana, Arial, Helvetica, sans;

1667 font-size: 11px;

1668 font-weight: normal;

1669 line-height: 1.8em;

1670 margin: 0px 0px 0px 20px;

1671 padding: 0px 0px 0px 0px;

1672 text-indent: 0em;

1673 }

1674

1675 #content ol li, ol li a { padding-bottom: 0.8em; }

1676 EOT

1677 ;#-

1678 #+

1679 0 <<'EOT';

1680 body {

1681 background-color: #D1AF55; /*#76A9DC;*/

1682 color: #444;

1683 font-family: "Times New Roman", Times, serif;

1684 margin: 30px;

1685 padding: 5px;

1686 }

1687

1688 a:link { text-decoration: none; }

1689 a:visited { text-decoration: none; }

1690 a:active { text-decoration: none; }

1691 a:hover { text-decoration: underline; }

1692 .hide { display: none; }

1693

1694 .shadow {

1695 box-shadow: 5px 5px 5px #ccc;

1696 -moz-box-shadow: 5px 5px 5px #ccc;

1697 -webkit-box-shadow: 5px 5px 5px #ccc;

1698 }

1699

1700 #pagebox {

1701 background: #fff;

1702 border: 1px solid #000;

1703 box-shadow: 10px 10px 10px #444;

1704 -moz-box-shadow: 10px 10px 10px #444;

1705 -webkit-box-shadow: 10px 10px 20px #444;

1706 margin: 0px auto;

1707 width: 788px;

1708 height: 491px;

1709 }

1710

1711 #headerBox {

1712 background: #A17F25;

1713 border-bottom: 1px solid #916F15;

1714 border-left: 1px solid #916F15;

1715 border-right: 1px solid #916F15;

1716 border-top: 1px solid #916F15;

1717 clear: both;

1718 height: 82px;

1719 width: 786px;

1720 text-align:center;

1721 color: #ffffff;

1722 }

1723

1724 #content-left {

1725 background: #fff;

1726 border-right: 1px solid #0F4D92;

1727 clear: both;

1728 float: left;

1729 height: 377px;

1730 margin: 0px;

1731 padding: 15px;

1732 width: 530px;

1733 }

1734

1735 #content-right {

1736 background: #fafae8;

1737 border: 0px;

1738 float: right;

1739 height: 377px;

1740 margin: 0px;

1741 padding: 15px;

1742 width: 197px;

1743 }

1744

1745 #content-left h1 {

1746 font-family: "Times New Roman", Times, serif;

1747 font-size: 20px;

1748 font-weight: normal;

1749 margin: 0px 0px 5px 0px;

1750 }

1751

1752 #content-left h2 {

1753 font-family: "Times New Roman", Times, serif;

1754 font-size: 20px;

1755 font-weight: normal;

1756 margin: 5px 0px 5px 0px;

1757 }

1758

1759 #content-left p.formLabel {

1760 color: #5F5F5F;

1761 font-family: "Times New Roman", Times, serif;

1762 font-size: 16px;

1763 font-weight: normal;

1764 margin: 6px 0px 0px 0px;

1765 text-align: right;

1766 }

1767

1768 #content-left p.sans {

1769 color: #5F5F5F;

1770 font-family: Verdana, Arial, Helvetica, sans;

1771 font-size: 11px;

1772 font-weight: normal;

1773 line-height: 1.7em;

1774 margin: 5px 0px 5px 0px;

1775 }

1776

1777 #content-left p.sansURL {

1778 color: #4e6d98;

1779 font-family: Verdana, Arial, Helvetica, sans;

1780 font-size: 11px;

1781 font-weight: normal;

1782 line-height: 1em;

1783 margin: 15px 0px 5px 0px;

1784 }

1785

1786 #content ul.plain, ul.plain a {

1787 color: #1A3E6F;

1788 font-family: Verdana, Geneva, Arial, sans-serif;

1789 font-size: 14px;

1790 line-height: 1.5em;

1791 list-style: none;

1792 margin: .4em 0em .2em 0em;

1793 padding: 0em 0em 0em 0em;

1794 text-indent: 0em;

1795 }

1796

1797 #content ul.plain li, ul.plain li a {

1798 padding-bottom: 0.8em;

1799 }

1800

1801 #content ul.plain li.disabled {

1802 color: #bbb;

1803 }

1804

1805

1806 #content ul.plain-serif, ul.plain-serif a {

1807 color: #1A3E6F;

1808 font-family: "Times New Roman", Times, serif;

1809 font-size: 14px;

1810 line-height: 1.2em;

1811 list-style: none;

1812 margin: 30px 0px 0px 0px;

1813 padding: 0px 0px 0px 0px;

1814 text-indent: 0em;

1815 }

1816

1817 #content ul.plain-serif li, ul.plain-serif li a {

1818 padding-bottom: 0.8em;

1819 }

1820

1821 #content ol {

1822 font-family: Verdana, Arial, Helvetica, sans;

1823 font-size: 11px;

1824 font-weight: normal;

1825 line-height: 1.8em;

1826 margin: 0px 0px 0px 20px;

1827 padding: 0px 0px 0px 0px;

1828 text-indent: 0em;

1829 }

1830

1831 #content ol li, ol li a { padding-bottom: 0.8em; }

1832 EOT

1833 ;

1834 #-

1835 }

1836 elsif ($par eq 'cas-mobile.css') {

1837 0 print "Content-Type: text/css; charset=UTF-8\n\n".

1838 #

1839 # echo "<<'EOT';\n${c}EOT\n;"; !>#+

1840 <<'EOT';

1841 body {

1842 background-color: #fff;

1843 color: #444;

1844 font-family: "Times New Roman", Times, serif;

1845 margin: 0px;

1846 padding: 0px;

1847 }

1848

1849 a:link { text-decoration: none; }

1850 a:visited { text-decoration: none; }

1851 a:active { text-decoration: none; }

1852 a:hover { text-decoration: underline; }

1853 .hide { display: none; }

1854 .hideInMobile { display: none; }

1855

1856 #pagebox {

1857 border: 0px;

1858 background: #fff;

1859 margin: 0px;

1860 width: auto;

1861 height: auto;

1862 box-shadow: none;

1863 -moz-box-shadow: none;

1864 -webkit-box-shadow: none;

1865 }

1866

1867 #headerBox {

1868 border: 0px;

1869 background: #A17F25;

1870 overflow: hidden;

1871 width: auto;

1872 height: auto;

1873 }

1874

1875 #headerBox h1 { font-size: 14pt; }

1876

1877 #content-left {

1878 background: #fff;

1879 border: 0px;

1880 margin: 0px;

1881 padding: 15px;

1882 width: auto;

1883 height: auto;

1884 float: none;

1885 }

1886

1887 #content-right {

1888 background: #fff;

1889 border: 0px;

1890 width: auto;

1891 height: auto;

1892 float: none;

1893 margin-left: 85px;

1894 }

1895

1896 #form-layout { width: auto; }

1897

1898 #login_form input {

1899 background: #f8f8f8;

1900 border: 1px solid #aaa;

1901 color: #555;

1902 font-family: Verdana, Arial, Helvetica, sans;

1903 font-weight: normal;

1904 margin: 0px 0px 0px 0px;

1905 font-size: 16px;

1906 padding: 5px;

1907 }

1908

1909 #login_form input.inputButton {

1910 background: #F5F091;

1911 border: 1px solid #aaa;

1912 color: #555;

1913 font-family: Georgia, "Times New Roman", Times, serif;

1914 font-weight: normal;

1915 margin: 10px 0px 10px 0px;

1916 font-size: 18px;

1917 }

1918

1919 #login_form input.formInput {

1920 width: 170px;

1921 float: none;

1922 }

1923

1924 h1.mobileTitle { display: none; }

1925

1926 #content-left h1 {

1927 color: #883F0A;

1928 font-family: Georgia, "Times New Roman", Times, serif;

1929 font-weight: bold;

1930 margin: 0px 0px 5px 0px;

1931 font-size: 19px;

1932 }

1933

1934 #content-left h2 { display: none; }

1935 #content-left p.sans { display: none; }

1936 #content-left p.sansURL { display: none; }

1937 #content-left p.mobile-tight { margin: 0; }

1938

1939 #content ul.plain, ul.plain a {

1940 color: #1A3E6F;

1941 font-family: Verdana, Geneva, Arial, sans-serif;

1942 line-height: 1.3em;

1943 list-style: none;

1944 margin: .4em 0em .2em 0em;

1945 padding: 0em 0em 0em 0em;

1946 text-indent: 0em;

1947 font-size: 14px;

1948 }

1949

1950 #content ul.plain li, ul.plain li a {

1951 padding-bottom: 0.8em;

1952 }

1953

1954 #content ul.plain li.disabled {

1955 color: #bbb;

1956 }

1957

1958 #content ul.plain-serif, ul.plain-serif a {

1959 display: none;

1960 }

1961

1962 #content ul.plain-serif li, ul.plain-serif li a {

1963 padding-bottom: 0.8em;

1964 }

1965

1966 #content ol {

1967 color: #5F5F5F;

1968 font-family: Verdana, Arial, Helvetica, sans;

1969 font-size: 11px;

1970 font-weight: normal;

1971 line-height: 1.8em;

1972 margin: 0px 0px 0px 20px;

1973 padding: 0px 0px 0px 0px;

1974 text-indent: 0em;

1975 }

1976

1977 #content ol li, ol li a {

1978 padding-bottom: 0.8em;

1979 }

1980 EOT

1981 ;#-

1982 #+

1983 0 <<'EOT';

1984 body {

1985 background-color: #fff;

1986 color: #444;

1987 font-family: "Times New Roman", Times, serif;

1988 margin: 0px;

1989 padding: 0px;

1990 }

1991

1992 a:link { text-decoration: none; }

1993 a:visited { text-decoration: none; }

1994 a:active { text-decoration: none; }

1995 a:hover { text-decoration: underline; }

1996 .hide { display: none; }

1997 .hideInMobile { display: none; }

1998

1999 #pagebox {

2000 border: 0px;

2001 background: #fff;

2002 margin: 0px;

2003 width: auto;

2004 height: auto;

2005 box-shadow: none;

2006 -moz-box-shadow: none;

2007 -webkit-box-shadow: none;

2008 }

2009

2010 #headerBox {

2011 border: 0px;

2012 background: #A17F25;

2013 overflow: hidden;

2014 width: auto;

2015 height: auto;

2016 }

2017

2018 #headerBox h1 { font-size: 14pt; }

2019

2020 #content-left {

2021 background: #fff;

2022 border: 0px;

2023 margin: 0px;

2024 padding: 15px;

2025 width: auto;

2026 height: auto;

2027 float: none;

2028 }

2029

2030 #content-right {

2031 background: #fff;

2032 border: 0px;

2033 width: auto;

2034 height: auto;

2035 float: none;

2036 margin-left: 85px;

2037 }

2038

2039 #form-layout { width: auto; }

2040

2041 #login_form input {

2042 background: #f8f8f8;

2043 border: 1px solid #aaa;

2044 color: #555;

2045 font-family: Verdana, Arial, Helvetica, sans;

2046 font-weight: normal;

2047 margin: 0px 0px 0px 0px;

2048 font-size: 16px;

2049 padding: 5px;

2050 }

2051

2052 #login_form input.inputButton {

2053 background: #F5F091;

2054 border: 1px solid #aaa;

2055 color: #555;

2056 font-family: Georgia, "Times New Roman", Times, serif;

2057 font-weight: normal;

2058 margin: 10px 0px 10px 0px;

2059 font-size: 18px;

2060 }

2061

2062 #login_form input.formInput {

2063 width: 170px;

2064 float: none;

2065 }

2066

2067 h1.mobileTitle { display: none; }

2068

2069 #content-left h1 {

2070 color: #883F0A;

2071 font-family: Georgia, "Times New Roman", Times, serif;

2072 font-weight: bold;

2073 margin: 0px 0px 5px 0px;

2074 font-size: 19px;

2075 }

2076

2077 #content-left h2 { display: none; }

2078 #content-left p.sans { display: none; }

2079 #content-left p.sansURL { display: none; }

2080 #content-left p.mobile-tight { margin: 0; }

2081

2082 #content ul.plain, ul.plain a {

2083 color: #1A3E6F;

2084 font-family: Verdana, Geneva, Arial, sans-serif;

2085 line-height: 1.3em;

2086 list-style: none;

2087 margin: .4em 0em .2em 0em;

2088 padding: 0em 0em 0em 0em;

2089 text-indent: 0em;

2090 font-size: 14px;

2091 }

2092

2093 #content ul.plain li, ul.plain li a {

2094 padding-bottom: 0.8em;

2095 }

2096

2097 #content ul.plain li.disabled {

2098 color: #bbb;

2099 }

2100

2101 #content ul.plain-serif, ul.plain-serif a {

2102 display: none;

2103 }

2104

2105 #content ul.plain-serif li, ul.plain-serif li a {

2106 padding-bottom: 0.8em;

2107 }

2108

2109 #content ol {

2110 color: #5F5F5F;

2111 font-family: Verdana, Arial, Helvetica, sans;

2112 font-size: 11px;

2113 font-weight: normal;

2114 line-height: 1.8em;

2115 margin: 0px 0px 0px 20px;

2116 padding: 0px 0px 0px 0px;

2117 text-indent: 0em;

2118 }

2119

2120 #content ol li, ol li a {

2121 padding-bottom: 0.8em;

2122 }

2123 EOT

2124 ;

2125 #-

2126

2127 }

2128 0 exit;

2129 } # end of sub deliver

2130

2131 ########################################################################

2132 # Section: Debug Functions

2133

2134 0 0 0 sub _dbg383 { return unless $DebugLevel > 5;

2135 0 $LogReport.="CAS client: Verification successful.\n"; &store_log; }

2136

2137 ########################################################################

2138 # Section: End of code; Documentation

2139

2140 1;

2141

2142 __END__

File Coverage

$title

$title

New Registration

Email Confirmation

$title

CAS – Central Authentication

Login Required

Please note

CAS – Central Authentication

Login Required

Please note