#!/usr/bin/env perl
#
# calendar.pl
$VERSION = "1.2";
#
# Copyright (c) 2003 Jacob Luna Lundberg <jacob@lunixsys.com>
#
# Perl script to create a calendar in the form of a chunk of html
# suitable for inclusion into a web page via shtml.  The calendar
# is marked up according to the configuration file calendar.dat.
#
# This source is distributed under the GPL, version 2 or at your
# convenience, any later version.
#


##
### Basic configuration options.
##
$DEBUG = 0;
$allowpoweredby = 1;
$conffile = "./calendar.dat";
$defaultlocale = "C";
$poweredby = "Powered by Lunix Systems calendar.pl v$VERSION";
$scrcpyrgt = "<!-- calendar.pl v$VERSION Copyright (c) 2003 Jacob Luna Lundberg <jacob\@lunixsys.com> -->";
$stackmark = "<!-- calendar.pl end -->";
$weekstarts = 0;


##
### Linear Program Flow
##
configurate();
emitcalendar();
closeupshop();
die("calendar.pl: Program flow past closeupshop(), hell must be frozen over!\n");


##
### Overhead and Configuration
##
sub configurate {
	# The configuration variables are globals...

	# Deal with some basic taint issues.
	delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
	$ENV{PATH} = "/sbin:/bin:/usr/sbin:/usr/bin";

	# We need the mktime() and strftime() functions, and locale support.
	require 5.004;
	use POSIX qw(mktime);
	use POSIX qw(strftime);
	use POSIX qw(locale_h);

	# Emit calendar program copyright header and prime the html stack.
	print("\n");
	tagopen($scrcpyrgt, $stackmark);

	# Read the configuration file.
	if ($ARGV[0]) {
		$conffile = $ARGV[0];
	}
	open(CONFFILE, "<$conffile") || barf("Failed to open the config file!");
	@conf = <CONFFILE>;
	close(CONFFILE);
	chomp(@conf);

	# Parse the recognised configuration options.
	$months = 0;
	foreach $lineitem (@conf) {
		if ($lineitem =~ /^\s*allowpoweredby\s+/i) {
			# May the script emit its attribution tag?
			($allowpoweredby = $lineitem) =~ s/^\s*allowpoweredby\s+("?)(.*)\1.*$/$2/i;
			$allowpoweredby =~ s/.*(false)|(no)|(off).*/0/i;
		} elsif ($lineitem =~ /^\s*color\s+/i) {
			# Set the primary text color.
			($color = $lineitem) =~ s/^\s*color\s+"(.*)".*$/$1/i;
		} elsif ($lineitem =~ /^\s*copyright\s+/i) {
			# Set the content copyright comment emitted.
			($copyright = $lineitem) =~ s/^\s*copyright\s+"(.*)".*$/$1/i;
		} elsif ($lineitem =~ /^\s*define\s+/i) {
			# Define a calendar markup.
			my ($ignore, $defkey, $defcol, $deftxt, $defurl);
			($ignore, $defkey, $defcol, $deftxt, $defurl) = ($lineitem =~ /"[^"]*"|\S+/g);
			map(s/"//g, ($defkey, $defcol, $deftxt, $defurl));
			$defaults{$defkey} = {col => $defcol, txt => $deftxt, url => $defurl};
		} elsif ($lineitem =~ /^\s*locale\s+/i) {
			# Locale selected for calendar output.
			($locale = $lineitem) =~ s/^\s*locale\s+"(\w*)".*$/$1/i;
		} elsif ($lineitem =~ /^\s*title\s+/i) {
			# Title of the calendar.
			($title = $lineitem) =~ s/^\s*title\s+"(.*)".*$/$1/i;
		} elsif ($lineitem =~ /^\s*weekstarts\s+/i) {
			($weekstarts = $lineitem) =~ s/^\s*weekstarts\s+"(.*)".*$/$1/i;
			$weekstarts = weektonum($weekstarts);
		} elsif ($lineitem =~ /^\s*month\s+/i) {
			# Month is ignored until the main loop.
			++$months;
		} elsif ($lineitem =~ /^\s*\d+\s+/) {
			# Hilighted days are also ignored until later.
		} elsif ($lineitem =~ /^\s*(?:#.*)*$/) {
			# Blank lines and comments are ignored.
		} else {
			# unknown option (bleh)
			$lineitem =~ s/\-{2,}/\-/g;
			$lineitem =~ y/<>/()/;
			tagopen("<!-- calendar.pl unknown option in conf file\n\t$lineitem\n-->");
		}
	}

	# Emit calendar contents copyright header.
	if ($copyright) {
		tagopen("<!-- Generated content $copyright -->");
	}

	# We will use a locale if one was specified (else we'll use the default, probably "C").
	if ($locale && setlocale(LC_TIME, $locale)) {
		tagopen("<!-- Using locale \"$locale\" -->");
	} else {
		setlocale(LC_TIME, $defaultlocale);
	}
}


##
### Calendar Emission
##
sub emitcalendar {
	my (@days, $curmonth, $lineitem);

	# Encapsulate the calendars in a table so the width is no more than needed.
	# NOTE: I hate all these tables, but show me how to make div format the same...
	tagopen("<table style=\"background: #ffffff; border: 2px solid #ccc;\">", "</table>");

	# Calendar title emission (title is an optional config directive).
	if ($title) {
		emittitle();
	}

	# Debugging calendar dump.
	if ($DEBUG) {
		emitdebugdump();
	}

	# Loop on the months and print their calendar outputs.
	$curmonth = undef;
	foreach $lineitem (@conf) {
		if ($lineitem =~ /^\s*month\s+/i) {
			# We're starting a new month and finishing out the old one, if any.
			if ($curmonth) {
				emitmonth($curmonth, @days);
			}
			# Kill the last calendar.
			@days = undef;
			# Decide what month we're currently working on.
			($curmonth = $lineitem) =~ s/\s*month\s+(\S+)\s+(\S+).*/$1 $2/i;
		} elsif ($lineitem =~ /^\s*\d+\s+/) {
			# Parse the markup info for this day and store in an array.
			my ($daynum, $daykey, $daytxt);
			($daynum, $daykey, $daytxt) = ($lineitem =~ /"[^"]*"|\S+/g);
			map(s/"//g, ($daynum, $daykey, $daytxt));
			if ($daynum > 0 && $daynum < 32) {
				$days[$daynum] = {dom => $daynum, key => $daykey, txt => $daytxt};
			}
		} else {
			# Ignore anything that's not a calendar directive.
		}
	}

	# If no months specified, we'll print the current month.  Feh.
	if ($months == 0 || !$curmonth) {
		$curmonth = strftime("%m %Y", localtime());
	}

	# The last (only?) month is now queued; print it.
	emitmonth($curmonth, @days);

	# Last but least is the script attribution notice.
	if ($allowpoweredby) {
		emitpoweredby();
	}

	# End the encapsulating table.
	tagclose("</table>");
}


##
### Close Up Shop, We're Done
##
sub closeupshop {

	# Main execution is now complete.  This takes the place of ``tagclose($stackmark);''.
	$stacktop = shift(@htmlstack);
	if ($stacktop ne $stackmark) {
		# Stack is not unwound!
		print("\n\n<!-- calendar.pl failed to unwind html stack; internal error! -->\n");
		print($stacktop, @htmlstack, "\n");
	} else {
		print("\n", $stacktop, "\n");
	}
	exit(0);
}


##
### Title Emission
##
sub emittitle {
	tagopen("<tr>", "</tr>");
	tagopen("<td colspan=\"2\" style=\"text-align: center; font-size: 120%;\">", "</td>");
	print($title);
	tagclose("</td>");
	tagclose("</tr>");
}


##
### Single Month Emission
##
sub emitmonth {
	my ($curmonth, @days) = @_;

	# Open table row containing this month.
	tagopen("<tr>", "</tr>");

	# Emit the calendar part of this month.
	tagopen("<td style=\"padding: 5px; border: 1px solid #000; color: $color;\">", "</td>");
	emitcalside($curmonth, @days);
	tagclose("</td>");

	# Emit the events part of this month.
	tagopen("<td valign=\"top\" style=\"border: 1px solid #000; color: $color;\">", "</td>");
	emitevtside($curmonth, @days);
	tagclose("</td>");

	# Close table row containing this month.
	tagclose("</tr>");
}


##
### Emit Single Month Calendar Portion
##
sub emitcalside {
	my ($curmonth, @days) = @_;
	my (@cal, $wkd, $tdc);

	# The calendar is wrapped in a formatting table.
	tagopen("<table>", "</table>");

	# Get the localised calendar description...
	@cal = getcalendar($curmonth);

	# The title of the calendar is the month name, in $cal[0].
	tagopen("<tr>", "</tr>");
	tagopen("<td colspan=\"7\" style=\"text-align: center;\">", "</td>");
	print($cal[0]);
	tagclose("</td>");
	tagclose("</tr>");

	# Next the day name headers...
	tagopen("<tr>", "</tr>");
	foreach $wkd (@{$cal[1]}) {
		tagopen("<td style=\"font-size: 75%; text-align: center; " .
			"border: 1px solid #ddd;\">", "</td>");
		print($wkd);
		tagclose("</td>");
	}
	tagclose("</tr>");

	# Get ready to spit out the main calendar table.
	tagopen("<tr>", "</tr>");
	if ($cal[2]) {
		# Padding may be needed before the first day.
		tagopen("<td colspan=\"$cal[2]\">", "</td>");
		tagclose("</td>");
	}

	# Output the actual month days of this calendar.
	for (my $dofm = 1; $dofm <= $cal[3]; ++$dofm) {
		my (%day, %def, $frgcol, $bkgcol);

		# Check if we need to split the table rows now.
		if ($dofm > 1 && (($dofm + $cal[2]) % 7 == 1)) {
			tagclose("</tr>");
			tagopen("<tr>", "</tr>");
		}

		# Get the info on this day.
		%day = %{$days[$dofm]};
		%def = %{$defaults{$day{"key"}}};

		# Can we do the markup for this day, if any?
		if ($day{"key"} && $def{"col"}) {
			# Mark the day up for display.
			$frgcol = $def{"col"};
			$bkgcol = scalecolor($frgcol, 85);
			tagopen("<td style=\"width: 3ex; text-align: right; " .
				"border: 1px solid $frgcol; " .
				"background: $bkgcol; color: $frgcol;\">", "</td>");
		} else {
			# Output the day as a default unmarked day.
			tagopen("<td style=\"width: 3ex; text-align: right; " .
				"border: 1px solid #ddd;\">", "</td>");
		}
		print($dofm);
		tagclose("</td>");
	}

	# Clean up after outputting the main calendar table.
	$tdc = 7 - (($cal[2] + $cal[3]) % 7);
	if ($tdc < 7) {
		# Padding may be needed after the last day.
		tagopen("<td colspan=\"$tdc\">", "</td>");
		tagclose("</td>");
	}
	tagclose("</tr>");

	# End of the formatting table.
	tagclose("</table>");
}


##
### Emit Single Month Events Portion
##
sub emitevtside {
	my ($curmonth, @days) = @_;
	my ($day);

	# The events are wrapped in a formatting table.
	tagopen("<table style=\"width: 100%;\">", "</table>");

	# Iterate through the entire set of markups for this month.
	foreach $day (@days) {
		my (%day, %def, $frgcol, $bkgcol);
		%day = %$day;
		%def = %{$defaults{$day{"key"}}};

		# Set up our working colors.
		$frgcol = $def{"col"};
		$bkgcol = scalecolor($frgcol, 85);

		if ($def{"txt"} || $day{"txt"} || $def{"url"}) {

			# Open the table row for this day.
			tagopen("<tr>", "</tr>");

			# Output the day of the month (leftmost cell).
			tagopen("<td style=\"width: 3ex; text-align: center; " .
				"background: $bkgcol; color: $frgcol; " .
				"border: 1px solid $frgcol;\">", "</td>");
			print($day{"dom"});
			tagclose("</td>");

			# Output the various informations (right cell).
			tagopen("<td style=\"text-align: left; " .
				"background: $bkgcol; color: $frgcol; " .
				"border: 1px solid #ccc;\">", "</td>");

			# The default text for this class of day.
			if ($def{"txt"}) {
				print($def{"txt"});
				if ($day{"txt"} || $def{"url"}) {
					tagopen("<br>");
				}
			}

			# The specific text for this day.
			if ($day{"txt"}) {
				print($day{"txt"});
				if ($def{"url"}) {
					tagopen("<br>");
				}
			}

			# The default URL information for this class.
			if ($def{"url"}) {
				tagopen("<a href=\"" . $def{"url"} . "\">", "</a>");
				print($def{"url"});
				tagclose("</a>");
			}

			# Close the cell and close the table row.
			tagclose("</td>");
			tagclose("</tr>");
		}
	}

	# End of the formatting table.
	tagclose("</table>");
}


##
### Emit Script Attribution, a.k.a. Powered-By Notice
##
sub emitpoweredby {
	my ($fadcol);

	# Pick our color.
	if (!$color) {
		$fadcol = "#7f7f7f";
	} else {
		$fadcol = scalecolor($color, 50);
	}

	# Emit the powered by notice in the bottom segment of the main table.
	tagopen("<tr>", "</tr>");
	tagopen("<td colspan=\"2\" style=\"color: $fadcol; font-size: 60%; text-align: right;\">", "</td>");
	print($poweredby);
	tagclose("</td>");
	tagclose("</tr>");
}


##
### Support Functions
##

#
# Functions for when something goes wrong.
#

# barf() is what we do on critical errors
sub barf {
	my (@message) = @_;

	# Tell the user what's up.
	print("\n\n<br>\n<br>The calendar script has failed for the following reason:");
	print("\n<br>'", @message, "'");
	print("\n<br>Please alert the web site administrator!\n<br>\n\n");

	# Unwind the html stack.
	print(@htmlstack, "\n");

	# We have barfed.  Exit.
	exit(0);
}

# emitdebugdump() is intended to provide really basic info on the running calendar.pl
sub emitdebugdump {
	my (@calendar, $temp);

	# TEMP? - well, for testing, heh...
	@calendar = getcalendar("oct 2003");

	# Dump a bunch of crap into the display table just below the title.
	tagopen("<tr>", "</tr>");
	tagopen("<td colspan=\"2\" style=\"text-align: left; border: 5px solid #a10;\">", "</td>");
	print("<p>. calendar.pl debug dump follows .</p>\n");
	print("<p>");
	($temp = $color) =~ y/<>/()/;
	print("color = \"$temp\"<br>\n");
	($temp = $copyright) =~ y/<>/()/;
	print("copyright = \"$temp\"<br>\n");
	($temp = $defaultlocale) =~ y/<>/()/;
	print("defaultlocale = \"$temp\"<br>\n");
	($temp = $locale) =~ y/<>/()/;
	print("locale = \"$temp\"<br>\n");
	($temp = $title) =~ y/<>/()/;
	print("title = \"$temp\"<br>\n");
	($temp = $weekstarts) =~ y/<>/()/;
	print("weekstarts = \"$temp\"");
	print("</p>\n");
	print("<p>toparray::", join(":", @calendar), "::</p>\n");
	print("<p>subarray::", join(":", @{$calendar[1]}), "::</p>\n");
	tagclose("</td>");
	tagclose("</tr>");
}

#
# Functions for color space management.
#

# scalecolor() scales a color to the specified brightness percentage
sub scalecolor {
	my ($colorig, $colpct) = @_;
	my ($colscld, $colrat, $currat, $satpct);
	my (@crgb, $maxrat3, $maxrat6);

	# These represent the maximum combined brightness for each size of color.
	$maxrat3 =  15 +  15 +  15;
	$maxrat6 = 255 + 255 + 255;

	# The scaling must be a valid percentage of the max ratio.
	if ($colpct < 0)   { $colpct = 0; }
	if ($colpct > 100) { $colpct = 100; }

	# We deal in properly formed colors.
	if ($colorig =~ /^[[:xdigit:]]{3}/i) {
		$colorig = "#" . $colorig;
	}

	# Now the hard work of actually scaling the color.
	if ($colorig =~ /#[[:xdigit:]]{3}/) {
		# It's a color we should be able to scale...
		if ($colorig =~ /#[[:xdigit:]]{6}/) {
			$colrat = $maxrat6 * $colpct / 100;
			@crgb = ($colorig =~ /[[:xdigit:]]{2}/g);
		} else {
			$colrat = $maxrat3 * $colpct / 100;
			@crgb = ($colorig =~ /[[:xdigit:]]{1}/g);
		}
		map($_ = hex($_), @crgb);
		$currat = $crgb[0] + $crgb[1] + $crgb[2];
		# Select between reducing value(-ish) and increasing saturation.
		if ($currat > $colrat) {
			# Reduce value (not exactly value; I like this better).
			map($_ = int($_ * $colrat / $currat), @crgb);
			if ($colorig =~ /#[[:xdigit:]]{6}/) {
				$colscld = sprintf("#%02x%02x%02x", @crgb);
			} else {
				$colscld = sprintf("#%01x%01x%01x", @crgb);
			}
		} elsif ($currat < $colrat) {
			# Increase saturation.
			if ($colorig =~ /#[[:xdigit:]]{6}/) {
				$satpct = ($colrat - $currat) / ($maxrat6 - $currat);
				map($_ = int($_ + $satpct * (255 - $_)), @crgb);
				$colscld = sprintf("#%02x%02x%02x", @crgb);
			} else {
				$satpct = ($colrat - $currat) / ($maxrat3 - $currat);
				map($_ = int($_ + $satpct * (15 - $_)), @crgb);
				$colscld = sprintf("#%01x%01x%01x", @crgb);
			}
		} else {
			$colscld = $colorig;
		}
	} else {
		# We don't know how to deal with this color.  Ah, well.
		$colscld = $colorig;
	}

	$colscld;
}

#
# Functions for date discovery and manipulation.
#

# getcalendar() returns a a list of data needed to construct a one-month calendar
# The data returned is: [$ name hdr][@ week hdrs][$ 1st dy of wk][$ lst dy of mo]
sub getcalendar {
	my ($month) = @_;
	my ($year, @tm, @caldat, @adndat);
	$year = $month;

	# Find the numerical digits representing month and year.
	$month =  monthtonum($month);
	$year  =~ s/^\s*\S*\s*(\d+)\s*$/$1/;

	# This function uses the locale!
	use locale;

	# Find out the day-of-week name abbreviations (01/01/1978 was a Sunday).
	@tm = localtime(mktime(0, 0, 12, 1 + $weekstarts, 0, 78));
	for (my $counter = 0; $counter < 7; ++$counter) {
		push(@adndat, strftime("%a", @tm));
		++$tm[3];
		@tm = localtime(mktime(@tm));
	}
	$caldat[1] = \@adndat;

	# Create a time struct describing the first day of this month.
	@tm = (0, 0, 12, 1, $month, $year - 1900);
	@tm = localtime(mktime(@tm));

	# Find the localized long month name and decimal year for this month.
	$caldat[0] = strftime("%B %Y", @tm);

	# This would happen automatically at the end of this code block...
	no locale;

	# Determine the first day of the week for this month.
	$caldat[2] = ($tm[6] - $weekstarts) % 7;

	# Determine how many days long the month is.
	$tm[3] = 28;
	while ($tm[3] >= 28 && scalar(@tm)) {
		$caldat[3] = $tm[3];
		++$tm[3];
		@tm = localtime(mktime(@tm));
	}

	# @caldat is returned; format is:
	# [$ name hdr][@ week hdrs][$ 1st dy of wk][$ lst dy of mo]
	@caldat;
}

# monthtonum() converts the a month name to a number (0..11)
sub monthtonum {
	my ($monthname) = @_;
	my (%monthcon, $monthyear, $monthnum);

	# Currently we ignore the year value here...
	$monthyear = $monthname;
	$monthyear =~ s/^\s*\S*\s*(\d+)\s*$/$1/;

	# The month needs to become a number 0..11 now...
	$monthname =~ s/^\s*(\S+)\s*\d*\s*$/$1/;
	if ($monthname =~ /^\d+$/) {
		# If it's already a number, it will be in 1..12 so decrement it.
		$monthnum = ($monthname + 11) % 12;
	} else {
		# Otherwise, we'll do a hash lookup on the first three letters.
		%monthcon = (jan =>  0, feb =>  1, mar =>  2, apr =>  3,
			     may =>  4, jun =>  5, jul =>  6, aug =>  7,
			     sep =>  8, oct =>  9, nov => 10, dec => 11);
		$monthname =~ s/^\s*(.{3}).*$/\L$1\E/;
		$monthnum  =  0 + $monthcon{$monthname};
	}

	$monthnum;
}

# weektonum() converts a week day name to a number
sub weektonum {
	($weeknam) = @_;
	my (%weekcon, $weeknum);

	# The week needs to become a number 0..6 now...
	if ($weeknam =~ /^\s*\d+\s*$/) {
		# If it's already a number, it will be in 1..7 so decrement it.
		($weeknum = $weeknam) =~ s/^\s*(\d+)\s*$/$1/;
		$weeknum = ($weeknum + 6) % 7;
	} elsif ($weeknam =~ /^\s*[[:alpha:]]{3,}\s*$/) {
		# Otherwise, we'll do a hash lookup on the first three letters.
		%weekcon = (sun => 0, mon => 1, tue => 2, wed => 3, thu => 4, fri => 5, sat => 6);
		$weeknam =~ s/^\s*(.{3}).*$/\L$1\E/;
		$weeknum =  0 + $weekcon{$weeknam};
	} else {
		# If all else fails, Sunday!
		$weeknum = 0;
	}

		$weeknum;
}

#
# Functions for HTML stack management.
#

# tagopen() prints an html tag and winds it onto the stack
sub tagopen {
	my ($tago, $tagc) = @_;

	print("\n$tago\n");
	if ($tagc) {
		unshift(@htmlstack, $tagc);
	}
}

# tagclose() closes an html tag and unwinds it from the stack
sub tagclose {
	my ($tagv) = @_;
	my ($tagc);

	$tagc = shift(@htmlstack);
	if (!($tagv) || $tagv eq $tagc) {
		print("\n$tagc\n");
	} else {
		print("\n<!-- calendar.pl failed stack check! -->\n");
		unshift(@htmlstack, $tagc);
	}
}