lreminder: initial commit

1 files changed, 271 insertions, 0 deletions

diff --git a/lreminder/reminder.pl b/lreminder/reminder.pl
new file mode 100755
index 0000000..aa0bc9e
--- /dev/null
+++ b/lreminder/reminder.pl
@@ -0,0 +1,271 @@
+#!/usr/bin/perl
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+#
+# Author: Steven Schubiger <stsc@refcnt.org>
+# Last modified: Thu Jan 31 11:12:22 CET 2013
+
+use strict;
+use warnings;
+use lib qw(lib);
+use constant true  => 1;
+use constant false => 0;
+
+use DBI ();
+use File::Basename ();
+use File::Spec ();
+use FindBin qw($Bin);
+use Getopt::Long qw(:config no_auto_abbrev no_ignore_case);
+use Hook::Output::File ();
+use LUGS::Events::Parser ();
+use Mail::Sendmail qw(sendmail);
+use Text::Wrap::Smart::XS qw(fuzzy_wrap);
+use WWW::Mechanize ();
+
+my $VERSION = '0.41';
+
+#-----------------------
+# Start of configuration
+#-----------------------
+
+my $Config = {
+    events_url => 'http://www.lugs.ch/lugs/termine/termine.txt',
+    form_url   => 'http://lists.lugs.ch/reminder.cgi',
+    mail_from  => 'reminder@lugs.ch',
+    dbase_name => '<hidden>',
+    dbase_user => '<hidden>',
+    dbase_pass => '<hidden>',
+};
+
+#---------------------
+# End of configuration
+#---------------------
+
+my $dbh  = DBI->connect("dbi:mysql(RaiseError=>1):$Config->{dbase_name}", $Config->{dbase_user}, $Config->{dbase_pass});
+my $file = File::Basename::basename($Config->{events_url});
+
+my ($test, $run) = (false, false);
+
+{
+    getopts(\$test, \$run);
+    my $hook = Hook::Output::File->redirect(
+        stdout => File::Spec->catfile($Bin, 'stdout.out'),
+        stderr => File::Spec->catfile($Bin, 'stderr.out'),
+    );
+    fetch_and_write_events();
+    process_events();
+}
+
+sub getopts
+{
+    my ($test, $run) = @_;
+
+    GetOptions(test => $test, run => $run) or exit;
+
+    if (not $$test || $$run) {
+        die "$0: neither --test nor --run specified, exiting\n";
+    }
+    elsif ($$test && $$run) {
+        die "$0: both --test and --run specified, exiting\n";
+    }
+    return; # --test or --run specified
+}
+
+sub fetch_and_write_events
+{
+    my $mech = WWW::Mechanize->new;
+    my $http = $mech->get($Config->{events_url});
+
+    open(my $fh, '>', $file) or die "Cannot open $file: $!\n";
+    print {$fh} $http->content;
+    close($fh);
+}
+
+sub init
+{
+    my ($parser, $month_days, $current) = @_;
+
+    $$parser = LUGS::Events::Parser->new($file, {
+        filter_html  => true,
+        tag_handlers => {
+            'a href' => [ {
+                rewrite => '$TEXT - <$HREF>',
+                fields  => [ qw(responsible) ],
+            }, {
+                rewrite => '$TEXT - $HREF',
+                fields  => [ qw(location more) ],
+            } ],
+            'br' => [ {
+                rewrite => '',
+                fields  => [ qw(more) ],
+            } ],
+        },
+        strip_text => [ 'mailto:' ],
+    });
+    unlink $file;
+
+    %$month_days = (
+        1 => 31,   7 => 31,
+        2 => 28,   8 => 31,
+        3 => 31,   9 => 30,
+        4 => 30,  10 => 31,
+        5 => 31,  11 => 30,
+        6 => 30,  12 => 31,
+    );
+
+    %$current = do {
+        my @time = (localtime)[3..5];
+        $time[1]++;
+        $time[2] += 1900;
+        map { $_ => shift @time } qw(day month year);
+    };
+}
+
+sub process_events
+{
+    my   ($parser,  %month_days,  %current);
+    init(\$parser, \%month_days, \%current);
+
+    while (my $event = $parser->next_event) {
+        my %event = (
+            year  => $event->get_event_year,
+            month => $event->get_event_month,
+            day   => $event->get_event_day,
+            color => $event->get_event_color,
+        );
+
+        my %sth;
+
+        $sth{subscribers} = $dbh->prepare('SELECT mail, mode, notify FROM subscribers');
+        $sth{subscribers}->execute;
+
+        while (my $subscriber = $sth{subscribers}->fetchrow_hashref) {
+            next unless $subscriber->{mode} == 2;
+
+            $sth{subscriptions} = $dbh->prepare('SELECT * FROM subscriptions WHERE mail = ?');
+            $sth{subscriptions}->execute($subscriber->{mail});
+
+            my $subscriptions = $sth{subscriptions}->fetchrow_hashref;
+            next unless $subscriptions->{$event{color}};
+
+            my %notify = %current;
+
+            $subscriber->{notify} ||= 0;
+
+            my $day = $current{day} + $subscriber->{notify};
+            my $days_in_month = $month_days{$current{month}};
+
+            if ($day > $days_in_month) {
+                $notify{day} = $day - $days_in_month;
+                $notify{month}++;
+            }
+            else {
+                $notify{day} += $subscriber->{notify};
+            }
+
+            if ($event{year}  == $notify{year}
+             && $event{month} == $notify{month}
+             && $event{day}   == $notify{day}
+            ) {
+                send_mail($event, $subscriber->{mail});
+            }
+        }
+    }
+}
+
+sub send_mail
+{
+    my ($event, $mail_subscriber) = @_;
+
+    my $year        = $event->get_event_year;
+    my $month       = $event->get_event_month;
+    my $simple_day  = $event->get_event_simple_day;
+    my $wday        = $event->get_event_weekday;
+    my $time        = $event->get_event_time;
+    my $title       = $event->get_event_title;
+    my $color       = $event->get_event_color;
+    my $location    = $event->get_event_location;
+    my $responsible = $event->get_event_responsible;
+    my $more        = $event->get_event_more || '';
+
+    wrap_text(\$more);
+    chomp $more;
+    wrap_text(\$location);
+
+    my $i;
+    my %month_names = map { sprintf('%02d', ++$i) => $_ }
+      qw(Januar Februar Maerz April Mai Juni Juli August
+         September Oktober November Dezember);
+
+    my $month_name = $month_names{$month};
+
+my $message = (<<MSG);
+Wann:\t$wday, $simple_day. $month_name $year, $time Uhr
+Was :\t$title
+Wo  :\t$location
+Wer :\t$responsible
+Info:\t$more
+
+Web Interface:
+$Config->{form_url}
+
+${\info_string()}
+MSG
+
+    if ($run) {
+        sendmail(
+            From    => $Config->{mail_from},
+            To      => $mail_subscriber,
+            Subject => "LUGS Reminder - $title",
+            Message => $message,
+        ) or die $Mail::Sendmail::error;
+    }
+    elsif ($test) {
+        printf "[%s] <$mail_subscriber> ($color)\n", scalar localtime;
+    }
+}
+
+sub wrap_text
+{
+    my ($text) = @_;
+
+    return unless length $$text;
+
+    my @chunks = fuzzy_wrap($$text, 70);
+
+    my $wrapped;
+    foreach my $chunk (@chunks) {
+        $wrapped .= ' ' x (defined $wrapped ? 8 : 0);
+        $wrapped .= "$chunk\n";
+    }
+    chomp $wrapped;
+
+    $$text = $wrapped;
+}
+
+sub info_string
+{
+    my $script = File::Basename::basename($0);
+    my $modified = localtime((stat($0))[9]);
+
+    $modified =~ s/(?<=\b) (?:\d{2}\:?){3} (?=\b)//x;
+    $modified =~ s/\s+/ /g;
+
+    my $info = <<EOT;
+-- 
+running $script v$VERSION - last modified: $modified
+EOT
+    return do { local $_ = $info; chomp while /\n$/; $_ };
+}