our $debug = 0;

# session variables
our $session_data = {};
our ($uid, $password, $token, $session_code, $authenticated, $ou_allowed, $preauth);
our ($short_uid_type);  # descriptive, for messages
our $small_menu_width = "100%";
# big menu size defined in js at the moment
our ($msg_count) = 0;
our ($content_type) = "text/html";
our ($page, $previous_page);
our ($screenwidth, $screenheight);
our $close_window_on_logout = 0;

our $program_name = "the Intranet";

use Data::Dumper;
use IO::File;
use CGI ':standard';
#use CGI::Carp qw(fatalsToBrowser cluck);
use CGI::Carp qw(cluck);
use strict; use warnings;
use Digest::MD5 qw(md5_hex);
use Net::LDAP;
use Fcntl ':flock'; # import LOCK_* constants
use MIME::Base64;
use Compress::Zlib;
use Html::Entities;
use Lingua::EN::Numbers::Easy;
use Win32::ODBC;
use IO::String;
use Time::localtime;

our %N;
our $cgi_out = "";
our $db;
$preauth = 0;

sub set_program_name {
	($program_name) = @_;
}

sub set_close_window_on_logout {
#	$close_window_on_logout = 1;
}

sub d {
	dbg(Dumper @_);
}

sub dbg {
	print qq{<table width="1000"><tr><td align="left"><pre wrap>\n}.encode_entities(join("\n", @_)).qq{\n</pre></td></tr></table>\n};
}

sub dmp {
	if ($debug) {
		d(@_);
	}
}

sub debug {
	if ($debug) {
		dbg(@_);
	}
}

sub debug_ls {
    my %dir;
    use IO::Dir;
    tie %dir, 'IO::Dir', ".";
    foreach (keys %dir) {
        print $_, " " , $dir{$_}->size,"\n";
	nl();
    }
}

# TODO make this a package based on exporter instead
# especially as I can't access some exported functions from this, e.g. I need:

sub encode_entities {
	return HTML::Entities::encode_entities(@_);
}

$authenticated = 0;

# variables


our $script_name = $ENV{SCRIPT_NAME} || "";
our $program = $ENV{SCRIPT_NAME} || $0;
$program =~ s/.*\///;
$program =~ s/\..*$//;

our $common_conf = read_data("common.conf");
our ($ldap, $ldap_base_domain);

our $submit_i = qq{<input type="submit" value="submit">};
our $file_i = qq{<input name="file" type="file">};
our $password_i = qq{<input name="password" type="password">};

our @month = (undef, qw(January February March April May June July August September October November December));
our @weekday = (undef, qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday));

my $secret = "7em93jd%\@F*4hjf%78";

# subs

# this function escapes tabs to \t, newlines to \n, null to \0, \ to \\, and undef to null
sub escape_dump {
	my $v = shift;
	return "\0" unless defined $v;
	for ($v) {
		s/\\/\\\\/g;
		s/\t/\\t/g;
		s/\n/\\n/g;
		s/\0/\\0/g;
	}
	return $v;
}

sub unescape_dump {
	my $v = shift;
	return undef if $v eq "\0";
	for ($v) {
		s/(?:(?<=[^\\])|^)((?:\\\\)*)\\0/$1\0/g;
		s/(?:(?<=[^\\])|^)((?:\\\\)*)\\n/$1\n/g;
		s/(?:(?<=[^\\])|^)((?:\\\\)*)\\t/$1\t/g;
		s/\\\\/\\/g;
	}
	return $v;
}

sub read_tsv {
	my ($file, $missing_ok) = @_;
	my $text = slurp_text($file, $missing_ok);
	return tsv_to_table($text);
}

# maybe tsv_to_table, write_tsv read_data and write_data should all do tab / newline escaping?

sub tsv_to_table {
	my ($text) = @_;
	my @rows = map [split /\t| {2,}/, $_], grep /[^\n]/, split /\n/, $text;
	return \@rows;
}

sub trim {
	for (@_) {
		s/\s+/ /gs; # convert tabs, newlines, double spaces to spaces
		# kill any leading and trailing space
		s/^\s//s;
		s/\s$//s;
	}
}

sub write_tsv {
	my ($file, $data) = @_;
	my $text = "";
	for (@$data) {
		trim(@$_);
		$text .= join "\t", @$_;
		$text .= "\n";
	}
	belch($file, $text);
}

sub read_data {
	my ($file, $missing_ok) = @_;
	my $text = slurp_text($file, $missing_ok);
	return parse_data($text);
}

