#!/usr/local/bin/perl5
####################################################################
# Script:       | EventCalender ( Long Calendar View )             #
# Version:      | 1.6                                              #
# By:           | i2 Services, Inc. / CGI World                    #
# Contact:      | Contact@CGI-World.com                            #
# WWWeb:        | http://www.cgi-world.com                         #
# Copyright:    | CGI World of i2-Services, Inc.                   #
# Released:     | June 1st, 1998                                   #
# Updated:      | September 9th 2003                               #
####################################################################
# By using this software, you have agreed to the license           #
# agreement packaged with this program.                            #
#                                                                  #
####################################################################
# Done: 
#
# (Do not edit below this point, Violation of License Agreement)
####################################################################

$cgidir  = $0=~m#^(.*)[\\/]#?$1:(`pwd`=~/(.*)/)[0];	# script dir
$cgiurl  = (split("/",$ENV{'SCRIPT_NAME'}))[-1];	# script filename
$|++;						# Unbuffer output

$datadir = "$cgidir";
$filelock = "$datadir/filelock";

@month   = qw(January February March April May June July August September October November December);
@mon     = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@weekday = qw(Saturday Sunday Monday Tuesday Wednesday Thursday Friday);
@wday    = qw(Sat Sun Mon Tue Wed Thu Fri);

$one_day   = 60*60*24;		# One Day   (86400 sec)
$one_month = $one_day * 28;	# One Month (2419200 sec)
$one_year  = $one_day * 356;	# One Year  (30758400 sec)

($ctime{'d'},$ctime{'m'},$ctime{'y'}) = (localtime)[3..5];	# Current Day/month/year


$SIG{__DIE__} = sub {				# die signal handler
 print "Content-type: text/plain\n\n";
 print "@_";
 exit;
 };	

# ------------------------------------------------------------------------ 
# Main : Test conditions and give commands
# ------------------------------------------------------------------------ 

  %in = &ReadForm;				# Read CGI Form input

  if ($in{'m'} && $in{'y'} && !$in{'d'}) { $in{'d'} = 1; }

  &Template("$cgidir/_longcal.html");		# Load Templates
  &Cal;						# Create Calendar
  &GetDate;

  &List; 					# List Day Events

  print &Template("$cgidir/_longcal.html",'html');	# Print Template

  exit;

# ------------------------------------------------------------------------ 
# Get Date : Set right date for $d,$m,$y (day,month,year)
# ------------------------------------------------------------------------ 

sub GetDate {

  ($d,$m,$y) = ($in{'d'},$in{'m'},$in{'y'});		# Set Day,Month,Year

  # use current date values if date isn't specified
  if (!$y) { $y = $ctime{'y'} + 1900; } 		# year
  if (!$m) { $m = $ctime{'m'} +1; } 			# month
  if (!$d) { $d = $ctime{'d'}; }			# day

  # Check date input for invalid values
  if ($d < 1    || $d > 31   || $d != int $d)	{ die "Cal : Invalid day value '$d'\n"; }
  if ($m < 1    || $m > 12   || $m != int $m)	{ die "Cal : Invalid month value '$m'\n"; }
  if ($y < 1980 || $y > 2020 || $y != int $y)	{ die "Cal : Invalid year value '$y'\n"; }

  foreach ($m,$d) { $_ = sprintf("%02d",$_); }

}

# ------------------------------------------------------------------------ 
# List : List Events for the current day/month/year
# ------------------------------------------------------------------------ 

sub List {


  %dat = &LoadHash("$datadir/cal-$y-$m.dat.cgi",$filelock);	# Load Event data file

  foreach $key (sort MySort keys %dat) { 
    ($day2,$num,$name) = split(/\./,$key); 
    if ($day2 == $d && $name eq 'name') {
      $name  = $dat{"$d.$num.name"};
      $desc  = $dat{"$d.$num.desc"};
      $list .= &Cell('row');
      } 
    }

  unless ($list) { $list = &Cell('noevents'); }

}


