#!/usr/bin/perl -w
#
# Wcal 1.05 copyright by Samuli Krkkinen <skarkkai@woods.iki.fi>.
#
# Released under GNU General Public License (GPL).
#
# TAB size 4
#

require 5.003;
use Data::Dumper;
use Date::Manip;
use Socket;
use strict;
use Getopt::Std;
no strict 'refs';

#use Carp qw(cluck);

# These you can edit
$::CONF_FILE = '/etc/wcal.conf';
$::DIRECTORY = '/home/httpd/html/wcal';
$::REFRESH_DELAY = 900;					# view refreshed every 900 seconds = 15 minutes
$::PATH_BASENAME = 'wcal';				# last component of the wcal directory name

# Values below affect the proportions of the frames
$::FIRST_HOUR = 8;
$::LAST_HOUR = 16;
$::MANY_WEEKS_VERT = 2;
$::MANY_WEEKS_HOR = 7;

# Colors
$::THCOLOR = '#E2E3FC';
$::TDCOLOR = '#D9F4F4';
$::NOW_THCOLOR = '#CAFFD0';
$::NOW_TDCOLOR = '#CAFFD0';
#$::REPEAT_THCOLOR = '#F4F4A4';
#$::REPEAT_TDCOLOR = '#F4F4A4';
$::REPEAT_TEXTCOLOR = '#C02090';
#$::BG_THCOLOR = '#D9F4F4';
$::BG_TDCOLOR = '#F2F3FC';
$::ERROR_COLOR = '#e06060';
$::H_BODY = "<BODY BGCOLOR=\"#ffffff\" TEXT=\"#000000\" LINK=\"#0000b0\" VLINK=\"#0000b0\" ALINK=\"#0000b0\">\n";

# No need to touch these
$::MAX_DURATION = 21; # maximum duration of an event in days
$::CURRENT_DB_VERSION = 2;	# Wcal 1.00 had version 1 databases
$::HTTP_HEADER = "Content-Type: text/html\n\n";

# Query string decoder, ripped from CGI_Lite
sub decode_url_encoded_data ($) {
    my ($reference_data) = @_;
    my ($code, $self);

    $code = <<'End_of_URL_Decode';

    my (@key_value_pairs, $delimiter, $key_value, $key, $value);

    @key_value_pairs = ();

    return unless ($$reference_data);

    $delimiter = '&';

    $$reference_data =~ tr/+/ /;
    @key_value_pairs = split (/$delimiter/, $$reference_data);

    foreach $key_value (@key_value_pairs) {
	($key, $value) = split (/=/, $key_value, 2);

	$key   =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;
	$value =~ s/%([\da-fA-F]{2})/chr (hex ($1))/eg;

#	print Socket "'$key':'$value'\n";
	
	$self->{$key} = $value;
    }

End_of_URL_Decode

    eval ($code);
    return $self;
}

