#!/usr/bin/env perl

# Copyright (C) 2005 Shingo W. Kagami.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

# 2005.07.18 by swk

# TODO
# - Cond の month
# - Cond の day of month
# - Cond の week of month の「last」
# - 複数行に渡るヘッダの処理
# - 同じヘッダが複数回出て来た場合の扱い (必要性?)

use strict;
use Time::Local;
use Getopt::Std;

# options
my %opts;
getopts('vs:d:', \%opts);

# defaults
my $src_dir = $opts{s} || "/home/swk/Mail/schedule";
my $dest_dir = $opts{d} || "/home/swk/Mail/schedule_unrolled";
my $opt_verbose = $opts{v}? 1: 0;

# constants and globals
my %wday = (mon => 1, tue => 2, wed => 3, thu => 4,
	   fri => 5, sat => 6, sun => 0);
my %mweek = ('1st' => 1, '2nd' => 2, '3rd' => 3,
	   '4th' => 4, '5th' => 5); # 'last' not supported yet
my %newest_mail_file = ();
my $intsect_dir = "$dest_dir/intersect";


# main
if (-f "$dest_dir/.ol_sync") {
    system("cp -p $dest_dir/.ol_sync $src_dir/.ol_sync_unrolled");
}
my $rsync_verbose = $opt_verbose? 'vv': '';
system("rsync -a$rsync_verbose --delete --exclude 'trash/' $src_dir/ $dest_dir/");
if (-f "$src_dir/.ol_sync_unrolled") {
    system("cp -p $src_dir/.ol_sync_unrolled $dest_dir/.ol_sync");
}

my @imsg = &list_intsect_msg($intsect_dir);
&verbose("@imsg\n");

foreach my $src (@imsg) {
    my (%date_header) = &get_header("$intsect_dir/$src",
				    'X-SC-Day', 'X-SC-Cond', 'X-SC-Duration');

    &verbose("================= msg: $src ===============\n");
    &verbose("h_day: $date_header{'X-SC-Day'}\n");
    &verbose("h_cond: $date_header{'X-SC-Cond'}\n");
    &verbose("h_duration: $date_header{'X-SC-Duration'}\n");

    my @unrolled_days = &list_unrolled_days(%date_header);
    if (@unrolled_days) {
	&verbose("unrolled: ", join(' ', @unrolled_days), "\n");
	&unroll_msg("$intsect_dir/$src", $dest_dir, @unrolled_days);

	&verbose("remove $intsect_dir/$src\n");
	system("rm $intsect_dir/$src");
    }
}


sub list_unrolled_days # XXX: adhoc
{
    my (%date_header) = @_;
    my ($h_day, $h_cond, $h_duration)
	= ($date_header{'X-SC-Day'},
	   $date_header{'X-SC-Cond'},
	   $date_header{'X-SC-Duration'});

    my ($dur_start, $dur_end, $dur_start_ym, $dur_end_ym);
    my (@wday_list) = ();
    my (@mweek_list) = ();
    my (@day_list) = ();
    my (@unrolled_list) = ();
    my (%exclude_hash) = ();

    if ($h_duration =~ /^\s*(\d{8})-(\d{8})\s*$/) {
	$dur_start = $1;
	$dur_end = $2;
	$dur_start_ym = &get_ym($dur_start);
	$dur_end_ym = &get_ym($dur_end);
    } else {
	&verbose("ignored because: h_duration = $h_duration\n");
	return ();
    }

    foreach (split(/\s+/, $h_cond)) {
	$_ =~ tr/A-Z/a-z/;
	if (defined($wday{$_})) {
	    push(@wday_list, $wday{$_});
	} elsif (defined($mweek{$_})) {
	    push(@mweek_list, $mweek{$_});
	} else {
	    &verbose("ignored because: h_cond has $_\n");
	    return ();
	}
    }

    foreach (split(/\s+/, $h_day)) {
	if (/^!(\d{8})$/) {
	    $exclude_hash{$1} = 1;
	} elsif (/^\d{8}$/) {
	    push(@day_list, $_);
	} else {
	    &verbose("ignored because: h_day has $_\n");
	    return ();
	}
    }

    # mweek_list が空 → 毎週
    unless (@mweek_list) {
	@mweek_list = (1, 2, 3, 4, 5);
    }

    # duration の最初の月から最後の月まで繰り返す:
     # wday と mweek の直積集合を生成し，@unrolled_list に push する
    for (my $ym = $dur_start_ym; $ym <= $dur_end_ym; $ym = &next_ym($ym)) {
	foreach my $w (@wday_list) {
	    foreach my $n (@mweek_list) {
		my $x = &get_nth_wday($w, $ym, $n);
		my $d = sprintf("%s%02d", $ym, $x);
		if ($x != 0 && $d >= $dur_start && $d <= $dur_end
		    && !defined($exclude_hash{$d})) {
		    push(@unrolled_list, $d);
		}
	    }
	}
    }

    return sort (@unrolled_list, @day_list);
}