sub MySort {

  ($day_a,$num_a,$name_a) = split(/\./,$a);
  ($day_b,$num_b,$name_b) = split(/\./,$b);

  $dat{"$day_a.$num_a.sort"} <=> $dat{"$day_b.$num_b.sort"} ||
  $dat{"$day_a.$num_a.name"} cmp $dat{"$day_b.$num_b.name"};
  
}



# ------------------------------------------------------------------------ 
# Cal : Create Calendar for user selected month and year
# ------------------------------------------------------------------------ 

sub Cal {

  ($d,$m,$y) = ($in{'d'},$in{'m'},$in{'y'});		# Set Day,Month,Year

  # use current date values if date isn't specified
  if (!$y)		{ $y = $ctime{'y'} } else { $y -= 1900 }	# year
  if (!$m)		{ $m = $ctime{'m'} } else { $m -= 1 }		# month
  if (!$d)		{ $d = $ctime{'d'} }				# day

  # Check date input for invalid values
  if ($d < 1  || $d > 31  || $d != int $d)	{ die "Cal : Invalid day value '$d'\n"; }
  if ($m < 0  || $m > 11  || $m != int $m)	{ die "Cal : Invalid month value '$m'\n"; }
  if ($y < 80 || $y > 120 || $y != int $y)	{ die "Cal : Invalid year value '$y'\n"; }

  # we need to get time in seconds of the date requested by the user.
  # just like the 'time' function gives us, so we'll take a copy of
  # the current time in seconds in $dtime and keep adding or subtracting
  # one year/month untill we get the year/month we want
  # $dtime is the current time in seconds since 1970, we'll modify this
  # to be the 'time' of our requested date so we can feed it to localtime

  $dtime = time;

  # If requested year is less than $dtime year minus one year from $dtime
  while ((localtime($dtime))[5]>$y) { $dtime -= $one_year;  }  

  # If requested month is less than $dtime month minus one month from $dtime
  while ((localtime($dtime))[4]>$m) { $dtime -= $one_month; }

  # If requested year is more than $dtime year add one year from $dtime
  while ((localtime($dtime))[5]<$y) { $dtime += $one_year;  }

  # If requested month is more than $dtime month add one month from $dtime
  while ((localtime($dtime))[4]<$m) { $dtime += $one_month; }

  # If requested month is less than $dtime month minus one month from $dtime
  while ((localtime($dtime))[4]>$m) { $dtime -= $one_month; }

  ($m,$y,$wd) = (localtime($dtime))[4..6];

  $day     = sprintf("%02d",$d);		# two digit day of month
  $dy      = int $d;			# one/two digit day of month
  $mon     = @mon[$m];				# Abbr month name
  $MON     = uc @mon[$m];			# Abbr month name uppercase
  $month   = @month[$m];			# Full month name
  $MONTH   = uc @month[$m];			# Full month name uppercase
  $year    = ($y+1900);				# four digit year
  $yr      = sprintf("%02d",$y>=100?$y-100:$y);	# two digit year

  $y = $year;					# Year var used in template
  $m = sprintf("%02d",$m+1);			# Month var used in template
  ${"m$m"."_selected"} = "selected";		# Select Month in pulldown menu
  ${"y$y"."_selected"} = "selected";		# Select Year in pulldown menu

  # Check which days of the month have events so we can make those days links
  %dat = &LoadHash("$datadir/cal-$y-$m.dat.cgi",$filelock);	# Load Event data file
  foreach $key (sort MySort keys %dat) {				# for record in month datafile
    my($day,$num,$name) = split(/\./,$key); 		# read record key
    if ($dat{"$day.$num.name"}) {			# if day has any events
      if ($name eq "name") {
        $day_int = int $day;
        $event_name{$day_int}    .= "<p>".$dat{"$day.$num.name"}."<br>";
        $event_content{$day_int} .= "<p><b>".$dat{"$day.$num.name"}."</b><br>";
        $event_content{$day_int} .= $dat{"$day.$num.desc"};
        }
      $day = 0+$day;
      $events{$day}++;					# give it a link in calendar
      } 
    }

  $ttime = $dtime;				# temp time var to count days in month
  while ((localtime($ttime))[3]>1) {		# While day of month is higher than one
    $ttime -= $one_day;				# minus one day from temp time var $ttime
    }
  $wpos  = (localtime($ttime))[6];		# weekday position, 1=Sun, 7=Sat
  $d     = 0;					# day of the month counter 

  ### Month days, count out the days in the month with $ttime var
  while ((localtime($ttime))[4] == (localtime($dtime))[4] ) {	# while we have days left in the month
    $ttime += $one_day;						# Add one day to temp time var
    $wpos++;							# Add one to weekday position
    $d++;							# Add one to day counter

    if ($d == $in{'d'} || (!$in{'d'} && $d == $ctime{'d'})) {	# If day is selected day
      $wd = (localtime($ttime))[6];				# Calculate current weekday for template
      $wday    = $wday[$wd];					# Abbr weekday name
      $WDAY    = uc $wday[$wd];					# Abbr weekday name uppercase
      $weekday = $weekday[$wd];					# Full weekday name
      $WEEKDAY = uc $weekday[$wd];				# Full weekday name uppercase

      $content = $event_content{$d};				# event name and content
#      $content = $event_name{$d};				# just event name

      if ($content) { $cal .= &Cell("day"); }			#
      }
    elsif ($events{$d}) {					# If Events on day, Add linked day

      $content = $event_content{$d};				# event name and content
#     $content = $event_name{$d};				# just event name

      if ($content) { $cal .= &Cell("day"); }
      }		
    }

  ### End of month, print out blank table cells from last day to the end of row
  if ($wpos && $wpos < 7) {					# if we don't have 7 days yet
    while ($wpos < 7) {						# while we don't have 7
     $cal .= &Cell("day_blank");				# add blank day cell
     $wpos++;							# add one to weekday position
     }
    $cal .= &Cell("row_end");					# end table row
  }

}