sub parse_data {
	my ($text) = @_;
	my @lines = split /\n/, $text;
	for (@lines) { s/^\s*#.*//; }
	@lines = grep /[^\n]/, @lines;

	my $data = {__order=>[]};
	my @stack;
	my ($k, $v);
	for my $line (@lines) {
		$_ = $line;
		s/^((  |\t)*)//;
		my $indent = length($1) / 2;
		if ($indent == @stack + 1 and
		  defined $k and !defined $data->{$k}) {
			push @stack, $data;
			$data->{$k} = {__order=>[]};
			$data = $data->{$k};
		} elsif ($indent < @stack) {
			while ($indent < @stack) {
				$data = pop @stack;
			}
		}
		if ($indent == @stack) {
			($k, $v) = split /\t| {2,}/, $_, -1;
			if (exists $data->{$k}) {
				die "duplicate key $k";
			}
			$data->{$k} = $v;
			push @{$data->{__order}}, $k;
		} else {
			die "bad syntax: $line\n";
		}
	}
	while (@stack) {
		$data = pop @stack;
	}
	return $data;
}

sub write_data {
	my ($file, $data) = @_;
	my $text = format_data($data);
	belch($file, $text);
}

# format_data accepts arrays, but parse data returns them as hashes with the original array in the __order member
# I could try doing this the other way, with arrays being primary, but I think not.

sub format_data {
	my ($data) = @_;
	my $is_ary = ref($data) =~ /ARRAY/;
#	d($data);
	my $text = "";
	my %keys = map {$_, 1} $is_ary ? @$data : keys %$data;
	my @keys;
	if (!$is_ary && exists $data->{__order}) {
		for ("__order", @{$data->{__order}}) {
			delete $keys{$_};
		}
		@keys = @{$data->{__order}};
	}
	push @keys, sort keys %keys;

	for my $k (@keys) {
		trim($k);
		my $v = $is_ary ? undef : $data->{$k};
		if (defined $v) {
			if (ref $v) {
				my $block = format_data($v);
				$text .= "$k\n";
				if ($block ne "") {
					$block =~ s/^/  /gm;
					$text .= $block;
				}
			} else {
				trim($v);
				my $spaces = 9 - ((length($k)+1) % 8);
				$text .= $k.(" " x $spaces).$v."\n";
			}
		} else {
			$text .= "$k\n";
		}
	}
#	d($text);
	return $text;
}

#			} elsif (ref $v =~ /ARRAY/) {
#				my $block = format_array($
#			} elsif (ref $v) {
#				die "format_data: can only handle scalars, arrays and hashes";

sub slurp {
	my ($file, $missing_ok) = @_;
	my $fh = $file;
	if (! ref $fh) {
		unless ($fh = IO::File->new($file, "r")) {
			$missing_ok and return '';
			die "can't open file `$file' to read: $!";
		}
	}
	binmode($fh);
	my $data = "";
	1 while read $fh, $data, 65536, length($data);
	close $fh;
	return $data;
}

sub slurp_text {
	my ($file, $missing_ok) = @_;
	my $text = slurp($file, $missing_ok);
	$text =~ tr/\r//d;
	return $text;
}

sub belch {
	my ($file, $data) = @_;
	my $fh = $file;
	if (! ref $fh) {
		$fh = IO::File->new($file, "w") ||
			die "can't open file `$file' to write: $!";
	}
	binmode($fh);
	print $fh $data or
		die "can't write to `$file': $!";
}

sub msgs_start {
	$msg_count = 0;
}
sub msgs_end {
	if ($msg_count) { nl(); }
}
sub msg {
	for (@_) { my $a = $_; $a = encode_entities($a); $a = nbspify($a); print $a; nl(); }
	$msg_count++;
}
sub redmsg {
	for (@_) { my $a = $_; $a = encode_entities($a); $a = nbspify($a); print qq{<i><font color="red" size="+1">$a</font></i>}; nl(); }
	$msg_count++;
}
sub smallredmsg {
	for (@_) { my $a = $_; $a = encode_entities($a); $a = nbspify($a); print qq{<font color="red">$a</font>}; nl(); }
	$msg_count++;
}

sub nbspify {
	my ($x) = @_;
	$x =~ s/ /&nbsp;/g;
	return $x;
}

sub nobrify {
	return "<nobr>$_[0]</nobr>";
}

sub nl {
	out("<br>\n");
}

use File::Glob ':glob';

unlink glob("CGItemp*");

sub stripbadchars {
	for (@_) {
		s,.*[:/\\],,;
		s,[^-0-9a-z _\.],,gis;
	}
}

sub hdr {
	return unless $content_type eq "text/html";
	my $args = {@_};

	my $title = $args->{title};
	my $body_bgcolor = $args->{bg_color};
	my $body_fgcolor = $args->{fg_color};
	my $body_link = $args->{link_color};
	my $initial_html = $args->{initial_html} || "";
	my $body_attrs = $args->{body_attrs} || "";
	my $left_margin = $args->{left_margin}; dflt($left_margin, 0);
	my $right_margin = $args->{right_margin}; dflt($right_margin, $left_margin);
	my $top_margin = $args->{top_margin}; dflt($top_margin, 0);
	my $bottom_margin = $args->{bottom_margin}; dflt($bottom_margin, $top_margin);

	if (defined $body_bgcolor) { $body_attrs .= qq{ bgcolor="$body_bgcolor"}; }
	if (defined $body_fgcolor) { $body_attrs .= qq{ text="$body_fgcolor"}; }
	if (defined $body_link) { $body_attrs .= qq{ link="$body_link" vlink="$body_link" alink="$body_link"}; }

	if (!param("embed")) {

###<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN"> this broke ScrollableTable.js !!
	print <<End;
<html>
<head>
<title> 
$title
</title> 
<link REL="STYLESHEET" HREF="/sam/common.css" TYPE="text/css">
<script LANGUAGE="JavaScript" TYPE="text/javascript" SRC="/sam/common.js"></script>
<script LANGUAGE="JavaScript" TYPE="text/javascript" SRC="/sam/ScrollableTable.js"></script>
</head>
<body style="margin-top: $top_margin; margin-left: $left_margin; margin-right: $right_margin; margin-bottom: $bottom_margin;" $body_attrs>

$initial_html

<h1>$title</h1>


End
	}
	print <<End;
<form action="$script_name" onsubmit="form_presubmit(this); return 1;" method="post" enctype="multipart/form-data">

End
}

sub ftr {
	my ($html_at_end) = @_;
	$html_at_end ||= "";
	return unless $content_type eq "text/html";
#	debug("authenticated: $authenticated");
#	if ($authenticated) {
#		token_field();
#		print hidden("uid", $uid);
#	}

	$page ||= "";  # FIXME redesign the page bogosity :)

	# output hidden "page" variable
	param("page", $page);
	out(hidden("page"));
	param("screenwidth", $screenwidth);
	out(hidden("screenwidth"));
	param("screenheight", $screenheight);
	out(hidden("screenheight"));

	print <<End;

</form>
End
	if (!param("embed")) {
		print <<End;

$html_at_end

</body>
</html>
End
	}

# <table id="maintable" width="770" cellpadding="10">
# <tr><td align="left">
# </td></tr>
# </table>

}

BEGIN {
	if ($ENV{GATEWAY_INTERFACE} and $ENV{GATEWAY_INTERFACE} =~ /CGI/) {
		open CGI_OUT, ">&STDOUT";
		close STDOUT;
		open STDOUT, '>', \$cgi_out;
		open STDERR, '>>', "bookings.log.txt" or die "can't open logfile";
		print STDERR "\nstart $ENV{SCRIPT_NAME}: ", ctime(), "\n";
	}
}

END {
	$ldap && ldap_close();
	$db && ($db->Close() or warn "could not close database connection");
	if ($ENV{GATEWAY_INTERFACE} && $ENV{GATEWAY_INTERFACE} =~ /CGI/) {
		if ($authenticated && !param("logout")) {
			token();
		} else {
			$token = "";
		}
		my $cookie = cookie(-name=>'token',
				     -value=>$token,
				     -expires=>$common_conf->{cookie_expires},
	#                            -path=>'/',
	#			     -domain=>$common_conf->{cookie_domain},
	#                             -secure=>1
				);

		print CGI_OUT header(-type => $content_type, -cookie => $cookie);
		print CGI_OUT $cgi_out;
	}
}

sub tbl_tsv {
	return tbl(tsv_to_table(join "\n", @_));
}

#sub tbl_tsv_old {
#	# FIXME
#	my $o;
#	$o .= "<table>";
#	for (split /\n/, join("\n", @_), -1) {
#		$o .= "<tr>";
#		for (split /\t/, $_, -1) {
#			$o .= qq{<td valign="top">$_</td>};
#		}
#		$o .= "</tr>";
#	}
#	$o .= "</table>";
#	return $o;
#}

sub tbl {
	my ($rows) = @_;
	my $o;
	$o .= "<table>";
	for (@$rows) {
		$o .= "<tr>";
		for (@$_) {
			$o .= qq{<td valign="top">$_</td>};
		}
		$o .= "</tr>";
	}
	$o .= "</table>";
	return $o;
}

sub Tbl {
	my $o;
	$o .= "<table>";
	while (@_) {
		my ($k, $v) = splice @_, 0, 2;
		$k .= ":" if $k ne "";
		$o .= "<tr>";
		$o .= qq{<td valign="top">$k</td>};
		$o .= qq{<td valign="top">$v</td>};
		$o .= "</tr>";
	}
	$o .= "</table>";
	return $o;
}

sub table_fill_rows_first {
	my ($n_columns, $values) = @_;
	my $n = @$values;
	my $n_rows = ($n + $n_columns-1) / $n_columns;
	my %data;
	for my $x (1..$n_columns) {
		for my $y (1..$n_rows) {
			$data{"$x,$y"} = shift @$values;
		}
	}
	my @rows;
	for my $y (1..$n_rows) {
		my $col = [];
		for my $x (1..$n_columns) {
			my $foo = $data{"$x,$y"};
			$foo = "" if !defined $foo; # FIXME
			push @$col, $foo;
		}
		push @rows, $col;
	}
}

sub table_fill_cols_first {
	my ($n_columns, $values) = @_;
	my $n = @$values;
	my $n_rows = ($n + $n_columns-1) / $n_columns;
	my %data;
	my @rows;
	for my $y (1..$n_rows) {
		my $col = [];
		for my $x (1..$n_columns) {
			my $foo = shift(@$values);
			$foo = "" if !defined $foo; # FIXME
			push @$col, $foo;
		}
		push @rows, $col;
	}
}

sub dropdown {
	# DODGY :)
	my $o = "";
	redirect_out(\$o, \&dropdown_, @_);
	return $o;
}
sub dropdown_ {
	my %opts = ref $_[0] ? %{shift @_} : ();
	my ($name, $ary) = @_;
	$ary = [@$ary];
#	my @attrs = $opts{attrs} ? ($opts{attrs}) : ();
	my @attrs = ();
	# FIXME this dropdown function should be nice

	if (delete $opts{autosubmit}) { push @attrs, onchange=>"this.form.submit();"; }
#	if (delete $opts{enter_submits}) { push @attrs, onKeyPress=>"enter_submits(this, event);"; }
# doesn't work!
	if (delete $opts{dynamic_expand}) {
		$opts{clip} = 1;
		push @attrs,
			onFocus=>"hover_select_focus(this);", onBlur=>"hover_select_blur(this)", onClick=>"hover_select_click(this)", onMouseover=>"hover_select_mouseover(this);", onMouseout=>"hover_select_mouseout(this)";
#			qq{onClick="alert('You are going too quick, take it easy!')" onMouseover="expand_select_delay(this,event);" onFocus="expand_select_focus(this,event);"};
			# see common.js
			# onMouseout="this.style.width='$small_menu_width';"}; }
			# this.style.width='';
	};
	if (delete $opts{clip}) { push @attrs, style=>"width: $small_menu_width; text-overflow: clip; overflow: hidden;"; }
	my $selected_option = delete $opts{selected};
	my $prompt = delete $opts{prompt} || "click to select...";
	my $no_prompt = delete $opts{no_prompt};
	my $abbrev = delete $opts{abbrev};

	# rest of opts are to add as html to the select, ok?  bogus, huh :)

	push @attrs, @{sort_hash(\%opts)};

	Tag("select", name=>$name, @attrs);

	out(qq{<option value="">$prompt</option>}) unless $no_prompt;

	while (@$ary) {
		my ($value, $label);
		if ($abbrev) { ($value, $label) = splice @$ary, 0, 2; }
		else { $value = shift @$ary; $label = $value; }
		my $selected = defined $selected_option && $value eq $selected_option ?
			" selected" : "";
		if ($label eq $value) {
			out(qq{<option$selected>$label</option>});
		} else {
			out(qq{<option value="$value"$selected>$label</option>});
		}
	}

	Ctag("select");
}


sub sort_hash {
	my ($hash) = @_;
	my @out;
	for (sort keys %$hash) {
		push @out, $_, $hash->{$_};
	}
	return \@out;
}

sub token {
	session_encode();
	debug("token (after session_encode)");
	dmp($session_data, $session_code);
	$uid or return ""; # die "no uid available, can't make token";
	my $salt = sprintf("%08x", rand()*1e9);
	$token = "$uid,".md5_hex($secret.$uid.$session_code.$salt).",$salt,$session_code";
	debug 'my $token = md5_hex($secret.$uid.$session_code.$salt).",$salt,$session_code";';
	debug qq{my $token = md5_hex($secret.$uid.$session_code.$salt).",$salt,$session_code";};
	debug("end");
	return $token;
}

sub check_token_ok {
	my $ok = _check_token_ok();
	$authenticated ||= $ok;
	debug("authenticated: $authenticated");
	return $ok;
}

sub _check_token_ok {
	debug("check_token_ok:");
	$token or return 0;
	my ($hash, $salt);
	($uid, $hash, $salt, $session_code) = split /,/, $token;
	debug q{($hash, $salt, $session_code) = split /,/, $token;};
	debug qq{($hash, $salt, $session_code) = split /,/, $token;};
	defined $session_code or return 0; 
	if ($hash eq md5_hex($secret.$uid,$session_code.$salt)) {
		debug(">> ok");
		session_decode();
		return 1;
	}
	debug ">> not ok!";
	return 0;
}

#sub token_field {
#	# don't use token_field, use cookies instead.
#	if ($authenticated && !param("logout")) {
#		token();
#		print qq{<input name="token" type="hidden" value="$token">};
#	}
#}

sub Gzip {
	return Compress::Zlib::memGzip($_[0]);
}

sub Gunzip {
	return Compress::Zlib::memGunzip($_[0]);
}

sub session_encode {
	$session_code = encode_base64(Gzip(format_data($session_data)));
	$session_code =~ s/=?\n//gs;
}

sub session_decode {
	defined $session_code or die "session_decode: \$session_code is not defined";
	$session_data = parse_data(Gunzip(decode_base64($session_code)));
	debug("session_decode:");
	dmp($session_data);
	debug("end");
}

sub yes {
	my ($tf) = @_;
	return $tf =~ /^(yes|y|1|true)$/i;
}

# will not return unless authenticated
sub auth {
	my $user = _auth();
	if (!$user) {
		my $message;
		if ($uid and $password) {
			$message = "login failed";
		}
		login_screen($message); # does not return
	}
	return $user;
}

sub _auth {
	my $token_ok = check_token_ok();
	$preauth ||= $token_ok;
	$uid = lc $uid;
	param("uid", $uid);
	my $user;

	# >>>
#	msg("uid: $uid");
#	msg("pass: $password");

#	my $rv = ldap_connect(); #$uid, $password);
#	my $rv = ldap_connect($uid, $password);

#	$preauth = 1;
#	msg("preauth: $preauth");
	# <<<

	unless ($preauth ? ldap_connect() : ldap_connect($uid, $password) and
		($user = ldap_lookup_user_by_uid($uid))) {
#		msg("ldap not ok!");
		ldap_close();
		return 0;
	}

	my $_ou = $ou_allowed;
	if (defined $_ou) {
		for (@{$user->{ous}}) {
			if (exists $_ou->{$_}) {
				$_ou = $_ou->{$_};
			} else {
# TO DEBUG OUS:
#				msg("not in group: ".Dumper($ou_allowed));
#				msg(">>@{$user->{ous}}<<");

				ldap_close(); return 0;
			}
		}
	}
#	sd_set("user is admin", grep(/^administrators$/i, @{$user->{ous}}) || $uid eq "ssw" || 0);
	$authenticated = $user && 1;
#	ldap_close();
	return $user;
}

sub ldap_connect {
	my %opts = ref $_[0] ? %{shift @_} : ();
	my ($uid, $password) = @_;
	if (!$uid) {
		$uid = $common_conf->{ldap_uid};
		$password = $common_conf->{ldap_pass};
	}
	if (!$uid || !$password) { return 0; }

	my $base_domain = $common_conf->{ldap_base_domain};
	$ldap_base_domain = join ",", map "dc=$_", split /\./, $base_domain;

	my $dn = $uid.'@'.$base_domain;
	my $ldap_server = $common_conf->{ldap_server};
	my $uid_field = $common_conf->{ldap_uid_field};

	$ldap = Net::LDAP->new($ldap_server, version => 3)
		or die "Unable to connect to LDAP server $ldap_server\n";
	my $mesg = $ldap->bind(dn => $dn, password => $password);
	$mesg->code and debug($mesg->error);
	$mesg->code and return 0;

	# do a search to check that the bind worked
	$mesg = $ldap->search(base => "$ldap_base_domain", filter => "$uid_field=$uid");
	if ($mesg->code) {
		debug($mesg->error);
		return 0;
	}
	if ($mesg->count != 1) {
		debug("search for user $uid returned ".$mesg->count." matches");
		return 0;
	}

	my ($user) = $mesg->entries;

	debug($user->get_value("dn"));

#	if (!$opts{keep_ldap_open}) { ldap_close() }

	return $user;
}

sub ldap_lookup {
	my ($domain, $filter, $attrs) = @_;
	$ldap or die "must auth first";

	my $base_domain = $common_conf->{ldap_base_domain};
	$ldap_base_domain = join ",", map "dc=$_", split /\./, $base_domain;
	$domain = "$domain,$ldap_base_domain";

	# do the search
	my $uid_field = $common_conf->{ldap_uid_field};
	#my $mesg = $ldap->search(base => $domain, filter => "$uid_field=$uid");
	my $mesg = $ldap->search(base => $domain, filter => $filter || "objectclass=person", $attrs ? (attrs=>$attrs) : ());

	if ($mesg->code) {
		my $dump_attrs = Dumper($attrs);
		die <<End."\n\n".$mesg->error;
ldap_lookup
domain: $domain
filter: $filter
attrs: $dump_attrs
uid_field: $uid_field
uid: $uid
End
#		die "ldap_lookup returned ".$mesg->error;
	}

	my @users = $mesg->entries;

	for (@users) {
		$_ = ldap_user_to_hash($_);
	}

	return \@users;
}

sub ldap_close {
	$ldap && $ldap->unbind;
	undef $ldap;
}

sub ldap_lookup_user_by_uid {
	my ($uid) = @_;
	my $uid_field = $common_conf->{ldap_uid_field};
	my $mesg = $ldap->search(base => "$ldap_base_domain", filter => "$uid_field=$uid");
	if ($mesg->code) {
		debug($mesg->error);
		return 0;
	}
	if ($mesg->count != 1) {
		debug("search for user $uid returned ".$mesg->count." matches");
		return 0;
	}

	my ($entry) = $mesg->entries;

	my $user = ldap_user_to_hash($entry);
	return $user;
}

sub ldap_user_to_hash {
	my ($user) = @_;

	$user = ldap_entry_to_hash($user);

	$user->{uid} = lc $user->{$common_conf->{ldap_uid_field}};

	my $dn = $user->{dn};
	my @ou;
	while ($dn =~ /ou=(.*?)(?:,|$)/gi) {
		unshift @ou, lc $1;
	}
	$user->{ous} = [@ou];

	$user->{is_student} = (grep /^students$/i, @{$user->{ous}}) && 1;
	$user->{is_staff} = (grep /^staff$/i, @{$user->{ous}}) && 1;
	$user->{is_admin} = ((grep /^administrators$/i, @{$user->{ous}}) || $user->{uid} eq "ssw" || $user->{uid} eq "administrator") && 1;
	$user->{is_library} = ((grep /^library$/i, @{$user->{ous}})) && 1;

	$user->{short_uid} = _short_uid($user);

	return $user;
}

sub ldap_entry_to_hash {
	my ($entry) = @_;
	my %hash;
	for my $attr ($entry->attributes) {
		$hash{$attr} = $entry->get_value($attr);
	}
	$hash{__entry} = $entry;
	$hash{dn} = $entry->dn;
	return \%hash;
}

sub ldap_set {
	my ($user, @attr_value_pairs) = @_;
	my $entry = $user->{__entry};
	$entry->replace(@attr_value_pairs);
	my $mesg = $entry->update($ldap);
	if ($mesg->code) {
		dbg( $mesg->error );
		ftr();
		exit;
	}
}

sub ldap_set_fullname {
	my ($user, $name1, $name2) = @_;
	ldap_set($user, sn=>$name2, givenName=>$name1);
}

sub ldap_set_initials {
	my ($user, $initials) = @_;
	ldap_set($user, initials=>$initials);
}

sub ldap_dump {
	my ($user_or_whatever) = @_;  # use this _after_ ldap_entry_to_hash
	for my $k (sort keys %$user_or_whatever) {
		print "$k\t$user_or_whatever->{$k}\n";
	}
}

sub title_case {
	my ($name) = @_;
	for ($name) {
		tr/A-Z/a-z/;
		s/(^|\s)(.)/$1.uc($2)/eg;
	}
	return $name;
}

sub ldap_get_name {
	my ($user) = @_;
	my ($name1, $name2) = ($user->{givenName}, $user->{sn});
	unless ($name1 and $name2) {
		if ($user->{displayName} && $user->{displayName} =~ / /) {
			if ($common_conf->{ldap_display_name_givenname_first}) {
				($name1, $name2) = split / /, $user->{displayName}, 2;
			} else {
				($name2, $name1) = split / /, $user->{displayName}, 2;
			}
		}
	}
	if (defined $name2 && $name2 !~ /[a-z]/) { $name2 = title_case($name2); }
	return ($name1, $name2);
}

sub ldap_get_fullname {
	my ($user, $how) = @_;
	$how ||= "";
	my ($name1, $name2) = ldap_get_name($user);
	$name2 = uc($name2) if $common_conf->{surname_uppercase};
	my $fullname = "";
	if ($name1 and $name2) {
		if ($how =~ /\buc_2ndname\b/) { $name2 = uc $name2 }
		if ($how =~ /\breverse\b/) {
			if ($how =~ /\bcomma\b/) { $fullname = "$name2, $name1"; }
			else { $fullname = "$name2 $name1"; }
		} else {
			$fullname = "$name1 $name2";
		}
	}
}

sub ldap_name_attrs {
	my ($user) = @_;
	($user->{name1}, $user->{name2}) = ldap_get_name($user);
}

sub conf_ary {
	my ($conf, $ary_name) = @_;
	my @ary;
	my $i = 1;
	while(1) {
		my $item = $conf->{"$ary_name.$i"};
		last unless defined $item;
		push @ary, $item;
		++$i;
	}
	return \@ary;
}

sub conf_set {
	my ($conf, $set_name) = @_;
	return { map {$_,1} @{conf_ary(@_)} };
}

sub conf_set_lc {
	my ($conf, $set_name) = @_;
	return { map {lc($_),1} @{conf_ary(@_)} };
}

sub get_lock {
	my ($lockfile) = @_;
	my $lockfh;
	$lockfh = IO::File->new($lockfile, "w") or
		die "can't open lockfile $lockfile: $!";
	my $ok = 0;
	for (1..10) {
		if (flock($lockfh, LOCK_EX|LOCK_NB)) { $ok = 1; last; }
		sleep 1;
	}
	$ok or die "cannot get lock for exclusive database access - please try to reload (refresh) this page.";
	return [$lockfile, $lockfh];
}

sub unlock {
	my ($lock) = @_;
	my ($lockfile, $lockfh) = @$lock;
        flock($lockfh, LOCK_UN);
	close $lockfh;
#	unlink $lockfile;
}

sub space {
	my ($count) = @_;
	$count ||= 1;
	out("&nbsp;" x $count);
}

sub load_session {
	$preauth = 0;
	if (param("logout")) {
		# fall through to the login screen
	} else {
		if (!defined $uid && !defined param("uid")) {
#			$token = param("token");
			$token = cookie("token");
		}
		if (!check_token_ok()) {
			if (defined $uid) {
				# fixed uid (e.g. admin)
			} elsif (defined param("uid")) {
				$uid = param("uid");
			} elsif (exists $ENV{AUTH_USER}) {
				($uid = $ENV{AUTH_USER}) =~ s/^.*\\//;
				$preauth = 1;
			}
			$uid =~ tr/A-Z/a-z/;
		}
		$password = param("password") if defined param("password");
	}
	$uid ||= "";

	# screen width, height
	$screenwidth = param("screenwidth") || sd("screenwidth") || 800;
	$screenheight = param("screenheight") || sd("screenheight") || 600;
	sd_set("screenwidth", $screenwidth);
	sd_set("screenheight", $screenheight);
}

sub get_uid_pass {
	out(tbl_tsv(<<End));
Login:	<input name="uid" type="text" value="$uid">
Password:	$password_i
	<input type="submit" value="submit">
End
#	<input type="submit" value="submit" onClick="form_submit_ensure_clean_window(); return 1;">
###	<input type="submit" value="submit" onClick="form_submit_open_in_new_window('width=800,height=600,resizable=1,scrollbars=1')">
}

sub sd {
	my ($key, $default) = @_;
	return exists $session_data->{$key} ? $session_data->{$key} : $default;
}

sub sd_set {
	my ($key, $value) = @_;
	return $session_data->{$key} = $value;
}

sub sd_delete {
	my ($key) = @_;
	delete $session_data->{$key};
}

sub sd_exists {
	my ($key) = @_;
	return exists $session_data->{$key};
}

sub buttons {
	return join("&nbsp;"x2, map {submit($_, $_)} @_);
}

sub split_html {
	my ($html) = @_;
	for ($html) {
		s/</\n</g;
		s/>/>\n/g;
		s/\n\n/\n/gs;
	}
	return $html;
}

sub Div {
	my ($a, $b) = @_;
	if ($a >= 0) { return int($a / $b); }
	if ($a < 0) { return int(($a-($b-1)) / $b); }
	# TODO generalize to work with b < 0 ?
}

sub Th {
	my ($n) = @_;
	return $n._th($n);
}

sub _th {
	my ($n) = @_;
	if ($n =~ /1[123]$/) { return "th"; }
	if ($n =~ /1$/) { return "st"; }
	if ($n =~ /2$/) { return "nd"; }
	if ($n =~ /3$/) { return "rd"; }
	return "th";
}

sub left_mid_right {
	my ($l, $m, $r) = @_;
	qq{<table width="100%"><tr><td align="left" valign="top">$l</td><td align="center" valign="top">$m<td align="right" valign="top">$r</td></tr></table>};
}

sub left_right {
	my ($l, $r) = @_;
	qq{<table width="100%"><tr><td align="left" valign="top">$l</td><td align="right" valign="top">$r</td></tr></table>};
}

sub left_mid {
	my ($l, $m) = @_;
	return left_mid_right($l, $m, "");
}

sub mid_right {
	my ($m, $r) = @_;
	return left_mid_right("", $m, $r);
}

sub index_to_table {
	my ($index) = @_;
	my $rows = [];
	my $row = [];
	my $i = $index;
	index_to_table_1($i, $row, $rows);
	return $rows;
}

sub index_to_table_1 {
	my ($i, $row, $rows) = @_;
	for my $k (sort keys %$i) {
		my $v = $i->{$k};
		if (ref $v) {
			push @$row, $k;
			index_to_table_1($v, $row, $rows);
			pop @$row;
		} else {
			push @$rows, [@$row, $k, $v];
		}
	}
}

sub table_to_index {
	my ($rows) = @_;
	my $index = {};
	for (@$rows) {
		my $row = [@$_];
		my $i = $index;
		my $last = pop @$row;
		my $last_but_one = pop @$row;
		for (@$row) {
			$i->{$_} ||= {};
			$i = $i->{$_};
		}
		$i->{$last_but_one} = $last;
	}
	return $index;
}

sub set {
	my ($ary) = @_;
	return { map {$_,1} @{$ary} };
}

sub uniq {
	my ($ary) = @_;
	return [keys %{set($ary)}]
}

sub dump_env {
	for my $k (sort keys %ENV) {
		print "$k - $ENV{$k}<br>\n";
	}
}

sub sql_item {
	return sql_row(@_);
}

sub sql_row {
	my ($sql) = @_;
	sql($sql);

	$db->FetchRow() or
		die "sql_row failed to fetch a row: $sql";
	
	return $db->Data();
}

sub sql_row_hash {
	my ($sql) = @_;
	sql($sql);

	$db->FetchRow() or
		die "sql_row failed to fetch a row: $sql";
	
	return $db->DataHash();
}

sub sql_col {
	my ($sql) = @_;
	sql($sql);

	my @col;

	while ($db->FetchRow()) {
		my ($val) = $db->Data();
		push @col, $val;
	}
	
	return \@col;
}

sub sql_rows {
	my ($sql) = @_;
	sql($sql);

	my @rows;

	while ($db->FetchRow()) {
		push @rows, [$db->Data()];
	}
	
	return \@rows;
}

sub sql_rows_hash {
	my ($sql) = @_;
	sql($sql);

	my @rows;

	while ($db->FetchRow()) {
		push @rows, {$db->DataHash()};
	}
	
	return \@rows;
}

sub sql {
	my ($stmt) = @_;
	$db->Sql($stmt) and
		die qq(SQL failed "$stmt": ), $db->Error(), qq(\n);
}

sub sql_connect {
	$db = Win32::ODBC->new($common_conf->{timetables_dsn}) or
		die "could not connect to database:".Win32::ODBC::Error();
}

# should use ldap_get_name with this, in case not everything is filled in
sub ldap_lookup_users_uid_name {
	my ($domain) = @_;
	my @fields = qw( sn givenName displayName );
	push @fields, $common_conf->{ldap_uid_field};
	push @fields, $common_conf->{ldap_short_uid_field} if $common_conf->{ldap_short_uid_field};
	return ldap_lookup($domain, "", \@fields);
}

# short_uid code...

# $user->{short_uid} is not necessarily the same as $user->{uid} (their login uid):
# - may be first 3 ($short_uid_max_length) chars of $user->{uid}, as at HHS
# - or e.g. $user->{initials} (if ldap_short_uid_field defined in common.conf), as at LHS
# - [[could also calculate from sn/givenName automatically??  but then good only for display, not for id?]]

$short_uid_type =
  $common_conf->{ldap_short_uid_field} ?   "$common_conf->{ldap_short_uid_field}" :
  "first $common_conf->{max_short_uid_length} chars";

sub _short_uid {
	my ($user) = @_;

	my $short_uid;
	my $ldap_short_uid_field = $common_conf->{ldap_short_uid_field};
	my $short_uid_max_length = $common_conf->{short_uid_max_length};
	if (defined $ldap_short_uid_field) {
		$short_uid = $user->{$ldap_short_uid_field};
	} else {
		my $long_uid = $user->{uid};
		if (length($long_uid) > $short_uid_max_length) {
			$short_uid = substr($long_uid, 0, $short_uid_max_length);
		} else {
			$short_uid = $long_uid;
		}
	}
	return lc $short_uid;
}

sub logout {
	my ($message) = @_;
	# log the user out and show login screen again
	# does not return
	param("logout", 1);
	undef $token;
	undef $authenticated;
	$uid = ""; #__admin__";
	load_session();
	login_screen($message);
	die "internal error - should not get here!";
}

sub login_screen {
	my ($message) = @_;
	hdr(title => "Login to $program_name");

	if ($message) { msg($message); }

	get_uid_pass();

	# in this case we want to preserve any QUERY_STRING and pass it on to the application
	# I wonder if this will work?  :>  too dodgy!
#	$cgi_out =~ s{(<form .*?action=".*?)"}{$1?$ENV{QUERY_STRING}"}i;
	for (qw(screenwidth screenheight)) {
#		if (param($_)) {
		out(hidden($_, param($_)||0));
#		}
	}

	if ($close_window_on_logout) {
		out(<<End);
<script type="text/javascript">
if (window.name == "calendar") {
	self.close();
}
</script>
End
	}

	ftr();
	exit();
}

sub popup {
	my ($popup_type, $html, $clicks_to, @anchors) = @_;
#	return qq{title='$html'} if $no_javascript;
	my $args = join(',', squot_str($html), squot_str($clicks_to||""), @anchors);
	return qq{onMouseover="$popup_type(this,event,$args)" onMouseout="delayhidemenu()"};
}

#sub showmenu {
#	return popup("showmenu", @_);
#}
#
#sub overlay_right {
#	return popup("overlay_right", @_);
#}
#
#sub overlay_left {
#	return popup("overlay_left", @_);
#}

sub with_popup {
	my ($html, $popup_html, $popup_type, $clicks_to, $span_id) = @_;
	$popup_type ||= "showmenu";
	my $popup_attrs = "";
	if ($popup_html ne "") {
		$popup_attrs = popup($popup_type, $popup_html, $clicks_to);
	}
	if ($span_id) {
		$popup_attrs = qq{id="$span_id" $popup_attrs};
	}
	return "<span $popup_attrs>$html</span>";
}

sub with_tooltip {
	my ($html, $tooltip_text) = @_;
	return qq{<span title="$tooltip_text">$html</span>};
}

#sub js_args {
#	my $args;
#	for (@_) {
#		push @$args, $_ =~ /[^0-9.]/ ? js_str($_) : $_;
#	}
#	return join ',', @$args;
#}

sub squot_str {
	my ($str) = @_;
	$str =~ s/'/\\'/g;  # more escaping needed?
	return "'$str'";
}

my @out_stack;

sub out {
	if (@out_stack == 0) { print @_; }
	else { ${$out_stack[-1]} .= join '', @_; }
}

sub redirect_out {
	my ($scalar_ref, $func, @args) = @_;
	$$scalar_ref = "";
	redirect_out_append(@_);
}
sub redirect_out_append {
	my ($scalar_ref, $func, @args) = @_;
	push @out_stack, $scalar_ref;
	&$func(@args);
	pop @out_stack;
}

# BROKEN:
#
#sub redirect_stdout {
#	my ($scalar_ref, $func, @args) = @_;
#	$$scalar_ref = "";
#	redirect_stdout_append($scalar_ref, $func, @args);
#}
#sub redirect_stdout_append {
##	print "hello world";
#	my ($scalar_ref, $func, @args) = @_;
#	open my $old_fh, ">&STDOUT" or die "can't dup stdout";
#	close STDOUT;
#	open STDOUT, '>', $scalar_ref or die "can't open stdout to a scalar";
#	&$func(@args);
#	close STDOUT;
#	open STDOUT, ">&", $old_fh or die "can't dup stdout back";
##	print "hello world 2";
#}

sub url_encode {  # TODO use a standard func?
	my $out = "";
	while (@_) {
		my ($k, $v) = (shift, shift);
		for ($k, $v) {
			s/([^a-z0-9_])/sprintf("%%%02x", ord($1))/iegms;
		}
		$out .= "&$k=$v";
	}
	$out =~ s/^.//;
	return $out;
}

sub dflt {
	if (!defined $_[0]) { $_[0] = $_[1]; }
}

sub tf {
	my ($name, $value, @rest) = @_;
	Tag("input", name=>$name, type=>"text", value=>$value, @rest);
}

sub but {
	my ($name, $value, @opts) = @_;
	$value = $name if !defined $value;
	Tag("input", name=>$name, type=>"submit", value=>$value,
		@opts
		);
}

sub jsbut {
	my ($label, $js, @rest) = @_;
	Tag("input", type=>"button", value=>"$label", onClick=>$js, @rest);
}

sub jslink {
	my ($label_html, $js, @rest) = @_;
	Tag("a", href=>"#", onClick=>"$js; return 0;", @rest);
	print $label_html;
	Ctag("a");
}

sub jsspan {
	my ($label_html, $js, @rest) = @_;
	Tag("span", onClick=>"$js;", @rest);
	print $label_html;
	Ctag("span");
}

sub jsimg {
	my ($src, $js, @rest) = @_;
	Tag("img", src=>$src, onClick=>"$js;", @rest);
}

sub opt {
	my ($key, $value) = @_;
	if (defined $value) { return ($key=>$value); }
	return ();
}

sub Tag {
	my $tag = shift;
	out("<$tag".attrs(@_).">");
}

sub Ctag {
	my ($tag) = @_;
	out("</$tag>");
}

sub attrs {
	my $out = "";
	my %vals;
	my @keys;
	while (my ($k, $v) = splice @_, 0, 2) {
		if (!exists $vals{$k}) {
			push @keys, $k;
			$vals{$k} = $v;
		} else {
			$vals{$k} .= $v;
		}
	}
	for my $k (@keys) {
		$out .= qq{ $k="$vals{$k}"};
	}
	return $out;
}

sub show_hide {
	my ($id, $expanded) = @_;
	my $expanded_name = "show_hide_x $id";  
	if (param($expanded_name)) { $expanded = param($expanded_name) }
	my $plus_minus = $expanded ? "[-]" : "[+]";
	jsspan($plus_minus, "show_hide('$id')", id=>"show_hide $id");
	out(hidden($expanded_name, $expanded));
	# this is dodgy because it outputs it right away, but that is ok for this app at least..
	return (id=>$id, style_display($expanded));
}

sub style_display {
	my ($inline) = @_;
	return Style(display($inline));
}

sub Style {
	return (style => css(@_));
}

sub display {
	my ($inline) = @_;
	$inline = $inline ? "inline" : "none";
	return (display=>$inline);
}

sub style_visible {
	my ($visible) = @_;
	return Style(visible($visible));
}

sub visible {
	my ($visible) = @_;
	$visible = $visible ? "visible" : "hidden";
	return (visibility=>$visible);
}

sub css {
	my $out = "";
	while (my ($k, $v) = splice @_, 0, 2) {
		$out .= "$k: $v; "
	}
	return $out;
}

sub select_on_focus {
	return (onFocus=>'select_all(this);');
}

sub jsconfirm {
	my ($msg) = @_;
	$msg = squot_str($msg);
	return (onClick => "return confirm($msg);");
}

sub jsconfirm2 {
	my ($msg, $msg2) = @_;
	$msg = squot_str($msg);
	$msg2 = squot_str($msg2);
	return (onClick => "return confirm($msg) && confirm($msg2);");
}

# these are for the `data' / tree file format used for configuration, e.g. bookings.conf

sub tree_rename {
	my ($tree, $old_name, $new_name) = @_;
	die "not a tree" if !$tree;
	if (exists $tree->{$new_name}) { return 0 };
	if (!exists $tree->{$old_name}) { return 0 };
	$tree->{$new_name} = delete $tree->{$old_name};
	my $c = 0;
	for (@{$tree->{__order}}) {
		if ($_ eq $old_name) {
			$_ = $new_name;
			$c++;
		}
	}
	if ($c != 1) { die "tree_rename: broken __order in tree! name: $old_name, count: $c"; }
	return 1;
}

sub tree_delete {
	my ($tree, $name) = @_;
	die "not a tree" if !$tree;
	if (!exists $tree->{$name}) { return 0 };
	delete $tree->{$name};
	$tree->{__order} = [grep {$_ ne $name} @{$tree->{__order}}];
	return 1;
}

sub tree_append {
	my ($tree, $name, $value) = @_;
	die "not a tree" if !$tree;
	if (exists $tree->{$name}) { return 0; }
	$tree->{$name} = $value;
	push @{$tree->{__order}}, $name;
	return 1;
}

sub tree_empty {
	return {__order => []};
}

sub is_tree_empty {
	my ($tree) = @_;
	return !$tree || !%$tree || ($tree->{__order} && @{$tree->{__order}} == 0 && @{[keys %$tree]} == 1);
}

sub backup {
	my ($filename) = @_;
	-e $filename and copy($filename, "$filename~") ||
		die "can't make backup file $filename~";
}

sub ou_allowed_tree_to_ldap_domains {
	my ($tree) = @_;
	my @domains;
	for my $ou (@{$tree->{__order}}) {
		my $sub_tree = $tree->{$ou};
		if ($sub_tree) {
			my $sub_domains = ou_allowed_tree_to_ldap_domains($sub_tree);
			for my $sub_dom (@$sub_domains) {
				push @domains, "$sub_dom,ou=$ou";
			}
		} else {
			push @domains, "ou=$ou";
		}
	}
	return \@domains;
}

sub uc_or_lc_id {
	my ($id) = @_;
	return defined $id && $common_conf->{display_id_caps} ? uc($id) : lc($id);
}

1