diff options
| -rwxr-xr-x | lreminder/reminder.pl | 271 |
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$/; $_ }; +} |