# ------------------------------------------------------------------------ 
# ReadForm : Read input from CGI form Perl Routine.  Parse input from a 
#            GET or POST form and return a hash of form names and values.
#
# Usage    : %in = &ReadForm; 
# ------------------------------------------------------------------------ 

sub ReadForm {

  my($max) = $_[1];					# Max Input Size
  my($name,$value,$pair,@pairs,$buffer,%hash);		# localize variables

  # Check input size if max input size is defined
  if ($max && ($ENV{'CONTENT_LENGTH'}||length $ENV{'QUERY_STRING'}) > $max) {
    die("ReadForm : Input exceeds max input limit of $max bytes\n");
    }

  # Read GET or POST form into $buffer
  if    ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); }
  elsif ($ENV{'REQUEST_METHOD'} eq 'GET')  { $buffer = $ENV{'QUERY_STRING'}; }

  @pairs = split(/&/, $buffer);				# Split into name/value pairs
  foreach $pair (@pairs) {				# foreach pair
    ($name, $value) = split(/=/, $pair);		# split into $name and $value
    $value =~ tr/+/ /;					# replace "+" with " "
    $value =~ s/%([A-F0-9]{2})/pack("C", hex($1))/egi;	# replace %hex with char
    $hash{$name} = $value;
    }

  return %hash;
  }

# ------------------------------------------------------------------------ 
# Valid Email : Check for valid email field
#
# usage       : if (&Valid_Email('dave@edis.org')) { ... }
#	      : returns 0=invalid 1=valid
# ------------------------------------------------------------------------ 

sub Valid_Email {

  my($email) = $_[0];
  my($user,$host) = split(/@/,$email);              # split into user @ host

  if ($email eq "")                                      { return 0; } # No email address  
  if ($email =~ /[^A-Za-z0-9-_\.\@]/)                    { return 0; } # Invalid characters
  if ($user !~ /^([\w-]+[\w-.])*[\w-]+$/)                { return 0; } # Invalid format
  if ($host !~ /^([\w-]+[\w-.])*[\w-]+\.[A-Za-z]{2,4}$/) { return 0; } # Invalid format

  return 1;

}

# ------------------------------------------------------------------------ 
# Template : Open a template file, translate variables and return contents
#
# usage    : print &Template("$cgidir/filename.html",'html');
# ------------------------------------------------------------------------ 