# And encoder, ripped too
sub url_encode
{
	my $string = shift;

	$string =~ s/([\x00-\x20"#%;<>?{}|\\\\^~`\[\]\x7F-\xFF])/
		sprintf ('%%%x', ord ($1))/eg;

	return $string;
}

sub strip_space ($) {
	my ($s) = @_;
	$s =~ s/^\s*(.*?)\s*$/$1/;
	return $s;
}

sub wday_to_dmwday ($) {
	my ($wday) = @_;

	if ($::FIRST_DAY eq 'monday') {
		return ($wday + 1);
	} else {
		if ($wday == 0) {
			return 7;
		} else {
			return $wday;
		}
	}
}

sub dmwday_to_wday ($) {
	my ($dmwday) = @_;

	return ($::FIRST_DAY eq 'monday' ?
				$dmwday - 1 :
				$dmwday % 7);
}

sub get_now () {
	if (! defined $::now_cache) {
		my (@n);
		@n = &UnixDate (&ParseDate ('now'), $::FIRST_DAY eq 'monday' ? "%G": "%Y", "%m", "%d", $::FIRST_DAY eq 'monday' ? "%W" : "%U", "%w");
		$::now_cache = {
			'year' => $n[0] + 0,
			'month' => $n[1] + 0,
			'day' => $n[2] + 0,
			'week' => $n[3] + 0,
			'wday' => dmwday_to_wday ($n[4]) };
	}
	return $::now_cache;
}

sub get_next_year_week ($$) {
	my ($year, $week) = @_;
	my ($cacheid);

	$cacheid = sprintf ("%04d%02d", $year, $week);
	if (! defined $::nyw_cache{$cacheid}) {
		my ($y, $w);
		($y, $w) = &UnixDate (&DateCalc ("$::FIRST_DAY week $week in $year", "+ 7 days"), $::FIRST_DAY eq 'monday' ? "%G": "%Y", $::FIRST_DAY eq 'monday' ? "%W" : "%U");
		$::nyw_cache{$cacheid} = [$y + 0, $w + 0];
	}
	return @{$::nyw_cache{$cacheid}};
}

sub get_prev_year_week ($$) {
	my ($year, $week) = @_;
	my ($cacheid);

	$cacheid = sprintf ("%04d%02d", $year, $week);
	if (! defined $::pyw_cache{$cacheid}) {
		my ($y, $w);
		($y, $w) = &UnixDate (&DateCalc ("$::FIRST_DAY week $week in $year", "- 7 days"), $::FIRST_DAY eq 'monday' ? "%G": "%Y", $::FIRST_DAY eq 'monday' ? "%W" : "%U");
		$::pyw_cache{$cacheid} = [$y + 0, $w + 0];
	}
	return @{$::pyw_cache{$cacheid}};
}

sub get_month_day_by_firstday_year_week ($$) {
	my ($year, $week) = @_;
	my ($cacheid);
	
	$cacheid = sprintf ("%04d%02d", $year, $week);
	if (! defined $::md_cache{$cacheid}) {
		my ($month, $day);
		($month, $day) = &UnixDate (&ParseDate ("$::FIRST_DAY week $week in $year"), "%m", "%d");
		$::md_cache{$cacheid} = [$month + 0, $day + 0];
	}
	return @{$::md_cache{$cacheid}};
}

sub get_month_day_by_wday_year_week ($$$) {
	my ($wday, $year, $week) = @_;
	my ($cacheid);
	
	$cacheid = sprintf ("%04d%02d%1d", $year, $week, $wday);
#	print STDERR "gmd: $cacheid (called by ", caller(), ")\n";
	if (! defined $::md2_cache{$cacheid}) {
		my ($month, $day);
		($month, $day) = &UnixDate (&ParseDate ($::weekdays[$wday] . " week $week in $year"), "%m", "%d");
		$::md2_cache{$cacheid} = [$month + 0, $day + 0];
	}
	return @{$::md2_cache{$cacheid}};
}

sub get_year_week_by_firstday_year_week_minus_days ($$$) {
	my ($year, $week, $days) = @_;
	my ($cacheid);
	
	$cacheid = sprintf ("%04d%02d%10d", $year, $week, $days);
	if (! defined $::yw_cache{$cacheid}) {
		my ($ryear, $rweek);
		($ryear, $rweek) = &UnixDate (&DateCalc ("$::FIRST_DAY week $week in $year", "- $days days"), $::FIRST_DAY eq 'monday' ? "%G": "%Y", $::FIRST_DAY eq 'monday' ? "%W" : "%U");
		$::yw_cache{$cacheid} = [$ryear + 0, $rweek + 0];
	}
	return @{$::yw_cache{$cacheid}};
}

sub week_wday_by_year_month_day ($$$) {
	my ($year, $month, $day) = @_;
	my ($cacheid);
	
	$cacheid = sprintf ("%04d%02d%2d", $year, $month, $day);
	if (! defined $::ww_cache{$cacheid}) {
		my ($week, $wday);
		($week, $wday) = &UnixDate (&ParseDate ("$month/$day/$year"), $::FIRST_DAY eq 'monday' ? "%W" : "%U", "%w");
		$::ww_cache{$cacheid} = [$week + 0, dmwday_to_wday ($wday)];
	}
	return @{$::ww_cache{$cacheid}};
}

sub get_start_end_by_year_week_wday_duration ($$$$) {
	my ($startyear, $startweek, $startwday, $duration) = @_;
	my ($cacheid);
	
	$cacheid = sprintf ("%04d%02d%2d%03d", $startyear, $startweek, $startwday, $duration);
	if (! defined $::se_cache{$cacheid}) {
		my ($startmonth, $startday, $endyear, $endweek, $endwday, $endmonth, $endday);

		($startmonth, $startday) =  get_month_day_by_wday_year_week ($startwday, $startyear, $startweek);

		($endyear, $endweek, $endwday) =
			&UnixDate (&DateCalc (&ParseDate (sprintf ("%04d-W%02d-%1d", $startyear, $startweek, wday_to_dmwday ($startwday))),
								  "+ " . ($duration - 1) . " days"),
					   $::FIRST_DAY eq 'monday' ? "%G": "%Y", $::FIRST_DAY eq 'monday' ? "%W" : "%U", "%w");
		$endwday = dmwday_to_wday ($endwday);

		($endmonth, $endday) =  get_month_day_by_wday_year_week ($endwday, $endyear, $endweek);

		$::se_cache{$cacheid} =
			[
			 $startmonth + 0, $startday + 0,
			 $endyear + 0, $endweek + 0, dmwday_to_wday ($endwday),
			 $endmonth + 0, $endday + 0
			];
	}
	return @{$::se_cache{$cacheid}};
}

sub get_year_week_wday_by_year_week_wday_plus_days ($$$$) {
	my ($year, $week, $wday, $days) = @_;
	my ($cacheid);
	
	$cacheid = sprintf ("%04d%02d%02d%10d", $year, $week, $wday, $days);
	if (! defined $::yww_cache{$cacheid}) {
		my ($nyear, $nweek, $nwday);
		($nyear, $nweek, $nwday) =
			&UnixDate (&DateCalc (sprintf ("%04d-W%02d-%1d", $year, $week, wday_to_dmwday ($wday)),
								  "+ $days days"),
					   $::FIRST_DAY eq 'monday' ? "%G": "%Y",
					   $::FIRST_DAY eq 'monday' ? "%W" : "%U",
					   "%w");
		$::yww_cache{$cacheid} = [$nyear + 0, $nweek + 0, dmwday_to_wday ($nwday)];
	}
	return @{$::yww_cache{$cacheid}};
}

sub fit_in_week ($$$$) {
	my ($year, $week, $wday, $duration) = @_;
	my ($endyear, $endweek, $endwday);

	($endyear, $endweek, $endwday) =
		get_year_week_wday_by_year_week_wday_plus_days
			($year, $week, $wday, $duration-1);
	if ($endyear != $year or $endweek != $week) {
		return 0;
	} else {
		return 1;
	}
}

sub fit_in_month ($$$$) {
	my ($year, $week, $wday, $duration) = @_;
	my ($month, $day);
	my ($endyear, $endweek, $endwday);
	my ($endmonth, $endday);

	($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);
	($endyear, $endweek, $endwday) =
		get_year_week_wday_by_year_week_wday_plus_days
			($year, $week, $wday, $duration-1);
	($endmonth, $endday) = get_month_day_by_wday_year_week ($endwday, $endyear, $endweek);
	if ($endyear != $year or $endmonth != $month) {
		return 0;
	} else {
		return 1;
	}
}

sub clipboard_set ($$) {
	my ($key, $data_ref) = @_;
	$::clipboard{$key} = $data_ref;
	return;
}

sub clipboard_get ($) {
	my ($key) = @_;
	if (defined $::clipboard{$key}) {
		return $::clipboard{$key};
	} else {
		return '';
	}
}

sub format_hour ($) {
	my ($hour) = @_;

	if ($::CLOCK eq '24-hour') {
		return ($hour + 0);
	} else {
		my ($newhour);
		
		$newhour = $hour;
		$newhour = 24 if $hour == 0;
		$newhour -= 12 if $hour > 12;
		return ($newhour + 0) . ($hour < 12 ? "am" : "pm");
	}
}

sub format_hour_padded ($) {
	my ($hour) = @_;

	if ($::CLOCK eq '24-hour') {
		return sprintf ("%02d", $hour);
	} else {
		my ($newhour);
		
		$newhour = $hour;
		$newhour = 24 if $hour == 0;
		$newhour -= 12 if $hour > 12;
		return sprintf ("%02d", $newhour) . ($hour < 12 ? "am" : "pm");
	}
}

sub format_time ($$) {
	my ($hour, $min) = @_;

	if ($::CLOCK eq '24-hour') {
		return ($hour + 0) . ":" . sprintf ("%02d", $min);
	} else {
		my ($newhour);
		
		$newhour = $hour;
		$newhour = 24 if $hour == 0;
		$newhour -= 12 if $hour > 12;
		return ($newhour + 0) . ":" . sprintf ("%02d", $min) . ($hour < 12 ? "am" : "pm");
	}
#	00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23
#	12 01 02 03 04 05 06 07 08 09 10 11 12 01 02 03 04 05 06 07 08 09 10 11
}

sub format_time_padded ($$) {
	my ($hour, $min) = @_;

	if ($::CLOCK eq '24-hour') {
		return sprintf ("%02d", $hour) . ":" . sprintf ("%02d", $min);
	} else {
		my ($newhour);
		
		$newhour = $hour;
		$newhour = 24 if $hour == 0;
		$newhour -= 12 if $hour > 12;
		return sprintf ("%02d", $newhour) . ":" . sprintf ("%02d", $min) . ($hour < 12 ? "am" : "pm");
	}
}
    
sub has_html ($) {
	my ($text) = @_;
	return $text =~ /[<>&]/;
}


sub newline_to_html ($) {
	my ($text) = @_;
	$text =~ s/\015\012/<BR>/sg;
	return $text;
}

sub html_to_newline ($) {
	my ($text) = @_;
	$text =~ s/<BR>/\015\012/sg;
	return $text;
}

sub events_version ($) {
	my ($events) = @_;
	my ($version);
	$version = $events->[0];
	if (ref $version) {
		$version = 1;
	}
	return $version;
}

sub convert_events_from_v1_to_v2 ($$$) {
	my ($events, $year, $week) = @_;
	my ($dayid, $eventhour, $eventid);
	for $dayid (0 .. $#$events) {
		for $eventhour (keys %{$events->[$dayid]}) {
			for $eventid (0 .. $#{$events->[$dayid]->{$eventhour}}) {
				my (@old_event, %new_event);
				@old_event = @{$events->[$dayid]->{$eventhour}->[$eventid]};
				%new_event = (
					'id' => $old_event[0],
					'min' => $old_event[1],
					'lengthmin' => $old_event[2],
					'title' => $old_event[3],
					'data' => $old_event[4],
					'rt' => $old_event[5],
					'startyear' => $year,
					'startweek' => $week,
					'startwday' => $dayid,
					'duration' => 1
				);
				$events->[$dayid]->{$eventhour}->[$eventid] = \%new_event;
			}
		}
	}
	# insert version number into beginning of the array
	unshift (@$events, $::CURRENT_DB_VERSION);
	return;
}

sub read_events ($;$$) {
	my ($rt, $year, $week) = @_;
	my ($filename, $now);

	if ($rt eq 'n') {
		$filename = sprintf "$::DB_DIR/w-${main::DATA_ID}-%04d%02d.db", $year, $week;
	} else {
		$filename = "$::DB_DIR/r$rt-${main::DATA_ID}.db";
	}
	
	if (open F, $filename) {
		my ($ref, $old_slash);
		$old_slash = $/;
		undef $/;
		$ref = eval (<F>);
		$/ = $old_slash;
		close F;
		# backwards compatibility
		if (events_version ($ref) < 2) {
			$now = get_now ();
			convert_events_from_v1_to_v2 ($ref, $year || $now->{'year'}, $week || $now->{'week'});
#			print STDERR Dumper ($ref);
		}
		shift @$ref;
		return $ref;
	} elsif ($rt eq 'n' or $rt eq 'w') {
		return [ {}, {}, {}, {}, {}, {}, {} ];
	} elsif ($rt eq 'm') {
		# let's give month 32 days to make sure
		return [ {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {}, {} ]
	}
	# can't happen
}


sub write_events ($$;$$) {
	my ($weekdata, $rt, $year, $week) = @_;
	my ($filename);

	if ($rt eq 'n') {
		if (! defined $year or ! $year or ! defined $week or ! $week) {
			return "The file type is no-repeat, but week or year not given, or zero.";
		}
		$filename = sprintf "$::DB_DIR/w-${main::DATA_ID}-%04d%02d.db", $year, $week;
		# Remove cached week file
		unlink sprintf ("$::DB_DIR/cache/w-${main::DATA_ID}-%04d%02d.html", $year, $week);
	} else {
		my (@files);
		$filename = "$::DB_DIR/r$rt-${main::DATA_ID}.db";
		# Remove all cached week files
		if (opendir (TDH, "$::DB_DIR/cache")) {
			@files = grep { /^w-${main::DATA_ID}-\d{6}\.html$/ } readdir (TDH);
			closedir TDH;
			for (@files) {
				unlink "$::DB_DIR/cache/$_";
			}
		}
	}

	# add the version identifier
	unshift (@$weekdata, $::CURRENT_DB_VERSION);

	if (open F, ">$filename") {
		$Data::Dumper::Terse = 1;
		flock (F, 2);
		print F Dumper ($weekdata);
		flock (F, 8);
		close F;
		return '';
	} else {
		return "File $filename can't be opened for writing: $!";
	}

	# and remove the version identifier again
	shift @$weekdata;
}

sub read_general () {
	my ($week) = @_;
	if (-f "$::DB_DIR/general.db" and ! -r "$::DB_DIR/general.db") {
		return "No write permission for file $::DB_DIR/general.db";
	}
	if (open F, "$::DB_DIR/general.db") {
		my ($ref, $old_slash);
		$old_slash = $/;
		undef $/;
		$ref = eval (<F>);
		$/ = $old_slash;
		close F;
		if ($@) {
			return "Error in processing file $::DB_DIR/general.db: $@";
		} else {
			return $ref;
		}
	} else {
		return { 'highid' => 56 };
	}
}

sub write_general ($) {
	my ($gendata) = @_;
	if (open F, ">$::DB_DIR/general.db") {
		$Data::Dumper::Terse = 1;
		flock (F, 2);
		print F Dumper ($gendata);
		flock (F, 8);
		close F;
		return '';
	} else {
		return "File $::DB_DIR/general.db can't be opened for writing: $!";
	}
}

# Print year, month and day in chosen date format
sub pd_year_month_day ($$$) {
	my ($year, $month, $day) = @_;
	my ($t);
	
	$t = $::DATE_FORMAT;
	if ($t == 1) {
		return "$day.$month.$year";
	} elsif ($t == 2) {
		return "$month/$day/$year";
	} elsif ($t == 3) {
		return "$day/$month/$year";
	} elsif ($t == 4) {
		return "$year/$month/$day";
	} elsif ($t == 5) {
		return "$year-$month-$day";
	} elsif ($t == 5) {
		return sprintf ("%04d%02d%02d", $year, $month, $day);
	} else {
		return "[DATE TYPE $t]";
	}
}

sub pd_month_day ($$) {
	my ($month, $day) = @_;
	my ($t);
	
	$t = $::DATE_FORMAT;
	if ($t == 1) {
		return "$day.$month";
	} elsif ($t == 2) {
		return "$month/$day";
	} elsif ($t == 3) {
		return "$day/$month";
	} elsif ($t == 4) {
		return "$month/$day";
	} elsif ($t == 5) {
		return "$month-$day";
	} elsif ($t == 6) {
		return sprintf ("%02d%02d", $month, $day);
	} else {
		return "[DATE TYPE $t]";
	}
}

sub pd_month_day_padded ($$) {
	my ($month, $day) = @_;
	my ($t);
	
	$t = $::DATE_FORMAT;
	if ($t == 1) {
		return sprintf "%02d.%02d", $day, $month;
	} elsif ($t == 2) {
		return sprintf "%02d/%02d", $month, $day;
	} elsif ($t == 3) {
		return sprintf "%02d/%02d", $day, $month;
	} elsif ($t == 4) {
		return sprintf "%02d/%02d", $month, $day;
	} elsif ($t == 5) {
		return sprintf "%02d-%02d", $month, $day;
	} elsif ($t == 6) {
		return sprintf "%02d%02d", $month, $day;
	} else {
		return "[DATE TYPE $t]";
	}
}

sub pd_single_event_date ($$$$) {
	my ($rt, $year, $week, $wday) = @_;
	my ($month, $day);
	
	($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);
	if ($rt eq 'n') {
		return pd_year_month_day ($year, $month, $day);
	} elsif ($rt eq 'w') {
		return $::weekdays[$wday];
	} else {
		return $day . ".";
	}
}

sub pd_event_date ($$$$$) {
	my ($rt, $startyear, $startweek, $startwday, $duration) = @_;
	my ($ret);
	
	$ret = '';
	$ret .= pd_single_event_date ($rt, $startyear, $startweek, $startwday);
	if ($duration > 1) {
		($startyear, $startweek, $startwday) =
			get_year_week_wday_by_year_week_wday_plus_days
				($startyear, $startweek, $startwday, $duration - 1);
		$ret .= " to " . pd_single_event_date ($rt, $startyear, $startweek, $startwday);
	}
	if ($rt eq 'w') {
		$ret .= " weekly";
	} elsif ($rt eq 'm') {
		$ret .= " monthly";
	}
	return $ret;
}

sub join_days (@) {
	my (@daylist) = @_;
	my (%sum_day, $day_ref, $hour, $event_ref);
	
	%sum_day = ();
	for $day_ref (@daylist) {
		for $hour (keys %$day_ref) {
			for $event_ref (@{$day_ref->{$hour}}) {
				push @{$sum_day{$hour}}, $event_ref;
			}
		}
	}
#	print STDERR Dumper (\%sum_day);
	return \%sum_day;
}

sub build_day ($$$$) {
	my ($year, $week, $wday, $day) = @_;
	my ($e_n, $e_rw, $e_rm, $sum_day_ref);

	$e_n = read_events ('n', $year, $week);
	$e_rw = read_events ('w');
	$e_rm = read_events ('m');
	
	$sum_day_ref = join_days ($e_n->[$wday], $e_rw->[$wday], $e_rm->[$day]);
	return $sum_day_ref;
}

sub build_week ($$) {
	my ($year, $week) = @_;
	my ($e_n, $e_rw, $e_rm, @sum_week, $wday);

	$e_n = read_events ('n', $year, $week);
	$e_rw = read_events ('w');
	$e_rm = read_events ('m');

	for $wday (0 .. 6) {
		my ($month, $day);
		($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);
		$sum_week[$wday] = join_days ($e_n->[$wday], $e_rw->[$wday], $e_rm->[$day]);
	}
	return \@sum_week;
}

sub build_week_list ($$) {
	my ($start_year, $start_week) = @_;
	my ($week_filename, @weeks, @ret, %weeks);
	my ($e_n, $e_rw, $e_rm, @sum_week);
	my ($cyear, $cweek, $cdate);
	my ($end_year, $end_week, $end_date);

	$e_rw = read_events ('w');
	$e_rm = read_events ('m');

	if (! opendir (DIR, $::DB_DIR)) {
		return "can't open $::DB_DIR for reading: $!";
	}	

	# gather all week filenames, 199805, 199806, 199807 ... 199851
	@weeks = map { /^w-${main::DATA_ID}-(\d{4}\d{2})\.db$/ && $1 }
				 grep { /^w-${main::DATA_ID}-(\d{4}\d{2})\.db$/ &&
						$1 >= sprintf ("%04d%02d", $start_year, $start_week) }
					  sort readdir(DIR);
	close DIR;

	# return immediately if no events
	if (scalar @weeks == 0) {
		return [];
	}

	# figure out the filename of the last week file
	$weeks[$#weeks] =~ /^(....)(..)$/;
	($end_year, $end_week) = ($1, $2);
	$end_date = sprintf ("%04d%02d", $end_year, $end_week);

	# generate an array of filenames between first and last week filename into %weeks
	$cyear = $start_year; $cweek = $start_week;
	$cdate = sprintf "%04d%02d", $cyear, $cweek;
	do {
		$weeks{$cdate} = $weeks[0] == $cdate ? shift @weeks : 0;
		($cyear, $cweek) = get_next_year_week ($cyear, $cweek);
		$cdate = sprintf "%04d%02d", $cyear, $cweek;
	} while ($cdate le $end_date);

	@ret = ();
	for $week_filename (sort keys %weeks) {
		my ($year, $week, @sum_week);

		$week_filename =~ /^(\d\d\d\d)(\d\d)/;
		($year, $week) = ($1, $2);

		# if $weeks{$week_filename} has true value, then there are week
		# events for that week - only in that case we will use the repeat events
		
		if ($weeks{$week_filename}) {
			my ($e_n, $wday);

			$e_n = read_events ('n', $year, $week);
			# Combine week files and repeat files
			@sum_week = ();
			for $wday (0 .. 6) {
				my ($day, $month);
				($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);
#				print STDERR "week $week_filename, day $wday: ";
				$sum_week[$wday] = join_days ($e_n->[$wday], $e_rw->[$wday], $e_rm->[$day]);
			}
		} else {
			@sum_week = ( {}, {}, {}, {}, {}, {}, {} );	# ignore repeat events too
		}

		push @ret, [\@sum_week, $year, $week];
	}
	return \@ret;
}

sub week_cache_read ($$) {
	my ($year, $week) = @_;
	my ($filename, $data, $old_slash);
	local (*CRFH);

	$filename = sprintf "$::DB_DIR/cache/w-%s-%04d%02d.html", ${main::DATA_ID}, $year, $week;
	if (! open (CRFH, $filename)) {
		return undef;
	}
	$old_slash = $/;
	undef $/;
	$data = <CRFH>;
	$/ = $old_slash;
	close CRFH;
	return \$data;
}

sub week_cache_write_open ($$) {
	my ($year, $week) = @_;
	my ($dirname, $filename, $cfh);
	$cfh = 'this_is_a_filehandle';
	
	$dirname = "$::DB_DIR/cache";
	$filename = sprintf "%s/w-%s-%04d%02d.html", $dirname, ${main::DATA_ID}, $year, $week;
	if (! -e $dirname) {
		if (! mkdir ($dirname, 0770)) {
			return \"can't create directory $dirname: $!";
		}
	}
	if (! open ($cfh, ">$filename")) {
		return \"can't open file $filename for writing: $!";
	}
	flock ($cfh, 2);
	return $cfh;
}

sub header_body ($) {
	return \"<BODY BGCOLOR=\"#ffffff\" TEXT=\"#000000\" LINK=\"#0000b0\" VLINK=\"#0000b0\" ALINK=\"#0000b0\">\n";
}

sub week_cache_write_close ($) {
	my ($fh) = @_;
	flock (F, 8);
	close $fh;
}

sub week_split_events_noon ($) {
	my ($events_ref) = @_;
	my ($e1, $e2, $day, $hour);

	for (@$events_ref) {
		for $day (0 .. 6) {
			my (%hours);
			%hours = %{$events_ref->[$day]};
			$e1->[$day] = {}; $e2->[$day] = {};
			if (%hours) {
				for $hour (keys %hours) {
#					print FH "<P>$hour\n";
					if ($hour < 12) {
						$e1->[$day]->{$hour} = $events_ref->[$day]->{$hour};
					} else {
						$e2->[$day]->{$hour} = $events_ref->[$day]->{$hour};
					}
				}
			}
		}
	}
	return ($e1, $e2);
}

sub week_print_events ($$$$$$) {
	my ($fh, $events_ref, $use_now_wday, $year, $week, $weekdays_ref) = @_;
	my ($day_offset, $day_ref, $hour, $event_ref);

#	print STDERR "week_prints_events: year $year, week $week\n";
#	print STDERR Dumper ($events_ref);

	$day_offset = 0;
	for $day_ref (@$events_ref) {
		my ($color);
#		if ($day_offset == $use_now_wday) {
#			$color = $::NOW_TDCOLOR;
#		} else {
			$color = $::TDCOLOR;
#		}
		if (%$day_ref) {
			print $fh "<TD BGCOLOR=\"$color\" VALIGN=top>\n";
			for $hour (sort { $a <=> $b } keys %$day_ref) {
				for $event_ref (@{$day_ref->{$hour}}) {
					my ($id, $min, $title, $data, $lengthmin, $rt, $color, $color_end);
					my ($startyear, $startweek, $startwday, $duration);
					$id = $event_ref->{'id'};
					$min = $event_ref->{'min'};
					$lengthmin = $event_ref->{'lengthmin'};
					$title = $event_ref->{'title'};
					$data = $event_ref->{'data'};
					$rt = $event_ref->{'rt'};
					$startyear = $event_ref->{'startyear'};
					$startweek = $event_ref->{'startweek'};
					$startwday = $event_ref->{'startwday'};
					$duration = $event_ref->{'duration'};

#					print Socket "<P>processing event: $event_ref (hour $hour)\n";

					if ($rt ne 'n') {
						$color = "<FONT COLOR=\"$::REPEAT_TEXTCOLOR\" SIZE=2>";
					} else {
						$color = '<FONT SIZE=2>';
					}
					$color_end = "</FONT>";

					print $fh "<A TARGET=fevent HREF=\"$::MY_URL_XUSER/?t=event",
					"&id=", $id,
					"&year=", $year, "&week=", $week, "&wday=", $day_offset,
					"&hour=", $hour,
					"&min=", $min,
					"&lengthmin=", $lengthmin,
					"&title=", url_encode ($title),
					"&data=", url_encode ($data),
					"&rt=", $rt,
					"&startyear=", $startyear,
					"&startweek=", $startweek,
					"&startwday=", $startwday,
					"&duration=", $duration,
					"\">$color<B>",
					format_time ($hour, $min),
#					$hour, ":", sprintf ("%02d", $min),
					" - ",
					format_time (int ($hour + ($min + $lengthmin)/60) % 24, ($min + $lengthmin) % 60),
#					int ($hour + ($min + $lengthmin)/60) % 24, ":", sprintf ("%02d", ($min + $lengthmin) % 60),
					"</B> ", $title, $color_end, "</A><BR>\n";
				}
			}
		} else {
			print $fh "<TD BGCOLOR=\"$color\"><FONT SIZE=2>&nbsp;</FONT>\n";
		}
		$day_offset++;
	}
	return;
}

# CGI input: year, week OR nothing, in which case current date is used
sub show_week (;$) {
	my ($cacheonly) = @_;
	my ($week, $month, $day, $year, $first_day);
	my ($weekdata, $i, @weekdays, $cached_week_ref, $cache_fh);
	my ($now_date, $now_year, $now_week, $now_wday, $use_now_wday);
	my ($events1, $events2, $wday_name, $now_ref);

	$year = $::query->{'year'};
	$week = $::query->{'week'};
	if (! defined $year or ! defined $week) {
		my ($ref);
		$ref = get_now ();
		($year,  $week) = ($ref->{'year'}, $ref->{'week'});
	}

	# If the week is in cache, return it
sw_check_cache:
	$cached_week_ref = week_cache_read ($year, $week);
	if (defined $cached_week_ref) {
		$$cached_week_ref =~ s/X_USER_X/${main::USER}/g;
		print Socket $$cached_week_ref;
		return;
	}

	# Find the current day to mark it in the output
	$now_ref = get_now ();
	($now_year, $now_week, $now_wday) = ($now_ref->{'year'}, $now_ref->{'week'}, $now_ref->{'wday'});

	if ($year == $now_year and $week == $now_week) {
		$use_now_wday = $now_wday + 0;
	} else {
		$use_now_wday = -1;
	}

	# Start writing the week into cache
	$cache_fh = week_cache_write_open ($year, $week);
	if (ref $cache_fh) {
		print Socket "<BODY>Internal error: $$cache_fh</BODY>\n";
		return;
	}

	# Build year/month/day information of the required week
	($month, $day) = get_month_day_by_firstday_year_week ($year, $week);
	$weekdays[0] = [$month, $day];
	for $i (1..6) {
		my ($month, $day);
		($month, $day) = get_month_day_by_wday_year_week ($i, $year, $week);
		$weekdays[$i] = [$month, $day];
	}

	print $cache_fh "<HEAD><META HTTP-EQUIV=refresh CONTENT=\"$::REFRESH_DELAY; url=$::MY_URL_XUSER/?t=week&year=$year&week=$week\"></HEAD>\n";
	print $cache_fh $::H_BODY;

	# Determine previous and next year & week
	my ($prev_week, $next_week, $prev_year, $next_year);
	$prev_week = $week - 1; $next_week = $week + 1;
	$prev_year = $next_year = $year;
	if ($prev_week < 2) {
		($prev_year, $prev_week )= get_prev_year_week ($year, $week);
	} elsif ($next_week > 50) {
		($next_year, $next_week )= get_next_year_week ($year, $week);
	}

	# Output title line
	print $cache_fh "<TABLE COLS=4 BORDER=0 WIDTH=\"100%\" ALIGN=center>\n";
	print $cache_fh "<TR><TH ALIGN=center>$::TOP_LEFT_CORNER</TH>\n";
	print $cache_fh "<TH COLSPAN=2 ALIGN=center><A TARGET=fweek HREF=\"$::MY_URL_XUSER/?t=week&year=$prev_year&week=$prev_week\"><IMG ALT=\"[next]\" SRC=\"$::BASE_URL/left-arrow.gif\" ALIGN=middle BORDER=0></A>\n";
	print $cache_fh " <A TARGET=fweek HREF=\"$::MY_URL_XUSER/?t=week&year=$now_year&week=$now_week\"><FONT SIZE=4><B>", $::months[$month], " week $week year $year</B></FONT></A> \n";
	print $cache_fh "<A TARGET=fweek HREF=\"$::MY_URL_XUSER/?t=week&year=$next_year&week=$next_week\"><IMG ALT=\"[prev]\" SRC=\"$::BASE_URL/right-arrow.gif\" ALIGN=middle BORDER=0></A></TH>\n";
	print $cache_fh "<TH ALIGN=center><A TARGET=fevent HREF=\"$::MY_URL_XUSER/?t=views&year=$year&week=$week\">[other views]</A></TH>\n";
	print $cache_fh "</TR></TABLE>\n\n";

	print $cache_fh "<TABLE COLS=7 BORDER=1 WIDTH=\"100%\">\n";
	print $cache_fh "<TR>\n";

	# Print weekday names
	$i = 0;
	for $wday_name (@main::weekdays_short) {
		my ($color);
		if ($i == $use_now_wday) {
			$color = $::NOW_THCOLOR;
		} else {
			$color = $::THCOLOR;
		}
		if ($i <= 4) {
			print $cache_fh "<TH BGCOLOR=\"$color\">";
		} else {
			print $cache_fh "<TH BGCOLOR=\"$color\">";
		}
		print $cache_fh "<A TARGET=fday HREF=\"$::MY_URL_XUSER/?t=day&year=", $year, "&week=", $week, "&wday=", $i, "\">", pd_month_day ($weekdays[$i]->[0], $weekdays[$i]->[1]), " ", $wday_name, "</A>\n";
		$i++;
	}

	$weekdata = build_week ($year, $week);
	($events1, $events2) = week_split_events_noon ($weekdata);

	print $cache_fh "<TR>\n";
	week_print_events ($cache_fh, $events1, $use_now_wday, $year, $week, \@weekdays);
	print $cache_fh "<TR>\n";
	week_print_events ($cache_fh, $events2, $use_now_wday, $year, $week, \@weekdays);

	print $cache_fh "</TABLE>\n</CENTER>\n</BODY>";

	week_cache_write_close ($cache_fh);

	# Now the cache should exist, so retry (someone may have removed it meanwhile, but then we just retry)
	goto sw_check_cache;
}

sub show_day () {
	my ($day, $month, $week, $year, $wday, $wday_name, $eventsdata, @hours, @thours, $day_ref, $rt);
	my ($now_ref, $now_thcolor, $is_now_day, $hour, $event_ref);
	
	# see if we are given the day or not - if year exists, assume yes
	$year = $::query->{'year'};
	if (! defined $year) {
		my ($now_ref);
		$now_ref = get_now ();
		($year, $month, $day, $week, $wday) =
			($now_ref->{'year'}, $now_ref->{'month'}, $now_ref->{'day'}, $now_ref->{'week'}, $now_ref->{'wday'});
	} else {
		$week = $::query->{'week'};
		$wday = $::query->{'wday'};
	}
	$wday_name = $::weekdays[$wday];

	($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);

	$day_ref = build_day ($year, $week, $wday, $day);
	
	# Build list of events on each hour
	@hours = ();
	for $hour (sort { $a <=> $b } keys %$day_ref) {
		for $event_ref (@{$day_ref->{$hour}}) {
			push @{$hours[$hour]}, $event_ref;
		}
	}

	# Count how many events will be on each row
	my ($max_c, $cols, @rows);
	$max_c = 0;
 	@rows = (0) x ($::LAST_HOUR + 1);
	for $hour ($::FIRST_HOUR .. $::LAST_HOUR) {
		if ($hours[$hour]) {
			for $event_ref (@{$hours[$hour]}) {
				my ($lengthmin, $min, $end_hour, $h);
				$lengthmin = $event_ref->{'lengthmin'};
				$min = $event_ref->{'min'};
				$end_hour = $hour + int (($lengthmin + $min - 1) / 60) % 24;
				for $h ($hour .. $end_hour) {
					my ($c);
					$c = ++$rows[$h];
					if ($c > $max_c) {
						$max_c = $c;
					}
				}
			}
		}
	}
	$max_c = 1 if $max_c == 0;
	$cols = $max_c + 1;

	$now_ref = get_now ();
	if ($now_ref->{'year'} == $year and $now_ref->{'month'} == $month and $now_ref->{'day'} == $day) {
		$is_now_day = 1;
	} else {
		$is_now_day = 0;
	}
	if ($is_now_day) {
		$now_thcolor = $::NOW_THCOLOR;
	} else {
		$now_thcolor = $::THCOLOR;
	}
	
	print Socket "<HEAD><META HTTP-EQUIV=refresh CONTENT=\"$::REFRESH_DELAY; url=$::MY_URL/?t=day&year=$year&week=$week&wday=$wday\"></HEAD>\n";
	print Socket "<BASE TARGET=fevent>\n";
	print Socket $::H_BODY;
	print Socket "<TABLE BORDER=2 CELLSPACING=0 WIDTH=\"90%\">\n";
	print Socket "<TR><TH WIDTH=10><TH COLSPAN=$max_c WIDTH=\"100%\" BGCOLOR=\"$::THCOLOR\">\n";
	print Socket "<TR><TD COLSPAN=$cols BGCOLOR=\"$now_thcolor\" ALIGN=center><FONT SIZE=3><B>", pd_year_month_day ($year, $month, $day), " $wday_name</B>\n";
	if (defined $::READ_ONLY and $::READ_ONLY ne 'true' and clipboard_get ($::remote_addr)) {
		print Socket "&nbsp;&nbsp;<A TARGET=_top HREF=\"$::MY_URL/?t=redraw&view=paste_event&year=$year&week=$week&wday=$wday&rt=$rt\">[Paste]</A>\n";
	}
	print Socket "</FONT></TD>\n";
	
	for $hour ($::FIRST_HOUR .. $::LAST_HOUR) {

		#
		# Print hour
		#
		print Socket "<TR><TD  BGCOLOR=\"$::THCOLOR\"><FONT SIZE=2>";
		if ($::READ_ONLY ne 'true') {
			print Socket "<A HREF=\"$::MY_URL/?t=add_edit",
				"&year=", $year, "&week=", $week, "&wday=", $wday, "&hour=", $hour, "\">";
		}
		print Socket format_hour_padded ($hour);
		if ($::READ_ONLY ne 'true') {
			print Socket "</A>\n";
		}

		#
		# Print events for this hour
		#
		if ($hours[$hour]) {
			my (@events, $event_ref);
			@events = @{$hours[$hour]};
			for $event_ref (@events) {
				my ($id, $min, $title, $data, $lengthmin, $rcolor, $rcolor_end);
				my ($startyear, $startweek, $startwday, $duration);
				$id = $event_ref->{'id'};
				$min = $event_ref->{'min'};
				$lengthmin = $event_ref->{'lengthmin'};
				$title = $event_ref->{'title'};
				$data = $event_ref->{'data'};
				$rt = $event_ref->{'rt'};
				$startyear = $event_ref->{'startyear'};
				$startweek = $event_ref->{'startweek'};
				$startwday = $event_ref->{'startwday'};
				$duration = $event_ref->{'duration'};
				
				if ($rt ne 'n') {
					$rcolor = "<FONT COLOR=\"$::REPEAT_TEXTCOLOR\">";
					$rcolor_end = "</FONT>";
				} else {
					$rcolor = $rcolor_end = '';
				}
				print Socket "<TD BGCOLOR=\"$::TDCOLOR\" ROWSPAN=", int (($lengthmin + $min + 59) / 60) % 24, "><FONT SIZE=2>",
				"<P><A HREF=\"$::MY_URL/?t=event&id=", $id,
				"&year=", $year, "&week=", $week, "&wday=", $wday,
				"&hour=", $hour, "&min=", $min,
				"&lengthmin=", $lengthmin,
				"&title=", url_encode ($title),
				"&data=", url_encode ($data),
				"&rt=", $rt,
				"&startyear=", $startyear,
				"&startweek=", $startweek,
				"&startwday=", $startwday,
				"&duration=", $duration,
				"\">", $rcolor, $title, $rcolor_end, "</A>\n";
			}
		}
#		if (! defined $rows[$hour]) { print Socket "<P>", $hour, "\n";};
		print Socket "<TD BGCOLOR=\"$::BG_TDCOLOR\">&nbsp;" x ($max_c - $rows[$hour]), "\n";
	}
sd_end:
	print Socket "</TABLE></CENTER>\n</BODY>\n";
}

sub show_event () {
	my ($year, $month, $day, $week, $wday, $wday_name, $weekdata, @hours, $day_ref, $rt);
	my ($hour, $min, $lengthmin, $title, $data, $endhour, $endmin, $id, $is_now, $now_thcolor, $rcolor);
	my ($startyear, $startweek, $startwday, $duration);
	
	$id = $::query->{'id'};
	$year = $::query->{'year'};
	$week = $::query->{'week'};
	$wday = $::query->{'wday'} || 0;
	$wday_name = $::weekdays[$wday];
	$hour = $::query->{'hour'} || 0;
	$min = $::query->{'min'} || 0;
	$lengthmin = $::query->{'lengthmin'} || 0;
	$title = $::query->{'title'};
	$data = $::query->{'data'};
	$rt = $::query->{'rt'};
	$is_now = $::query->{'is_now'};
	$startyear = $::query->{'startyear'};
	$startweek = $::query->{'startweek'};
	$startwday = $::query->{'startwday'};
	$duration = $::query->{'duration'};

	if (! defined $year or ! defined $title) {
		my ($n);
		$n = get_now ();
        show_other_views ($n->{'year'}, $n->{'week'});
		return;
	}

	($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);

	$endhour = int ($hour + ($min + $lengthmin) / 60) % 24;
	$endmin = int (($min + $lengthmin) % 60);

	print Socket $::H_BODY;
#	print Socket $::READ_ONLY;

	if ($is_now) {
		$now_thcolor = $::NOW_THCOLOR;
	} else {
		$now_thcolor = $::THCOLOR;
	}
	if ($rt ne 'n') {
		$rcolor = "COLOR=\"$::REPEAT_TEXTCOLOR\"";
	} else {
		$rcolor = '';
	}

	print Socket "<CENTER>\n<TABLE BORDER=1 COLS=1 CELLPADDING=10 ALIGN=center VALIGN=middle WIDTH=\"80%\" BGCOLOR=\"$::TDCOLOR\">\n";
	print Socket "<TR><TH ALIGN=center BGCOLOR=\"$now_thcolor\"><FONT SIZE=\"3\">Event at ", pd_event_date ($rt, $startyear, $startweek, $startwday, $duration), "</FONT>\n";
	print Socket "\n<TR><TD BGCOLOR=\"$::TDCOLOR\" ALIGN=left>\n";
	printf Socket "<P><CENTER><FONT SIZE=\"4\" $rcolor><B>%s - %s $title", format_time ($hour, $min), format_time ($endhour, $endmin);
	print Socket (($rt eq 'w') ? ' (week repeat)' : ( ( $rt eq 'm' ) ? ' (month repeat)' : '' ));
	print Socket "</B></FONT></CENTER>\n";
	print Socket "<P>$data\n";
	print Socket "</TABLE>\n";
	
	if ($::READ_ONLY ne 'true') {
		my ($enc_title, $enc_data);
		$enc_title = url_encode ($title);
		$enc_data = url_encode ($data);
		print Socket "<A HREF=\"$::MY_URL/?t=add_edit&id=$id&year=$year&week=$week&wday=$wday&hour=$hour&min=$min&lengthmin=$lengthmin&title=$enc_title&data=$enc_data&rt=$rt&startyear=$startyear&startweek=$startweek&startwday=$startwday&duration=$duration\">",
			"[Edit]</A>\n";
		print Socket "<A TARGET=\"_top\" HREF=\"$::MY_URL/?t=redraw&view=after_remove_event&id=$id&year=$year&week=$week&wday=$wday&hour=$hour&title=$enc_title&data=$enc_data&rt=$rt&min=$min&lengthmin=$lengthmin&startyear=$startyear&startweek=$startweek&startwday=$startwday&duration=$duration\">",
			"&nbsp;&nbsp;&nbsp;[Cut]</A>\n";
		print Socket "<A HREF=\"$::MY_URL/?t=copy_event&id=$id&year=$year&week=$week&wday=$wday&hour=$hour&min=$min&lengthmin=$lengthmin&title=$enc_title&data=$enc_data&rt=$rt&startyear=$startyear&startweek=$startweek&startwday=$startwday&duration=$duration\">",
			"&nbsp;&nbsp;&nbsp;[Copy]</A>\n";
	}
	print Socket "</CENTER></BODY>\n";
}

sub add_edit_event_ask () {
	my ($id, $year, $month, $day, $week, $wday, $wday_name, $weekdata, @hours, $day_ref);
	my ($hour, $min, $lengthmin, $title, $data, $endhour, $endmin, $rt, $duration);
	my ($startyear, $startweek, $startwday, $startmonth, $startday);
	my ($endyear, $endweek, $endwday, $endmonth, $endday);
	
	$id = $::query->{'id'} || '';
	$year = $::query->{'year'};
	$week = $::query->{'week'};
	$wday = $::query->{'wday'};
	$wday_name = $::weekdays[$wday];
	$hour = $::query->{'hour'};
	$min = $::query->{'min'} || 0;
	$lengthmin = $::query->{'lengthmin'};
	$rt = $::query->{'rt'} || 'n';
	$title = $::query->{'title'} || '';
	$data = $::query->{'data'} || '';
	$startyear = $::query->{'startyear'} || $year;
	$startweek = $::query->{'startweek'} || $week;
	$startwday = $::query->{'startwday'} || $wday;
	$duration = $::query->{'duration'} || 1;

	($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);

#	print STDERR "startyear: $startyear, $startweek, $startwday, duration: $duration\n";

	if ($id) {
		$endhour = int ($hour + ($min + $lengthmin) / 60) % 24;
		$endmin = int (($min + $lengthmin) % 60);
	} else {
		$endhour = $hour+1;
		$endmin = 0;
	}

	($startmonth, $startday, $endyear, $endweek, $endwday, $endmonth, $endday) =
		get_start_end_by_year_week_wday_duration ($startyear, $startweek, $startwday, $duration);

	print Socket $::H_BODY;
	print Socket "<CENTER>\n";
	print Socket "<TABLE BORDER=1 COLS=1 CELLPADDING=3 ALIGN=center WIDTH=\"100%\" BGCOLOR=\"$::TDCOLOR\">\n";
	print Socket "<TR><TH ALIGN=center BGCOLOR=\"$::THCOLOR\"><FONT SIZE=\"3\"><B>";
	if ($id) {
		print Socket 'Edit event ';
	} else {
		print Socket 'Add event ';
	}
	print Socket pd_event_date ($rt, $startyear, $startweek, $startwday, $duration);
	print Socket "</B></FONT></TH></TR>\n";
	print Socket "<TR><TD BGCOLOR=\"$::TDCOLOR\">\n";

	print Socket "<CENTER><TABLE BORDER=0 BGCOLOR=\"$::TDCOLOR\" CELLSPACING=0 CELLPADDING=0 WIDTH=470>\n\n";

	print Socket "<FORM TARGET=_top ACTION=\"$::MY_URL\" METHOD=GET>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=oldrt VALUE=$rt>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=oldhour VALUE=$hour>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=oldduration VALUE=$duration>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=year VALUE=$year>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=week VALUE=$week>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=wday VALUE=$wday>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=startyear VALUE=$startyear>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=startweek VALUE=$startweek>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=startwday VALUE=$startwday>\n";

	print Socket "<INPUT TYPE=HIDDEN NAME=t VALUE=redraw>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=view VALUE=add_event>\n";
	print Socket "<INPUT TYPE=HIDDEN NAME=id VALUE=$id>\n";

	# Event time
	print Socket "<TR><TD ALIGN=left>\n";
	print Socket "Time</TD><TD><SELECT NAME=hour1>\n";
	for (0 .. 23) {
		print Socket "<OPTION VALUE=$_ ", (($_ == $hour) ? 'SELECTED' : ''), ">", format_hour_padded ($_), "\n";
	}
	print Socket "</SELECT>\n";
	print Socket "<SELECT NAME=min1>\n";
	for (qw (00 15 30 45)) {
		print Socket "<OPTION VALUE=$_ ", (($_ == $min) ? 'SELECTED' : ''), ">$_\n";
	}
	print Socket "</SELECT>\n";
	print Socket " - \n";
	print Socket "<SELECT NAME=hour2>\n";
	for (0 .. 23) {
		print Socket "<OPTION VALUE=$_ ", (($_ == $endhour) ? 'SELECTED' : ''), ">", format_hour_padded ($_), "\n";
	}
	print Socket "</SELECT>\n";
	print Socket "<SELECT NAME=min2>\n";
	for (qw (00 15 30 45)) {
		print Socket "<OPTION VALUE=$_ ", (($_ == $endmin) ? 'SELECTED' : ''), ">$_\n";
	}
	print Socket "</SELECT>\n</TD></TR>\n";

	# Duration (days)
	print Socket "<TR><TD>Duration</TD><TD><SELECT NAME=duration>\n";
	for (1 .. $::MAX_DURATION) {
		print Socket "<OPTION VALUE=$_ ", (($_ == $duration) ? 'SELECTED' : ''), ">$_ ", ($_ == 1 ? "day" : "days"), "\n";
	}
	print Socket "</SELECT>\n";

	# Repeat
	my ($sn, $sw, $sm);
	$sn = $sw = $sm = '';
	if ($rt eq 'n') {
		$sn = 'SELECTED';
	} elsif ($rt eq 'w') {
		$sw = 'SELECTED';
	} elsif ($rt eq 'm') {
		$sm = 'SELECTED';
	}
	print Socket "<SELECT NAME=rt>";
	print Socket "<OPTION VALUE=n $sn>No repeat";
	print Socket "<OPTION VALUE=w $sw>Repeat every week";
	print Socket "<OPTION VALUE=m $sm>Repeat every month";
	print Socket "</SELECT>\n</TD></TR>\n";
	
	# Title
	print Socket "<TR><TD ALIGN=left>Title</TD><TD>";
	print Socket "<INPUT SIZE=51 NAME=title VALUE=\"", html_to_newline ($title), "\"></TD></TR>";

	# Data
	print Socket "<TR><TD ALIGN=left COLSPAN=2><TEXTAREA ROWS=", ($::SCREEN_RESOLUTION eq '800x600' ? 2 : 4) ," COLS=58 NAME=\"data\">", html_to_newline ($data), "</TEXTAREA></TD></TR>";
	print Socket "</TABLE>\n";

	# Submit
	my ($submit_value);
	$submit_value = ($id ? 'Edit' : 'Add');
	print Socket "<INPUT TYPE=submit VALUE=\"$submit_value\">\n";
	print Socket "</FORM></CENTER>\n";

	print Socket "</TABLE>\n";

	print Socket "</FORM></CENTER>\n";
	print Socket "</BODY>\n";
	
}

sub print_event_error_start () {
	print Socket $::H_BODY;
	print Socket "<DIV ALIGN=center VALIGN=middle>\n";
	print Socket "<TABLE BORDER=1 CELLPADDING=10 ALIGN=center VALIGN=middle BGCOLOR=\"$::TDCOLOR\" WIDTH=\"80%\">\n<TR><TD><BR><BR>\n\n";
}

sub print_event_error_end () {
	print Socket "<BR><BR></TABLE>\n</BODY>\n";
}

sub day_index ($$$$) {
	my ($rt, $year, $week, $wday) = @_;
	my ($index);
	
	# Index by day or wday, depending on repeat type
	if ($rt eq 'n' or $rt eq 'w') {
		$index = $wday + 0;
	} else {
		my ($month, $day);
		($month, $day) = get_month_day_by_wday_year_week ($wday, $year, $week);
		$index = $day + 0;
	}

#	print STDERR "day_index: $rt, $year, $week, $wday: $index\n";
	return $index;
}

# Read, update, and write new highest event id into general database
# Return the (id, possible error or false)
sub next_id () {
	my ($id, $gendata, $err);

	$gendata = read_general ();
	if (! ref $gendata eq 'HASH') {
		$err = $gendata;
			return ('', $err);
	}

	$id = $gendata->{'highid'} + 1;
	$gendata->{'highid'} = $id;

	$err = write_general ($gendata);
	if ($err) {
		return ('', $err);
	}
	return ($id, '');
}

sub remove_events ($$$$$$$) {
	my ($rt, $year, $week, $wday, $duration, $hour, $id) = @_;
	my ($i);

	for $i (0 .. $duration - 1) {
		my ($cyear, $cweek, $cwday, $index_day, $hour_ref, $eventsdata, @hour, $err);

		($cyear, $cweek, $cwday) = get_year_week_wday_by_year_week_wday_plus_days ($year, $week, $wday, $i);

		$index_day = day_index ($rt, $cyear, $cweek, $cwday);

#		print STDERR "index_day: $index_day\n";
		
		$eventsdata = read_events ($rt, $cyear, $cweek);
		$hour_ref = $eventsdata->[$index_day]->{$hour};
#		print STDERR "found event:";
#		print STDERR Dumper ($hour_ref);
		if (ref $hour_ref eq 'ARRAY') {
			my ($i);
			@hour = @$hour_ref;
			for $i (0 .. $#hour) {
				if ($hour[$i]->{'id'} == $id) {
					splice (@hour, $i, 1);
					goto re_found;
				}
			}
		}
		return "internal error: the event isn't in the database (user ${main::DATA_ID}, year $cyear, week $cweek, wday $cwday, id $id, rt $rt)";
		
re_found:
		if (@hour) {
			$eventsdata->[$index_day]->{$hour+0} = \@hour;
		} else {
			# no events left for this hour, so remove whole hour
			delete $eventsdata->[$index_day]->{$hour};
		}
		$err = write_events ($eventsdata, $rt, $cyear, $cweek);
		if ($err) {
			return  $err;
		}
#		print STDERR "Removed event $rt, $cyear, $cweek, $index_day, $hour:\n";
	}
	return '';
}

sub add_events ($$$$$$$$$$$) {
	my ($rt, $year, $week, $wday, $duration, $hour, $id, $min, $lengthmin, $title, $data) = @_;
	my ($i, $err);

	# Figure out the new $id
	if (! $id) {
		my ($gendata);

		# Read, update, and write new highest event id into general database
		$gendata = read_general ();
		if (! ref $gendata eq 'HASH') {
			$err = $gendata;
			return $err;
		}
		$id = $gendata->{'highid'} + 1;
		$gendata->{'highid'} = $id;
		$err = write_general ($gendata);
		if ($err) {
			return $err;
		}
	}

	
	for $i (0 .. $duration - 1) {
		my ($cyear, $cweek, $cwday, $index_day, $eventsdata);

#		print STDERR "add_events: $year, $week, $wday, $i\n";

		($cyear, $cweek, $cwday) = get_year_week_wday_by_year_week_wday_plus_days ($year, $week, $wday, $i);

#		print STDERR "add_events: $cyear, $cweek, $cwday\n";

		$index_day = day_index ($rt, $cyear, $cweek, $cwday);

		# Read events, add, write back
		$eventsdata = read_events ($rt, $cyear, $cweek);
		push @{$eventsdata->[$index_day]->{$hour+0}},
			{
				'id' => $id + 0,
				'min' => $min + 0,
				'lengthmin' => $lengthmin + 0,
				'title' => $title,
				'data' => $data,
				'rt' => $rt,
				'startyear' => $year + 0,
				'startweek' => $week + 0,
				'startwday' => $wday + 0,
				'duration' => $duration + 0,
			};
                                                                                                	
		$err = write_events ($eventsdata, $rt, $cyear, $cweek);
		if ($err) {
			return $err;
		}
			
#		print STDERR "Wrote event $rt, $cyear, $cweek, $index_day, $hour, id: $id:\n";
#		print STDERR Dumper ($eventsdata->[$index_day]->{$hour1+0});
	}
	return '';
}

sub add_event_commit () {
	my ($id, $year, $month, $day, $week, $wday, $wday_name, $rt);
	my ($hour1, $min1, $hour2, $min2, $lengthmin, $title, $data, $endhour, $endmin);
	my ($err, $i);
	my ($oldrt, $oldhour);
	my ($oldhour_ref, @hour, $oldduration, $duration);
	my ($startyear, $startweek, $startwday, $startmonth, $startday);

	$oldrt = $::query->{'oldrt'};
	$oldhour = $::query->{'oldhour'};
	$oldduration = $::query->{'oldduration'};

	$id = $::query->{'id'} || '';
	$year = $::query->{'year'};
	$week = $::query->{'week'};
	$wday = $::query->{'wday'};
	$startyear = $::query->{'startyear'};
	$startweek = $::query->{'startweek'};
	$startwday = $::query->{'startwday'};
	$duration = $::query->{'duration'};

	$hour1 = $::query->{'hour1'};
	$min1 = $::query->{'min1'};
	$hour2 = $::query->{'hour2'};
	$min2 = $::query->{'min2'};
	$rt = $::query->{'rt'};
	$title = strip_space $::query->{'title'};
	$data = strip_space $::query->{'data'} || '';

	($startmonth, $startday) = get_month_day_by_wday_year_week ($startwday, $startyear, $startweek);

	$lengthmin = $hour2*60 + $min2 - $hour1*60 - $min1;

	if ($hour1 < 0 or $hour1 > 23 or $hour2 < 0 or $hour2 > 23) {
		return "The hour must be 0 - 23.";
	} elsif ($min1 < 0 or $min1 > 59 or $min2 < 0 or $min2 > 59) {
		return "The minute must be 0 - 59.";
	} elsif (! defined $title or ! $title) {
		return "The title of the event must be entered.";
	} elsif (! &ParseDate ("$startmonth/$startday/$startyear")) {
		return "Date $startday.$startmonth.$startyear is invalid."
	} elsif ($duration < 1 or $duration > $::MAX_DURATION) {
		return "You chose impossible duration \"$duration\"."
	} elsif ($rt eq 'w' and ! fit_in_week ($startyear, $startweek, $startwday, $duration)) {
		return "Weekly repeating event must fit entirely in one week."
	} elsif ($rt eq 'm' and ! fit_in_month ($startyear, $startweek, $startwday, $duration)) {
		return "Monthly repeating event must fit entirely in one month (the month you placed it in specifically)."
	} elsif ($rt ne 'n' and $rt ne 'w' and $rt ne 'm') {
		return "You chose impossible repeat type \"$rt\"."
	} elsif (has_html $title or has_html $data) {
		return "Text contains one more more of the illegal characters <, > and &."
	} elsif ($lengthmin <= 0) {
		return "The start of the event ($hour1:$min1) must be before its end ($hour2:$min2)."
	}

	$title = newline_to_html $title;
	$data = newline_to_html $data;

	#
	# Remove the old event. The old one only exists if $id is set so this is
	# an edit command.
	#

	if ($id) {
		$err = remove_events ($oldrt, $startyear, $startweek, $startwday, $oldduration, $oldhour, $id);
		if ($err) {
			return $err;
		}
	}

	#
	# Figure out the new $id
	#
	if (! $id) {
		($id, $err) = next_id ();
		if ($err) {
			return $err;
		}
	}

	#
	# Add event for each day
	#

	$err = add_events ($rt, $startyear, $startweek, $startwday, $duration, $hour1, $id,
		$min1, $lengthmin, $title, $data);
	if ($err) {
		return $err;
	}
	#
	# When we get here, add has been succesful.
	#
	# Return the id and some other items to redraw(), since he doesn't know
	# them otherwise.
	#
	return { 'id' => $id, 'lengthmin' => $lengthmin, 'data' => $data, 'title' => $title };
}

sub remove_event_commit ($$$$$$$$$$$$$$) {
	my ($year, $week, $wday, $id, $hour, $rt, $min, $lengthmin, $title, $data, $startyear, $startweek, $startwday, $duration) = @_;
	my ($err);

	if (! defined $id or ! defined $week or ! defined $wday or ! defined $rt or ! defined $duration) {
		return "some data of the event to be removed not given";
	}

	#
	# Copy data into clipboard
	#
	clipboard_set ($::remote_addr,
		{ 'hour' => $hour, 'min' => $min, 'lengthmin' => $lengthmin,
		  'title' => $title, 'data' => $data, 'rt' => $rt,
		  'startyear' => $startyear, 'startweek' => $startweek, 'startwday' => $startwday, 'duration' => $duration } );

	#
	# Remove the event from the database
	#
	$err = remove_events ($rt, $startyear, $startweek, $startwday, $duration, $hour, $id);
	if ($err) {
		return $err;
	}

	return '';
}

sub copy_event () {
	my ($hour, $min, $lengthmin, $title, $data, $rt, $startyear, $startweek, $startwday, $duration);

	$hour = $::query->{'hour'};
	$min = $::query->{'min'};
	$lengthmin = $::query->{'lengthmin'};
	$title = $::query->{'title'};
	$data = $::query->{'data'};
	$rt = $::query->{'rt'};
	$startyear = $::query->{'startyear'};
	$startweek = $::query->{'startweek'};
	$startwday = $::query->{'startwday'};
	$duration = $::query->{'duration'};

	return if ! check_write_access ();

	clipboard_set ($::remote_addr,
		{ 'hour' => $hour, 'min' => $min, 'lengthmin' => $lengthmin,
		  'title' => $title, 'data' => $data, 'rt' => $rt,
		  'startyear' => $startyear, 'startweek' => $startweek, 'startwday' => $startwday, 'duration' => $duration } );

	# Show_even() re-reads the variables from %$::query
	show_event ();
}

sub paste_event_commit ($$$) {
	my ($year, $week, $wday) = @_;
	my ($event_ref, $err, $id);

#	print STDERR "paste_event_commit: year $year, week $week, wday $wday\n";

	# Read the event data from clipboard
	$event_ref = clipboard_get ($::remote_addr);
	if (! $event_ref) {
		return "There is no event in clipboard for your computer $::remote_addr.";
	}

	#
	# Find new id
	#
	($id, $err) = next_id ();
	if ($err) {
		return $err;
	}

	#
	# Update some fields
	#

	$event_ref->{'startyear'} = $year;
	$event_ref->{'startweek'} = $week;
	$event_ref->{'startwday'} = $wday;
	$event_ref->{'id'} = $id;

	#
	# Make some sanity checks
	#

	my ($startmonth, $startday, $startyear, $startweek, $startwday, $duration, $rt);
	($startmonth, $startday) = get_month_day_by_wday_year_week ($wday, $year, $week);
	$startyear = $year; $startweek = $week; $startwday = $wday;
	$duration = $event_ref->{'duration'};
	$rt = $event_ref->{'rt'};

	if (! &ParseDate ("$startmonth/$startday/$startyear")) {
		return "Date $startday.$startmonth.$startyear is invalid."
	} elsif ($rt eq 'w' and ! fit_in_week ($startyear, $startweek, $startwday, $duration)) {
		return "Weekly repeating event must fit entirely in one week."
	} elsif ($rt eq 'm' and ! fit_in_month ($startyear, $startweek, $startwday, $duration)) {
		return "Monthly repeating event must fit entirely in one month (the month you placed it in, specifically)."
	}
	
	#
	# Add event for each day
	#

#	print STDERR "paste_event: ", Dumper ($event_ref);

	$err = add_events (
		$event_ref->{'rt'},
		$event_ref->{'startyear'},
		$event_ref->{'startweek'},
		$event_ref->{'startwday'},
		$event_ref->{'duration'},
		$event_ref->{'hour'},
		$event_ref->{'id'},
		$event_ref->{'min'},
		$event_ref->{'lengthmin'},
		$event_ref->{'title'},
		$event_ref->{'data'} );
	if ($err) {
		return $err;
	}

	# When we get here, add has been succesful
	return $event_ref;
}

sub xxx_event_error () {
	my ($error1, $error2);
	$error1 = $::query->{'error1'};
	$error2 = $::query->{'error2'};
	
	print Socket $::H_BODY;
	print Socket "<DIV ALIGN=center VALIGN=middle>\n";
	print Socket "<TABLE BORDER=3 ROWS=1 COLS=1 CELLPADDING=20 ALIGN=center VALIGN=middle WIDTH=\"70%\" BGCOLOR=$::ERROR_COLOR>\n";
	print Socket "<TR><TD ALIGN=center VALIGN=middle>\n";
	print Socket "<H1>$error1</H1>\n";
	print Socket "<P>$error2\n</TD></TR>";
	print Socket "</TABLE>\n";
	print Socket "</BODY>\n";
	return;
}

sub show_event_list () {
	my ($year, $week, $alldata_ref, $alldata_ref, $lastweek);
	my ($cweek, $cyear, $cmonth, $cday, $end_cmonth, $end_cday);	
	my ($now_ref, $now_year, $now_week, $now_wday, $week_ref, $wday, $hour);
	
	$year = $::query->{'year'};
	$week = $::query->{'week'};

	$alldata_ref = build_week_list ($year, $week);
#	print STDERR Dumper ($alldata_ref);
	if (ref $alldata_ref ne 'ARRAY') {
		print Socket "<DIV ALIGN=center VALIGN=middle><H1>Listing events failed: $alldata_ref</H1></DIV>\n";
		return;
	}

	$now_ref = get_now ();
	($now_year, $now_week, $now_wday) = ($now_ref->{'year'}, $now_ref->{'week'}, $now_ref->{'wday'});

	print Socket $::H_BODY;

	print Socket "<PRE>\n</PRE>\n<P>\n";
	print Socket "<TABLE BORDER=1 ALIGN=left WIDTH=\"100%\">\n";
	print Socket "<TR><TH COLSPAN=3 BGCOLOR=\"$::THCOLOR\"><FONT SIZE=\"+1\">Events since week $week of year $year\n";
	print Socket "<TR><TH COLSPAN=3><TH>\n";

	$lastweek = -1;
	for $week_ref (@$alldata_ref) {
		for $wday (0..6) {
			for $hour (sort {$a <=> $b} keys %{$week_ref->[0]->[$wday]}) {
				my ($event_ref);
				$cyear = $week_ref->[1];
				$cweek = $week_ref->[2];

				# Change of week
				if ($cweek != $lastweek) {
					my ($b_month, $b_day, $e_month, $e_day, $color);
					$lastweek = $cweek;
					($b_month, $b_day) = get_month_day_by_firstday_year_week ($cyear, $cweek);
					($e_month, $e_day) = get_month_day_by_wday_year_week (6, $cyear, $cweek);
					if ($cyear == $now_year and $cweek == $now_week) {
						$color = $::NOW_TDCOLOR;
					} else {
						$color = $::TDCOLOR;
					}
					print Socket "<TR><TD COLSPAN=3 BGCOLOR=\"$color\"><A TARGET=_top HREF=\"$::MY_URL/?t=redraw&view=week&year=$cyear&week=$cweek\"><B>Week $cweek, ", pd_year_month_day ($cyear, $b_month, $b_day), " - ", pd_year_month_day ($cyear, $e_month, $e_day), "</B></A>\n";
				}

				for $event_ref (@{$week_ref->[0]->[$wday]->{$hour}}) {
					my (%e, $hour1, $min1, $hour2, $min2, $lengthmin);
					my ($tmonth, $tday, $twday, $id, $min, $title, $data, $rt, $day, $color, $rcolor);
					my ($startyear, $startweek, $startwday, $duration);
					%e = %$event_ref;
					$hour1 = $hour;
					$id = $e{'id'};
					$min1 = $e{'min'};
					$lengthmin = $e{'lengthmin'};
					$title = $e{'title'};
					$data = $e{'data'};
					$rt = $e{'rt'};
					$startyear = $event_ref->{'startyear'};
					$startweek = $event_ref->{'startweek'};
					$startwday = $event_ref->{'startwday'};
					$duration = $event_ref->{'duration'};

					$hour2 = ($hour1 + int (($min1+$lengthmin) / 60)) % 24;
					$min2 = ($min1 + $lengthmin) % 60;
					($cmonth, $cday) = get_month_day_by_wday_year_week ($wday, $cyear, $cweek);
					if ($cyear == $now_year and $cweek == $now_week and $wday == $now_wday) {
						$color = " BGCOLOR=\"$::NOW_TDCOLOR\"";
					} else {
						$color = '';
					}
					if ($rt ne 'n') {
						$rcolor = "COLOR=\"$::REPEAT_TEXTCOLOR\"";
					} else {
						$rcolor = '';
					}
					print Socket "<TR><TD$color WIDTH=150><A TARGET=_top HREF=\"$::MY_URL/?t=redraw&view=event",
						"&id=", $id,
						"&year=", $cyear, "&week=", $cweek, "&wday=", $wday,
						"&hour=", $hour,
						"&min=", $min1,
						"&lengthmin=", $lengthmin,
						"&title=", url_encode ($title),
						"&data=", url_encode ($data),
						"&rt=", $rt,
						"&startyear=", $startyear,
						"&startweek=", $startweek,
						"&startwday=", $startwday,
						"&duration=", $duration,
						"\"><FONT $rcolor SIZE=\"2\">";
					printf Socket "<TT>%s %s - %s</TT></A>\n",
						$::weekdays_short[$wday],
						format_time_padded ($hour1, $min1),
						format_time_padded ($hour2, $min2);
					print Socket "</FONT><TD><FONT SIZE=\"2\">", $e{'title'}, "</FONT><TD><FONT SIZE=\"2\">", $data || "&nbsp;", "</FONT>\n";
				}
			}
		}
	}
	print Socket "</TABLE><BR CLEAR=all>\n";

	return;
}

sub show_other_views (;$$) {
	my ($year, $week) = @_;
	my ($month, $moffset);

	$year = $year || $::query->{'year'};
	$week = $week || $::query->{'week'};

	print Socket $::H_BODY;
	
	print Socket "<CENTER>\n<TABLE BORDER=1 COLS=1 CELLPADDING=10 ALIGN=center VALIGN=middle WIDTH=\"95%\" BGCOLOR=\"$::TDCOLOR\">\n";
	print Socket "<TR><TH ALIGN=center BGCOLOR=\"$::THCOLOR\"><FONT SIZE=\"3\"><B>Other views</B></FONT>\n";
	print Socket "\n<TR><TD BGCOLOR=\"$::TDCOLOR\" ALIGN=left>\n";
	print Socket "<UL><FONT SIZE=2>\n";
	print Socket "<LI><A TARGET=_top HREF=\"$::BASE_URL/\">Users of this calendar</A>\n";
	print Socket "<LI><A TARGET=_top HREF=\"$::MY_URL/?t=event_list&year=$year&week=$week\">Events since week $week of year $year</A>";
	print Socket "</FONT></UL>\n";
	
	print Socket "<CENTER><TABLE BORDER=1 COLS=$::MANY_WEEKS_HOR WIDTH=\"98%\" BGCOLOR=\"$::BG_TDCOLOR\">\n";
	my ($cyear, $cweek, $cmonth, $cday, $now_year, $now_week, $n);
	$n = get_now ();
	$now_year = $n->{'year'}; $now_week = $n->{'week'};
	($cyear, $cweek) = get_year_week_by_firstday_year_week_minus_days ($year, $week,
		($::MANY_WEEKS_VERT * $::MANY_WEEKS_HOR  + int ($::MANY_WEEKS_HOR / 2)) * 7);
	for $moffset (-$::MANY_WEEKS_VERT .. $::MANY_WEEKS_VERT) {
		my ($m);
		print Socket "<TR>\n";
		for $m (0 .. $::MANY_WEEKS_HOR-1) {
			($cmonth, $cday) = get_month_day_by_firstday_year_week ($cyear, $cweek);
			if ($cweek == $now_week and $cyear == $now_year) {
				printf Socket "<TD BGCOLOR=\"$::NOW_TDCOLOR\"><FONT SIZE=2><A TARGET=fweek HREF=\"$::MY_URL/?t=week&year=$cyear&week=$cweek\">%02d: %s</A></FONT></TD>\n", $cweek, pd_month_day_padded ($cmonth, $cday);
			} else {
				printf Socket "<TD><FONT SIZE=2><A TARGET=fweek HREF=\"$::MY_URL/?t=week&year=$cyear&week=$cweek\">%02d: %s</A></FONT></TD>\n", $cweek, pd_month_day_padded ($cmonth, $cday);
			}
			$cweek++;
			if ($cweek > 50) {
				$cweek--;
				($cyear, $cweek) = get_next_year_week ($cyear, $cweek);
			}
		}
		print Socket "</TR>\n";
	}
	print Socket "</TABLE></CENTER>\n";

	print Socket "</TABLE>\n";
	print Socket "</CENTER>\n</BODY>\n";
	return;
}

sub redraw_print_frameset ($$$) {
	my ($tweek, $tday, $tevent) = @_;
	my ($top_y, $left_x);
	
	if ($::SCREEN_RESOLUTION eq '800x600') {
		$top_y = 200;
		$left_x = 250;
	} else {
		$top_y = 250;
		$left_x = 320
	}


	print Socket <<END;
<HEAD><TITLE>Wcal - $::LONG_NAME</TITLE></HEAD>
<frameset framespacing="0" border="false" rows="$top_y,*" frameborder="0">
  <frame src="$tweek" bordercolor="#ffffff"
  frameborder="0" marginheight="1" marginwidth="1" name="fweek" scrolling="auto" target="fday" noresize>
  <frameset cols="$left_x,*">
    <frame src="$tday" frameborder="0" marginheight="1"
    marginwidth="1" name="fday" scrolling="auto" target="fevent" noresize>
    <frame src="$tevent" frameborder="0" marginheight="1"
    marginwidth="1" name="fevent" scrolling="auto" noresize>
  </frameset>
  <noframes>
  <body>
  </body>
  </noframes>
</frameset>
END
	return;
}

sub check_write_access () {
	if ($::READ_ONLY eq 'true') {
		print Socket $::H_BODY;
		print Socket "<CENTER><TABLE BORDER=2 COLS=1 CELLPADDING=5 WIDTH=\"80%\" ALIGN=center VALIGN=middle BGCOLOR=\"#b04040\">\n";
		print Socket "<TR><TD><BGCOLOR=\"$::THCOLOR\">&nbsp;<P><CENTER><FONT COLOR=\"#ffffff\" SIZE=4><B>This user has no write permission.</B></FONT></CENTER><P>&nbsp;</TD></TR>\n";
		print Socket "</TABLE></CENTER>\n";
		print Socket "</BODY>\n";
		return 0;
	}
	return 1;
}

sub redraw () {
	my ($view, $id, $year, $week, $wday, $wday_name);
	my ($hour, $min, $lengthmin, $title, $data, $rt);
	my ($tweek, $tday, $tevent);
	my ($startyear, $startweek, $startwday, $duration);

	$view = $::query->{'view'};
	$id = $::query->{'id'};
	$year = $::query->{'year'};
	$week = $::query->{'week'};
	$wday = $::query->{'wday'} || 0;
	$wday_name = $::weekdays[$wday];
	$hour = $::query->{'hour'};
	$min = $::query->{'min'};
	$lengthmin = $::query->{'lengthmin'};
	$title = $::query->{'title'};
	$data = $::query->{'data'};
	$rt = $::query->{'rt'} || 'n';
	$startyear = $::query->{'startyear'};
	$startweek = $::query->{'startweek'};
	$startwday = $::query->{'startwday'};
	$duration = $::query->{'duration'};

	if (! defined $view or $view eq '' or $view eq 'default') {
		$tweek = "$::MY_URL/?t=week";
		$tday = "$::MY_URL/?t=day";
		$tevent = "$::MY_URL/?t=event";
		redraw_print_frameset ($tweek, $tday, $tevent);
	} elsif ($view eq 'week') {
		$tweek = "$::MY_URL/?t=week&year=$year&week=$week";
		$tday = "$::MY_URL/?t=day";
		$tevent = "$::MY_URL/?t=event";
		redraw_print_frameset ($tweek, $tday, $tevent);
	} elsif ($view eq 'event') {
		$tweek = "$::MY_URL/?t=week&year=$year&week=$week";
		$tday = "$::MY_URL/?t=day&year=$year&week=$week&wday=$wday";
		$tevent = "$::MY_URL/?t=event&id=$id&year=$year&week=$week&wday=$wday&hour=$hour&min=$min&lengthmin=$lengthmin&title=" . url_encode ($title) . "&data=" . url_encode ($data) . "&rt=$rt&startyear=$startyear&startweek=$startweek&startwday=$startwday&duration=$duration";
		redraw_print_frameset ($tweek, $tday, $tevent);
	} elsif ($view eq 'after_remove_event') {
		my ($err);
		return if ! check_write_access ();
		$err = remove_event_commit ($year, $week, $wday, $id, $hour, $rt, $min, $lengthmin, $title, $data, $startyear, $startweek, $startwday, $duration);
		$tweek = "$::MY_URL/?t=week&year=$year&week=$week";
		$tday = "$::MY_URL/?t=day&year=$year&week=$week&wday=$wday&rt=$rt";
		if ($err) {
			$tevent = "$::MY_URL/?t=xxx_event_error&error1=" . url_encode ("Error removing event") . "&error2=" . (url_encode $err);
		} else {
			$tevent = "$::MY_URL/?t=event";
		}
		redraw_print_frameset ($tweek, $tday, $tevent);
	} elsif ($view eq 'paste_event') {
		my ($err);
		return if ! check_write_access ();
		$err = paste_event_commit ($year, $week, $wday);
		$tweek = "$::MY_URL/?t=week&year=$year&week=$week";
		$tday = "$::MY_URL/?t=day&year=$year&week=$week&wday=$wday&rt=$rt";
		if (ref $err ne 'HASH') {
			$tevent = "$::MY_URL/?t=xxx_event_error&error1=" . url_encode ("Error pasting event from clipboard") . "&error2=" . (url_encode $err);
		} else {
			$tevent = "$::MY_URL/?t=event&id=" . $err->{'id'} . "&year=$year&week=$week&wday=$wday&hour=" . $err->{'hour'} . "&min=" . $err->{'min'} . "&lengthmin=" . $err->{'lengthmin'} . "&title=" . url_encode ($err->{'title'}) . "&data=" . url_encode ($err->{'data'}) . "&rt=" . $err->{'rt'} . "&startyear=" . $err->{'startyear'} . "&startweek=" . $err->{'startweek'} . "&startwday=" . $err->{'startwday'} . "&duration=" . $err->{'duration'};
		}
		redraw_print_frameset ($tweek, $tday, $tevent);
	} elsif ($view eq 'add_event') {
		my ($err);
		return if ! check_write_access ();
		$err = add_event_commit ();
		$tweek = "$::MY_URL/?t=week&year=$year&week=$week";
		$tday = "$::MY_URL/?t=day&year=$year&week=$week&wday=$wday&rt=$rt";
		if (ref $err ne 'HASH') {
			$tevent = "$::MY_URL/?t=xxx_event_error&error1=" . url_encode ("Error adding an event") . "&error2=" . (url_encode $err);
		} else {
#			print STDERR "redraw: ", Dumper ($err);
			$tevent = "$::MY_URL/?t=event&id=" . $err->{'id'} . "&year=$year&week=$week&wday=$wday&hour=" . $::query->{'hour1'} . "&min=" . $::query->{'min1'} . "&lengthmin=" . $err->{'lengthmin'} . "&title=" . url_encode ($err->{'title'}) . "&data=" . url_encode ($err->{'data'}) . "&rt=$rt&startyear=$startyear&startweek=$startweek&startwday=$startwday&duration=$duration";
		}
		redraw_print_frameset ($tweek, $tday, $tevent);
	} else {
		print Socket "<CENTER><H1>Redraw: Unknown view \"$view\".\n";
	}
	return;
}

sub list_users () {
	my (@users, $user);

	print Socket "<HEAD><TITLE>Users of the $::ORGANIZATION calendar</TITLE></HEAD>\n";
	print Socket $::H_BODY;

	if (! chdir ($::DIRECTORY)) {
		print Socket "<P>Can't change into directory $::DIRECTORY: $!";
		print Socket "<P>Make sure it exists, and its permissions are as explained in file INSTALL of the Wcal distribution.";
		exit (1);
	}

	print Socket "<CENTER><H1>Users of the $::ORGANIZATION calendar</H1></CENTER>";
	print Socket "Click on the calendar which you want to use\n";
	print Socket "<P><UL>\n";
	@users = sort (keys (%$::USER_CONFS));
	for $user (@users) {
		my ($desc);
		$desc = $::USER_CONFS->{$user}->{'long name'};
		print Socket "<LI><A TARGET=_top HREF=\"$::BASE_URL/$user/?t=redraw&view=default\">$desc</A>\n";
	}
	print Socket "</UL>\n";
	print Socket "</BODY>\n";
	return;
}

sub create_users () {
	my (@users, $user);

	if (! chdir ($::DIRECTORY)) {
		return "Can't change into directory $::DIRECTORY: $!<P>Make sure it exists, and its permissions are as explained in file INSTALL of the Wcal distribution.";
	}

	@users = sort (keys (%$::USER_CONFS));
	for $user (@users) {
		my ($desc);
		$desc = $::USER_CONFS->{$user}->{'long name'};
		if (-d $user and -M $user > -M $::CONF_FILE) {
			system "/bin/rm -rf $user";
		}
		if (! -d $user) {
			my ($access_file, $access_file_name);
			if (! mkdir ($user, 0770)) {
				return "Internal error: can't create user '$user': $!";
			}
			if (! chown (0, $::GID, $user)) {
				return "Internal error: can't chown directory '$user' to user id 0, group id $::GID: $!";
			}
			if (! link ('index.cgi', $user . '/index.cgi')) {
				return "Internal error: can't create hard link 'index.cgi -> $user/index.cgi': $!";
			}
			$access_file_name = $::USER_CONFS->{$user}->{'access file name'};
			$access_file = $::USER_CONFS->{$user}->{'access file'};
			if ($access_file and $access_file_name) {
				if (! open (AF, ">$user/$access_file_name")) {
					return "Internal error: can't create access file $user/$access_file_name: $!";
				}
				print AF "# This file is automatically generated from $::CONF_FILE - do not edit\n";
				print AF $access_file;
				close AF;
			}
		}
	}
	return '';
}

# Removes all cache files.
sub purge_cache_all () {
	my (@files);
	if (! opendir (DIR, "$::DB_DIR/cache")) {
#		print STDERR "can't open $::DB_DIR/cache for reading: $!\n";
		return;
	}
	@files = grep { /^w-[^-]+-\d\d\d\d\d\d\.html$/ } readdir (DIR);
	closedir DIR;
	for (@files) {
		unlink "$::DB_DIR/cache/$_" or warn "can't remove $::DB_DIR/cache/$_: $!\n";
	}
}

# Removes cached week views and Date::Manip wrapper caches.
# Supposed to be called at first request after midnight.
sub purge_cache_newday () {
	my (@files);
	my ($now_ref, $foo, $week1, $week2);
	
	#
	# Cached dates.
	# Other date caches stay valid accross date change.
	#

	undef $::now_cache;

	#
	# Cached week for this week, or all weeks if the week has changed
	# 
	$now_ref = get_now ();
	$week1 = sprintf ("%02d", $now_ref->{'week'});
	($foo, $week2) = get_prev_year_week ($now_ref->{'year'}, $week1);
	$week2 = sprintf ("%02d", $week2);
	
	if (! opendir (DIR, "$::DB_DIR/cache")) {
#		print STDERR "can't open $::DB_DIR/cache for reading: $!\n";
		return;
	}
	if ($week1 == $week2) {
		@files = grep { /^w-[^-]+-\d\d\d\d$week1\.html$/ } readdir (DIR);
	} else {
		@files = grep { /^w-[^-]+-\d\d\d\d\d\d\.html$/ } readdir (DIR);
	}
	closedir DIR;
	for (@files) {
		unlink "$::DB_DIR/cache/$_" or warn "can't remove $::DB_DIR/cache/$_: $!\n";
	}

	return;
}

# Create socket and make it listen
sub init_socket () {
	if (! socket (SSocket, PF_INET, SOCK_STREAM, getprotobyname('tcp')) ) {
		print STDERR "$0: can't create socket: $!";
		exit 1;
	}

	if (! setsockopt(SSocket, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) ) {
		print STDERR "$0: can't set socketopt SO_REUSEADDR: $!";
		exit 1;
	}

	if (! bind(SSocket, sockaddr_in($::PORT, INADDR_ANY)) ) {
		print STDERR "$0: can't bind socket to INADDR_ANY: $!";
		exit 1;
	}

	if (! listen(SSocket, SOMAXCONN) ) {
		print STDERR "$0: can't make socket listen: $!";
		exit 1;
	}
}

sub parse_config_line ($) {
	my ($line) = @_;
	my ($key, $value);

	if ($line =~ /^#/ or $line =~ /^\s*$/) {
		return '';
	}
	if ($line =~ /=/) {
		($key, $value) = split (/=/, $_, 2);
	} else {
		($key, $value) = ($_, '');
	}
	$key =~ s/^\s*(.*?)\s*$/$1/;
	$key = lc $key;
	$key =~ tr/ \t/ /s;
	if ($key !~ /^[a-z0-9_ ]+$/) {
		return "Config file line $. key '$key' has invalid characters";
	}
	$value =~ s/^\s*(.*?)\s*$/$1/;
	return {'key' => $key, 'value' => $value};
}

sub import_settings ($) {
	my ($s_ref) = @_;
	$::PASSWORD = $s_ref->{'password'};
	$::PORT = $s_ref->{'port'};
	$::BASE_URL = $s_ref->{'base url'};
	$::DB_DIR = $s_ref->{'database directory'};
	$::ORGANIZATION = $s_ref->{'organization'};
	$::LONG_NAME = $s_ref->{'long name'};
	$::READ_ONLY = $s_ref->{'read only'};
	$::DATA_ID = $s_ref->{'data id'};
	$::FIRST_DAY = $s_ref->{'first day'};
	$::DATE_FORMAT = $s_ref->{'date format'};
	$::CLOCK = $s_ref->{'clock'};
	$::SCREEN_RESOLUTION = $s_ref->{'screen resolution'};
	$::TOP_LEFT_CORNER = $s_ref->{'top left corner'};

	$::MY_URL = $::BASE_URL . "/" . (defined ${main::USER} ? ${main::USER} : '');
	$::MY_URL_XUSER = $::BASE_URL . "/" . (defined ${main::USER} ? 'X_USER_X' : '');

	return;
}

# Reads global config data from /etc/wcal.conf
sub read_config () {
	my ($key, $value, $line, $line_ref, %global_conf, %user_confs, $cuser, $conf_ref);
	my (@current_access_file, $reading_access_file);
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks);
	my ($valid_line);

	if (! open (CONF, "<$::CONF_FILE")) {
		return \"can't open $::CONF_FILE for reading: $!";
	}

	# Conf file must not be read/writeable by 'other'
	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat (CONF);
	if ($mode & 6) {
		close CONF;
		return \"Configuration file $::CONF_FILE must not have read or write permission for 'other' (do 'chmod o= $::CONF_FILE)'.\n";
	}

	# Empty the settings from the last run
	%global_conf = (); %user_confs = ();
	$conf_ref = \%global_conf;
	$cuser = '';
	$reading_access_file = 0;

	# Set some defaults
	$global_conf{'host'} = 'localhost';
	$global_conf{'port'} = '13134';
	$global_conf{'base url'} = '/wcal';
	$global_conf{'database directory'} = '/var/wcal';
	$global_conf{'access file name'} = '.htaccess';
	$global_conf{'access file'} = '';
	$global_conf{'organization'} = 'My Organization';
	$global_conf{'read only'} = 'false';
	$global_conf{'first day'} = 'monday';
	$global_conf{'date format'} = 1;
	$global_conf{'clock'} = '24-hour';
	$global_conf{'screen resolution'} = '800x600';
	$global_conf{'top left corner'} = '&nbsp;';

	while (<CONF>) {
		chomp;
		$line = $_;

		# If we are reading access file, do special processing
		if ($reading_access_file) {
			$line =~ s/^\s*(.*?)\s*$/$1/;
			if ($line =~ /^end access file$/i) {
				$conf_ref->{'access file'} = join ("\n", @current_access_file) . "\n";
				$reading_access_file = 0;
			} else {
				push @current_access_file, $line;
			}
			next;
		}
		
		# Else do the normal processing

		$line_ref = parse_config_line ($line);
		next if ! $line_ref;	# skip comments and empty lines
		if (! ref $line_ref) {	# if return value not empty, and not a reference, it's an error
			close CONF;
			return \$line_ref;
		}
		$key = $line_ref->{'key'};
		$value = $line_ref->{'value'};

		# 'user' field starts user definition
		if ($key eq 'user') {
			if ($value !~ /^\w+$/) {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. starts user definition, but given user id '$value' is invalid; user id must consist of alphanumeric characters and the underline character _";
			}
			if (! defined $global_conf{'password'}) {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. starts user definition, but the password field hasn't yet occured (password must be given in global section before any user definitions)";
			}
			$cuser = $value;
			$conf_ref = {};
			next;
		}
		
		# 'end user' field ends user definition
		if ($key eq 'end user') {
			my ($gkey);
			# Copy each global conf field into user definition if it isn't given in user definition
			for $gkey (keys %global_conf) {
				if (! defined $conf_ref->{$gkey}) {
					$conf_ref->{$gkey} = $global_conf{$gkey};
				}
			}
			# Long name = user, if not explicitely given
			if (! defined $conf_ref->{'long name'}) {
				$conf_ref->{'long name'} = $cuser;
			}
			# Data id = user, if not explicitely given
			if (! defined $conf_ref->{'data id'}) {
				$conf_ref->{'data id'} = $cuser;
			}
			# Empty 'top left corner' replaced with &nbsp;, to make browsers happier.
			if ($conf_ref->{'top left corner'} eq '') {
				$conf_ref->{'top left corner'} = '&nbsp;';
			}
			$user_confs{$cuser} = $conf_ref;
			$cuser = '';
			$conf_ref = \%global_conf;
			next;
		}

		# 'access file' starts (default / user) access file definition
		if ($key eq 'access file') {
			if ($value) {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. starts access file definition, but has value field";
			}
			@current_access_file = ();
			$reading_access_file = 1;
			next;
		}

		$valid_line = 0;

		# Some fields can only occur in global section
		if ($cuser and ($key eq 'port' or $key eq 'address')) {
			close CONF;
			return \"Configuration file $::CONF_FILE line $. has in user $cuser definition parameter '$key' that can only occur in global section";
		}

		# And some only in user definition
		if (! $cuser and ($key eq 'long name' or $key eq 'read only')) {
			close CONF;
			return \"Configuration file $::CONF_FILE line $. has in global section parameter '$key' that can only occur in user definition";
		}

		# READ ONLY field can have only values true or false
		if ($key eq 'read only') {
			$value = lc $value;
			if ($value ne 'true' and $value ne 'false') {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. has invalid value for option 'read only'. Allowed values are true and false (default false).";
			}
			$valid_line = 1;
		}

		# FIRST DAY can be only monday or sunday
		elsif ($key eq 'first day') {
			if ($value ne 'monday' and $value ne 'sunday') {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. has invalid value for option 'first day'. Allowed values are monday and sunday (default monday).";
			}
			$value = lc $value;
			$valid_line = 1;
		}

		# DATE FORMAT must be between 1 and 5
		elsif ($key eq 'date format') {
			if ($value < 1 or $value > 6) {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. has invalid value for option 'date format'. Allowed values are 1 to 6 (default 1).";
			}
			$valid_line = 1;
		}
		
		# PORT must be a integer number
		elsif ($key eq 'port') {
			if ($value !~ /^\d+$/ or $value < 1 or $value > 65535) {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. has invalid value for option 'port'. Allowed values are integer numbers between 1 and 65535 (default 13134).";
			}
			$valid_line = 1;
		}

		# CLOCK must be 24-hour or 12-hour
		elsif ($key eq 'clock') {
			$value = lc $value;
			if ($value ne '24-hour' and $value ne '12-hour') {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. has invalid value for option 'clock'. Allowed values are '24-hour' and '12-hour' (default 24-hour).";
			}
			$valid_line = 1;
		}

		# SCREEN RESOLUTION must be 800x600 or 1024x768
		elsif ($key eq 'screen resolution') {
			$value = lc $value;
			if ($value ne '800x600' and $value ne '1024x768') {
				close CONF;
				return \"Configuration file $::CONF_FILE line $. has invalid value for option 'screen resolution'. Allowed values are '800x600' and '1024x768' (default 800x600).";
			}
			$valid_line = 1;
		}

		# OTHERS - no particular syntax required, but must be a valid key
		elsif ($key eq 'base url' or $key eq 'database directory' or $key eq 'password' or
		       $key eq 'organization' or $key eq 'access file name' or $key eq 'data id' or
		       $key eq 'long name' or $key eq 'address' or $key eq 'top left corner') {
			$valid_line = 1;
		}

		if (! $valid_line) {
			close CONF;
			return \"Configuration file $::CONF_FILE line $. has unknown option '$key'.";
		}

		$conf_ref->{$key} = $value;
	}
	close CONF;
	if ($reading_access_file or $cuser) {
		return \"End of configuration file $::CONF_FILE while reading access file or user definition";
	}

	if (scalar (keys (%user_confs)) == 0) {
		return \"Configuration file $::CONF_FILE doesn't define any users";
	}

	$::GLOBAL_CONF = \%global_conf;
	$::USER_CONFS = \%user_confs;

	import_settings ($::GLOBAL_CONF);

	if (! -d $::DB_DIR and ! mkdir ($::DB_DIR, 0770)) {
		return \"Can't create $::DB_DIR: $!";
	}
	if (! -d "$::DB_DIR/cache" and ! mkdir ("$::DB_DIR/cache", 0770)) {
		return \"Can't create $::DB_DIR/cache: $!";
	}

	purge_cache_all ();

	return 1;
}

# Read CGI environment and conf option from Socket (sent by the cgi-proxy)
sub read_environment () {
	my ($key, $value, $user);

	while (<Socket>) {
		chomp;
		last if /^$/;
		my ($key, $value);
		
		($key, $value) = split (/=/, $_, 2);
#		$::cgi_env{$key} = $value;
		if ($key eq 'QUERY_STRING') {
			$::query = decode_url_encoded_data \$value;
		} elsif ($key eq 'REMOTE_ADDR') {
			$::remote_addr = $value;
		} elsif ($key =~ /^__/) {
			$key = lc $key;
#			print Socket "<P>$key:$value\n";
			if ($key eq '__password') {
#				print Socket "<P>got: '$value', correct is '$::PASSWORD'\n";
				if ($value ne $::PASSWORD) {
					print Socket "<P>Invalid password\n";
					return 0;
				}
			} elsif ($key eq '__user') {
				$::USER = $value;
			} elsif ($key eq '__gid') {
				$::GID = $value;
			} else {
				print Socket "<P>Unknown configuration option '$key'\n";
				return 0;
			}
		}
	}
#	print Socket "<P>$::MY_URL\n";

	# Make sure we received all the mandatory options
	if (! $::USER) {
		print Socket "<P>User not sent by cgi-proxy\n";
		return 0;
	}
	return 1;
}

sub siginthandler {
	exit (1);
}

sub sighuphandler {
	my ($res);

	return; # do nothing, this is just a kludge that doesn't work

	$::GID = 60;
	$res = read_config ();
	if (ref $res) {
		print STDERR "<P>Re-reading configureation failed: ", $$res, " - configuration not changed.\n";
	} else {
		$res = create_users ();
		if ($res) {
			print STDERR "<P>Error creating new users: $res\n";
		}
	}
	return;
}

#
# Access various functions to create cache entries
# This takes a surprising 10 seconds on P100
#
sub populate_caches () {
	my ($year, $month, $day, $week, $wday, $n);

#	$n = get_now();
#	$year = $n->{'year'};
#	$week = $n->{'week'};
#	for (1 .. 2) {
#		get_month_day_by_firstday_year_week ($year, $week);
#		for $wday (0 .. 6) {
#			get_month_day_by_wday_year_week ($wday, $year, $week);
#		}
#		get_prev_year_week ($year, $week);
#		($year, $week) = get_next_year_week ($year, $week);
#	}
	return;
}

sub create_directories () {
	if (! -e $::DB_DIR) {
		if (! mkdir ($::DB_DIR, 0770)) {
			die "can't create directory $::DB_DIR: $!";
		}
	}
	if (! -e "$::DB_DIR/cache") {
		if (! mkdir ("$::DB_DIR/cache", 0770)) {
			die "can't create directory $::DB_DIR/cache: $!";
		}
	}
}

sub check_and_set_first_day () {
	my ($gen);
	
	$gen = read_general ();
	if (! ref $gen) {
		print "error: $gen\n";
		exit (1);
	}
	if (defined $gen->{'first day'} and $gen->{'first day'} ne $::FIRST_DAY) {
		print <<EOD;

Current database ($::DB_DIR/*.db) is created using different 'first day'
value than defined in current configuration file $::CONF_FILE.
If you want to change 'first day' setting, you must first destroy the
current database (by doing 'rm $::DB_DIR/*.db').

EOD
		exit (1);
	}
	if (! defined $gen->{'first day'}) {
		my ($err);

		$gen->{'first day'} = $::FIRST_DAY;
		$err = write_general ($gen);
		if ($err) {
			print "error: $err\n";
			exit (1);
		}
	}
	return;
}

sub main () {
	my ($config_result, $last_run, $last_conf);
   my (%opts, $pid);
   local *FD;

   # parse command line options
   getopts('dpP', \%opts);

   if( $opts{d} ) {  # daemon mode
      $pid = fork();
      if( $pid !=0 ) {  # parent returns
         if( $opts{p} ) {  # print pid
           print "$pid\n";
         }
         if( $opts{P} ) {  # print pid to /var/run/wcald.pid
           open(FD, ">/var/run/wcald.pid");
           print FD "$pid\n";
           close(FD);
         }
         exit(0);
      }
   }
	
	$SIG{HUP} = $SIG{PIPE} = 'IGNORE';
	$SIG{ALRM} = \&purge_cache_all;
	$ENV{'PATH'} = '/usr/local/bin:/usr/local/sbin:/usr/bin:/usr/sbin:/bin:/sbin';	# To pass taint checks
	
	#
	# Make sure the $::DIRECTORY variable is set (by Makefile or manually)
	#

	if ($::DIRECTORY =~ /^_X_DIRECTOR/) {
		print "You haven't set the variable $::DIRECTORY at top of wcald.\n";
		print "It is automatically set by Makefile. If you're installing manually,\n";
		print "set the variable the name directory you installed wcald to.\n";
		exit 1;
	}

	#
	# Read configuration
	#
	$config_result = read_config ();
	if (ref $config_result) {
		print "$0: error: ", $$config_result, "\n";
		exit 1;
	}

	#
	# Make sure current database (if one exists) uses same 'first day'
	# parameter as we're currently using.
	#

	check_and_set_first_day ();
	
	#
	# Set the date constants
	#
	if ($::FIRST_DAY eq 'monday') {
		@main::weekdays = qw (Monday Tuesday Wednesday Thursday Friday Saturday Sunday);
		@main::weekdays_short = qw (mon tue wed thu fri sat sun);
		&Date_Init ('FirstDay=1');
	} else {
		@main::weekdays = qw (Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
		@main::weekdays_short = qw (sun mon tue wed thu fri sat);
		&Date_Init ('FirstDay=7');
	}
	@main::months = qw (ERROR January February March April May June July August September October November December);

	#
	# Set up rest of the environment
	#
	create_directories ();
	populate_caches ();

	init_socket ();

	$last_run = (localtime(time))[7];
	$last_conf = 0;
	while (1) {
		my ($query_type, $pid, $paddr, $cgi, %user, $now_run, $now_conf);

		$SIG{'INT'} = $SIG{'TERM'} = \&siginthandler;
		$SIG{'HUP'} = \&sighuphandler;
		$paddr = accept (Socket, SSocket);
		$SIG{'INT'} = $SIG{'TERM'} = $SIG{'HUP'} = 'IGNORE';

		#
		# Purge cache when day changes
		#
		$now_run = (localtime(time))[7];
		if ($now_run != $last_run) {
			$last_run = $now_run;
			purge_cache_newday ();
		}

		#
		# Start outputing HTML
		#
		print Socket $::HTTP_HEADER;
		print Socket "<HTML>\n";

		#
		# Read CGI environment and the config options that cgi-proxy passes to us
		# Includes QUERY_STRING (decoded into $::query),
		#  __password (checked) and __user (stored in $::USER)
		#
		if (! read_environment ()) {
			next;
		}

		#
		# Re-read config if it has changed
		#
		$now_conf = (stat($::CONF_FILE))[9];
		if ($now_conf != $last_conf) {
			$last_conf = $now_conf;
			$config_result = read_config ();
			if (ref $config_result) {
				while (<Socket>) { chomp; last if /^$/; };	# Read environment to make cgi-proxy happy
				print Socket $::H_BODY;
				print Socket "<P><H2>Configuration has changed.</H2>";
				print Socket "<P>Re-reading configureation failed: ", $$config_result, " - configuration not changed.\n";
				print Socket "<P><A TARGET=\"_top\" HREF=\"$::BASE_URL/\">Click me</A> to go to the main view\n";
				print Socket "</BODY>\n";
				next;
			} else {
				my ($res);
				
				$res = create_users ();
				if ($res) {
					print Socket $::H_BODY;
					print Socket "<P><H2>Configuration has changed.</H2>";
					print Socket "<P>Error creating new users: $res\n";
					print Socket "<P><A TARGET=\"_top\" HREF=\"$::BASE_URL/\">Click me</A> to go to the main view\n";
					print Socket "</BODY>\n";
					next;
				}
				# fall through: just serve the request 
			}
		}

		# If cgi-proxy was executed from directory named wcal (by default),
		# show a list of users
#		print Socket "<P>:$::USER:\n";
		if ($::USER eq $::PATH_BASENAME) {
			list_users ();
			next;
		}

		# Make sure the users exists
		if (! $::USER_CONFS->{$::USER}) {
			print Socket "$0: User '$::USER' doesn't exist in this system";
			next;
		}
		import_settings ($::USER_CONFS->{$::USER});
		
		#
		# Dispatch the operation
		#

		$::query->{'u'} = $::USER;
		$query_type = $::query->{'t'} || '';
		if ($query_type eq 'redraw' or $query_type eq '') {
			redraw ();
		} elsif ($query_type eq 'week') {
			show_week ();
		} elsif ($query_type eq 'day') {
			show_day ();
		} elsif ($query_type eq 'event') {
			show_event ();
		} elsif ($query_type eq 'copy_event') {
			copy_event ();
		} elsif ($query_type eq 'add_edit') {
			add_edit_event_ask () if check_write_access ();
		} elsif ($query_type eq 'add_edit_confirm') {
			add_edit_event_confirm () if check_write_access ();
		} elsif ($query_type eq 'remove') {
			remove_event_confirm () if check_write_access ();
		} elsif ($query_type eq 'xxx_event_error') {
			xxx_event_error ();
		} elsif ($query_type eq 'event_list') {
			show_event_list ();
		} elsif ($query_type eq 'views') {
			show_other_views ();
		} else {
			print Socket "<H2><P>Unknown command '$query_type'.</H2>\n";
		}
		undef $::query;

	} continue {
		print Socket "</HTML>\n";
		close Socket;
	}

	# not reached
}

main();