sub get_nth_wday
{
    my ($wday, $ym, $n) = @_;

    my $wday1 = &get_wday_of_1st($ym);
    my $lastday = &get_last_mday($ym);

    my $ret = 1 + (($wday - $wday1 + 7) % 7) + 7 * ($n - 1);

    if ($ret > $lastday) {
	return 0;
    } else {
	return $ret;
    }
}

sub get_wday_of_1st
{
    my ($ym) = @_;

    $ym =~ /^(\d{4})0?(\d{1,2})$/;
    my ($y, $m) = ($1, $2);
    
    return (localtime timelocal(0, 0, 0, 1, $m - 1, $y - 1900))[6];
}

sub get_last_mday
{
    my ($ym) = @_;

    $ym =~ /^(\d{4})0?(\d{1,2})$/;
    my ($y, $m) = ($1, $2);
    
    if ($m == 2) {
	return ((($y % 4 == 0) && ($y % 100 != 0)) || ($y % 400 == 0))? 29: 28;
    } else {
	return (31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[$m - 1];
    }
}

sub get_year
{
    my ($ymd) = @_;

    $ymd =~ /^!?(\d{4})\d{4}/;

    return int($ymd / 10000);
}

sub get_month
{
    my ($ymd) = @_;

    return int($ymd / 100) % 100;
}

sub get_day
{
    my ($ymd) = @_;

    return $ymd % 100;
}

sub get_ym
{
    my ($ymd) = @_;

    return int($ymd / 100);
}

sub next_ym
{
    my ($ym) = @_;

    if ($ym % 100 == 12) {
	return $ym + (100 - 11);
    } else {
	return $ym + 1;
    }
}

sub list_intsect_msg
{
    my ($idir) = @_;
    my @intsect_msg = ();
    
    while (<$idir/*>) {
	$_ =~ s/^.*\///;
	next unless /^(\d+)$/;
	push(@intsect_msg, $_);
    }
    @intsect_msg = sort by_num @intsect_msg;

    return @intsect_msg;
}

sub by_num { $a <=> $b; }

sub unroll_msg
{
    my ($src_file, $dest_dir, @unrolled_days) = @_;
    my $msg = &read_whole_file("$src_file");
    
    # XXX: multiple lines are ignored
    # XXX: duplicated occurrence of a header is ignored
    $msg =~ s/^X-SC-Cond:[ \t]*(.*)$/X-SC-Cond: /mi;
    $msg =~ s/^X-SC-Duration:[ \t]*(.*)$/X-SC-Duration: /mi;

    foreach my $d (@unrolled_days) {
	$msg =~ s/^X-SC-Day:[ \t]*(.*)$/X-SC-Day: $d/mi;	
	&put_msg($msg, $dest_dir, $d);
    }
}

sub get_header
{
    my ($msg_file, @headers) = @_;
    my @tmp;
    my %date_header = ();
    my $msg = &read_whole_file($msg_file);

    # XXX: multiple lines are ignored
    # XXX: duplicated occurrence of a header is ignored
    foreach my $h (@headers) {
	$msg =~ /^$h:[ \t]*(.*)$/mi;
	$date_header{$h} = $1;
    }

    return %date_header;
}

sub read_whole_file
{
    my ($f) = @_;
    my $cont;
    my @tmp;

    open(FILE_READ, $f) or die "can't open $f";
    $cont = join('', @tmp = <FILE_READ>);
    close(FILE_READ);

    return $cont;
}

sub put_msg
{
    my ($msg, $dest_dir, $d) = @_;

    my $y = &get_year($d);
    my $m = &get_month($d);
    my $ydir = sprintf("$dest_dir/%04d", $y);
    my $mdir = sprintf("$ydir/%02d", $m);

    if (!-d $ydir) {
	mkdir($ydir, 0755) or die "can't mkdir: $ydir\n";
    }
    if (!-d $mdir) {
	mkdir($mdir, 0755) or die "can't mkdir: $mdir\n";
    }

    my $mail_file = &get_newest_mail_file($mdir) + 1;

    &verbose("write to: $mdir/$mail_file\n");
    open(WRITE, "> $mdir/$mail_file") or die "can't open: $mdir/$mail_file";
    print WRITE $msg;
    close(WRITE);

    $newest_mail_file{$mdir} = $mail_file;
}

sub get_newest_mail_file
{
    my ($mdir) = @_;

    if (defined($newest_mail_file{$mdir})) {
	return $newest_mail_file{$mdir};
    } else {
	my $max = 0;
	while (<$mdir/*>) {
	    $_ =~ s/^.*\///;
	    next unless /^\d+$/;
	    $max = $_ if $max < $_;
	}
	return $max;
    }
}

sub verbose
{
    my ($str) = @_;

    if ($opt_verbose) {
	print STDERR $str;
    }
}