sub Template {  

  local(*FILE);

  if    ($_[1] eq 'html') { print "Content-type: text/html\n\n"  unless ($ContentType++ > 0); }
  elsif ($_[1] eq 'text') { print "Content-type: text/plain\n\n" unless ($ContentType++ > 0); }

  if    (!$_[0])	{ return "<br>\nTemplate : No file was specified<br>\n"; }
  elsif (!-e "$_[0]")	{ return "<br>\nTemplate : File '$_[0]' does not exist<br>\n"; }
  else {
    open(FILE, "<$_[0]") || return "<br>\nTemplate : Could open $_[0]<br>\n";
    while (<FILE>) { $FILE .= $_; }
    close(FILE);
    for ($FILE) {
      s/<!-- insert : (.*?) -->/\1/gi;				# show hidden inserts
      s/<!-- def : (\w+) -->(?:\r\n|\n)?(.*?)<!-- \/def : \1 -->/
	$CELL{$1}=$2;''/ges;					# read/remove template cells
      s/\$(\w+)\$/${$1}/g;					# translate $scalars$
      }
    }
  return $FILE;
}

# ------------------------------------------------------------------------ 
# Cell  : Return a template cell with translated variables.
#         Note: Before you can read a cell you need to load the template.
#
# usage : print &Cell("cellname");
# ------------------------------------------------------------------------ 

sub Cell {  

  my($CELL);
  for (0..$#_) { if ($_[$_]) { $CELL .= $CELL{$_[$_]}; }}

  if    (!$_[0]) { return "<br>\nCell : No cell was specified<br>\n"; }
  elsif (!$CELL) { return "<br>\nCell : Cell '$_[0]' is not defined<br>\n"; }
  else		 { $CELL =~ s/\$(\w+)\$/${$1}/g; }		# translate $scalars$
  
  return $CELL;

}


# ------------------------------------------------------------------------ 
# Append : Append some data to the end of a file
#
# usage  : &Append($file,$data);
# ------------------------------------------------------------------------ 

sub Append {

  local (*FILE);        # Localize filehandle
  my($file,$data) = @_;

  open(FILE,">>$file") || die ("Append : Can't append to $file : $!\n");
  print FILE $data;
  close(FILE);
}

# ----------------------------------------------------------------------------
# FileLock : File locking/unlocking Perl routines.
#
# Usage    : &FileLock("$lockdir");
#	   : &FileUnlock("$lockdir");
# ----------------------------------------------------------------------------

sub FileLock   {
  my($i);					# sleep counter
  while (!mkdir($_[0],0777)) {			# if there already is a lock
    sleep 1;					# sleep for 1 sec and try again
    if (++$i>60) { die("File_Lock : Can't create filelock : $!\n"); }		
    }
  }

sub FileUnlock {
  rmdir($_[0]);					# remove file lock dir
  }

# ------------------------------------------------------------------------ 
# Hash  : Perl routines for saving and loading a hash from a datafile
#
# usage : &SaveHash('hash',$filename);
#         %Hash = &LoadHash($filename);
#
#         &SaveHash('hash',$filename,$filelock);	# with file locking
#         %Hash = &LoadHash($filename,$filelock);	# with file locking
# ------------------------------------------------------------------------ 

sub SaveHash {

  local(*FILE);		# localize file handle
  my($hash) = $_[0];	# hash name
  my($file) = $_[1];	# Data file
  my($lockdir) = $_[2];	# File Lock Dir
  my($value);		# temp hash value var

  if ($lockdir) { &FileLock($lockdir); }

  open(FILE,">$file") || die ("SaveHash : Can't open $file : $!\n");

  print FILE qq|#!/usr/local/bin/perl\n|;
  print FILE qq|print "Content-type: text/plain\\n\\n";\n|;
  print FILE qq|print "This is a data file created with edis-lib.pl";\n|;
  print FILE qq|__END__\n|;

  foreach $key (sort keys %{$hash}) {
    $value = &URL_Encode($hash->{$key});
    print FILE "$key $value\n";
    }
  close(FILE);

  if ($lockdir) { &FileUnlock($lockdir); }

}

sub LoadHash {

  my($file) = $_[0];	# Data file
  my(@lines,$name,$value,%hash);

  if ($lockdir) { &FileLock($lockdir); }

  open(FILE,"<$file");				# Load in Data file
  while (<FILE>) { if (/__END__/) { last }}	# Skip Perl header
  @lines = <FILE>;
  close(FILE);

  if ($lockdir) { &FileUnlock($lockdir); }

  foreach $line (@lines) {
    ($name,$value) = split(/ /,$line);
    chomp $value; 				# remove trailing nextline
    $hash{$name} = &URL_Decode($value);
    }

  return %hash;
}


# ------------------------------------------------------------------------ 
# Log    : Make a dated entry in a log file
#
# usage  : &Append($file,$data);
# ------------------------------------------------------------------------ 

sub Log {

  local (*FILE);        # Localize filehandle
  my($file,$data) = @_;
  my $datetime       = localtime(time);

  open(FILE,">>$file") || die ("Log : Can't append to $file : $!\n");
  print FILE "[$datetime] $data\n";
  close(FILE);
}


# ------------------------------------------------------------------------ 
# Tail  : Read last few lines from a text file
#
# usage : $lines = $Tail($file,20);
# ------------------------------------------------------------------------ 

sub Tail {

  local (*FILE);             # Localize filehandle
  my($file)  = $_[0];        # File to read 
  my($lines) = $_[1] || 10;  # Lines to read in
  my($buffer,@lines);

  $buffer = $lines*80;       # How much to read in

  open(FILE,"<$file") || die ("Tail : Can't open $file : $!\n");
 
  ### Read lines from file

  while (@lines < $lines) {       # while lines read < lines requested
    if ($buffer >= -s FILE) {     # if buffer >= file size
      seek(FILE,0,0);             # go to start of file
      @lines = <FILE>;            # read all lines into @lines
      last;                       # and exit this while loop
      }  
    else {                        # else if buffer isn't >= file size
      seek(FILE,-$buffer,2);      # read in buffer size from end of file
      ($_,@lines) = <FILE>;       # break that up into full lines
      $buffer += 80;              # up buffer in case we need another loop
      }
    }
  close(FILE);

  ### Return right number of lines
  
  # unless there is less lines than requested shorten array
  unless (@lines < $lines) { @lines = @lines[($#lines-$lines+1)..$#lines]; }

  return @lines;
}


# ----------------------------------------------------------------------------
# MIME64 : MIME64 encoding/decoding Perl routines.  MIME64 is a common base64
#          encoding scheme documented in RFC1341, section 5.2.
#
# Usage  : $mime64_text = &MIME64_Encode("$plaintext");
#	 : $plaintext   = &MIME64_Decode("$mime64_text");
# ----------------------------------------------------------------------------

sub MIME64_Encode {    
  my($in)  = $_[0];					# text to encode
  my(@b64) = ((A..Z,a..z,0..9),'+','/');		# Base 64 char set to use
  my($out) = unpack("B*",$in);				# Convert to binary
  $out=~ s/(\d{6}|\d+$)/$b64[ord(pack"B*","00$1")]/ge;	# convert 3 bytes to 4
  while (length($out)%4) { $out .= "="; }		# Pad string with '='
  return $out;						# Return encoded text
  }

sub MIME64_Decode {
  my($in)  = $_[0];					# encoded text to decode
  my(%b64);						# Base 64 char set hash
  my($out);						# decoded text variable
  for((A..Z,a..z,0..9),'+','/'){ $b64{$_} = $i++ }	# Base 64 char set to use
  $in = $_[0] || return "MIME64 : Nothing to decode";	# Get input or return
  $in =~ s/[^A-Za-z0-9+\/]//g;				# Remove invalid chars
  $in =~ s/[A-Za-z0-9+\/]/unpack"B*",chr($b64{$&})/ge;	# b64 offset val -> bin
  $in =~ s/\d\d(\d{6})/$1/g;				# Convert 8 bits to 6
  $in =~ s/\d{8}/$out.=pack("B*",$&)/ge;		# Convert bin to text
  return $out;						# Return decoded text
  }


# ----------------------------------------------------------------------------
# URL    : URL encoding/decoding Perl routines.  URL encoding is an common 
#          encoding scheme where non A-Za-z0-9+*.@_- characters are replaced
#          with a character triplet of "%" followed by the two hex digits.
#
# Usage  : $URL_encoded = &URL_Encode("$plaintext");
#	 : $plaintext   = &URL_Decode("$URL_encoded");
# ----------------------------------------------------------------------------

sub URL_Encode {
  my($text)  = $_[0];					# text to URL encode
  $text =~ tr/ /+/;					# replace " " with "+"
  $text =~ s/[^A-Za-z0-9\+\*\.\@\_\-]/			# replace odd chars
             uc sprintf("%%%02x",ord($&))/egx;		#   with %hex value
  return $text;						# return URL encoded text
  }

sub URL_Decode {
  my($text)  = $_[0];					# URL encoded text to decode
  $text =~ tr/+/ /;					# replace "+" with " "
  $text =~ s/%([A-F0-9]{2})/pack("C", hex($1))/egi;	# replace %hex with chars
  return $text;						# return decoded plain text
  }


# ----------------------------------------------------------------------------
# Cookie : Perl routines for setting/reading browser cookies.
#        : Cookies have a max size of 4k and each host can send up to 20.
#
# Usage  : &SetCookie("name","value");
#        : %cookie = &ReadCookie;
# ----------------------------------------------------------------------------

sub SetCookie {

  my($cookie_info);
  my($name,$value,$exp,$path,$domain,$secure) = @_;

  # $name 	- cookie name (ie: username)
  # $value	- cookie value (ie: "joe user")
  # $exp	- exp date, cookie will be deleted at this date. Format: Wdy, DD-Mon-YYYY HH:MM:SS GMT
  # $path	- Cookie is sent only when this path is accessed   (ie: /);
  # $domain	- Cookie is sent only when this domain is accessed (ie: .edis.org)
  # $secure	- Cookie is sent only with secure https connection

  unless (defined $name) { die("SetCookie : Cookie name must be specified\n"); }
  if ($exp && $exp !~ /^[A-Z]{3}, \d\d-[A-Z]{3}-\d{4} \d\d:\d\d:\d\d GMT$/i) { die("SetCookie : Exp Dat format isn't: Wdy, DD-Mon-YYYY HH:MM:SS GMT\n"); }

  if ($name)		{ $name  = &URL_Encode($name); }
  if ($value)		{ $value = &URL_Encode($value); }
  if ($exp)		{ $cookie_info .= "expires=$exp; "; }
  if ($path)		{ $cookie_info .= "path=$path; "; }
  if ($domain)		{ $cookie_info .= "domain=$domain; "; }
  if ($secure)		{ $cookie_info .= "secure; "; }

  print "Set-Cookie: $name=$value; $cookie_info\n";

  }

sub ReadCookie {

  my($cookie,$name,$value,%jar);

  foreach $cookie (split(/; /,$ENV{'HTTP_COOKIE'})) {		# for each cookie sent
    ($name,$value) = split(/=/,$cookie);			# split into name/value
    foreach($name,$value) { $_ = &URL_Decode($_); }		# URL decode strings
    $jar{$name}=$value;						# and put into %jar hash
    }

   return %jar;							# return %jar hash

}


# ----------------------------------------------------------------------------
# ENV      : print out Enviroment variables
#
# Usage    : &ENV;		# print ENV vars
# ----------------------------------------------------------------------------

sub ENV {

  &PrintHash('ENV');
  }


# ----------------------------------------------------------------------------
# PrintHash : print out hash key/value pairs
#
# Usage     : &PrintHash('ENV');
# ----------------------------------------------------------------------------

sub PrintHash {

  my($HASH) = $_[0];
  foreach $key (sort keys %{$HASH}) { print "$key = $HASH->{$key}<br>\n"; }
  }

# ----------------------------------------------------------------------------
# ExecTime : Return time the program has been running.
#
# Usage    : $secs         = &ExecTime;
# ----------------------------------------------------------------------------

sub ExecTime {
  
  my($exectime) = time - $^T;				# exectime in seconds
  my($mins)  = int($exectime/60);
  my($secs)  = sprintf("%02d",$exectime%60);
  return ($secs,$mins,$exectime);

  }