]>
git.refcnt.org Git - lugs.git/blob - lreminder/reminder.pl
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with this program; if not, write to the Free Software
15 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
17 # Author: Steven Schubiger <stsc@refcnt.org>
18 # Last modified: Wed 09 Jun 2021 01:19:17 PM CEST
23 use constant true
=> 1;
24 use constant false
=> 0;
28 use Encode
qw(decode encode);
29 use File
::Basename
();
32 use Getopt::Long qw(:config no_auto_abbrev no_ignore_case);
33 use Hook
::Output
::File
();
34 use LUGS
::Events
::Parser
();
35 use Mail
::Sendmail
qw(sendmail);
36 use Text
::Wrap
::Smart
::XS
qw(fuzzy_wrap);
38 use WWW
::Mechanize
();
42 #-----------------------
43 # Start of configuration
44 #-----------------------
47 events_url
=> 'http://www.lugs.ch/lugs/termine/termine.txt',
48 form_url
=> 'http://lists.lugs.ch/reminder.cgi',
49 mail_from
=> 'reminder@lugs.ch',
50 mail_admin
=> 'stsc@refcnt.org',
51 dbase_name
=> '<hidden>',
52 dbase_user
=> '<hidden>',
53 dbase_pass
=> '<hidden>',
58 #---------------------
59 # End of configuration
60 #---------------------
62 my $dbh = DBI
->connect("dbi:mysql(RaiseError=>1):$Config->{dbase_name}", $Config->{dbase_user
}, $Config->{dbase_pass
});
63 my $file = File
::Spec
->catfile('tmp', (URI
->new($Config->{events_url
})->path_segments)[-1]);
65 my ($test, $run) = (false
, false
);
68 getopts
(\
$test, \
$run);
69 my $hook = Hook
::Output
::File
->redirect(
70 stdout
=> File
::Spec
->catfile($Bin, 'stdout.out'),
71 stderr
=> File
::Spec
->catfile($Bin, 'stderr.out'),
73 fetch_and_write_events
();
79 my ($test, $run) = @_;
81 GetOptions
(test
=> $test, run
=> $run) or exit;
83 if (not $$test || $$run) {
84 die "$0: neither --test nor --run specified, exiting\n";
86 elsif ($$test && $$run) {
87 die "$0: both --test and --run specified, exiting\n";
89 return; # --test or --run specified
92 sub fetch_and_write_events
94 my $mech = WWW
::Mechanize
->new;
96 my ($http, $retry, $tries);
103 $http = $mech->get($Config->{events_url
});
105 warn "[${\scalar localtime}] $@";
106 $retry = ($tries < $Config->{max_tries
}) ? true
: false
;
107 sleep $Config->{sleep_secs
} if $retry;
112 open(my $fh, '>', $file) or die "Cannot open $file for writing: $!\n";
113 print {$fh} $http->content;
117 my $script = File
::Basename
::basename
($0);
118 warn "[${\scalar localtime}] $script not entirely run, no http content\n";
119 my $message = <<"MSG";
122 This is lreminder [<$Config->{mail_from}>].
124 Could not run $script entirely, no http content.
125 Please re-run manually with `$0 --run' today.
130 From
=> $Config->{mail_from
},
131 To
=> $Config->{mail_admin
},
132 Subject
=> 'LUGS Reminder - warning: timeout',
134 ) or die "Cannot send mail: $Mail::Sendmail::error";
143 $$parser = LUGS
::Events
::Parser
->new($file, {
147 rewrite
=> '$TEXT - <$HREF>',
148 fields
=> [ qw(responsible) ],
150 rewrite
=> '$TEXT - $HREF',
151 fields
=> [ qw(location more) ],
154 purge_tags
=> [ qw(location responsible more) ],
155 strip_text
=> [ 'mailto:' ],
165 while (my $event = $parser->next_event) {
167 year
=> $event->get_event_year,
168 month
=> $event->get_event_month,
169 day
=> $event->get_event_day,
170 color
=> $event->get_event_color,
175 $sth{subscribers
} = $dbh->prepare('SELECT mail, mode, notify FROM subscribers');
176 $sth{subscribers
}->execute;
178 while (my $subscriber = $sth{subscribers
}->fetchrow_hashref) {
179 next unless $subscriber->{mode
} == 2;
181 $sth{subscriptions
} = $dbh->prepare('SELECT * FROM subscriptions WHERE mail = ?');
182 $sth{subscriptions
}->execute($subscriber->{mail
});
184 my $subscriptions = $sth{subscriptions
}->fetchrow_hashref;
185 next unless $subscriptions->{$event{color
}};
187 my $notify = DateTime
->now(time_zone
=> 'Europe/Zurich');
189 $subscriber->{notify
} ||= 0;
191 $notify->add(days
=> $subscriber->{notify
});
193 if ($event{year
} == $notify->year
194 && $event{month
} == $notify->month
195 && $event{day
} == $notify->day
197 send_mail
($event, $subscriber->{mail
});
205 my ($event, $mail_subscriber) = @_;
207 my $year = $event->get_event_year;
208 my $month = $event->get_event_month;
209 my $simple_day = $event->get_event_simple_day;
210 my $wday = $event->get_event_weekday;
211 my $time = $event->get_event_time;
212 my $title = $event->get_event_title;
213 my $color = $event->get_event_color;
214 my $location = $event->get_event_location;
215 my $responsible = $event->get_event_responsible;
216 my $more = $event->get_event_more || '';
220 wrap_text
(\
$location);
223 my %month_names = map { sprintf('%02d', ++$i) => $_ }
224 qw(Januar Februar Maerz April Mai Juni Juli August
225 September Oktober November Dezember);
227 my $month_name = $month_names{$month};
229 my $message = (<<"MSG");
230 Wann:\t$wday, $simple_day. $month_name $year, $time Uhr
243 $title = decode
('UTF-8', $title);
245 From
=> $Config->{mail_from
},
246 To
=> $mail_subscriber,
247 Subject
=> encode
('MIME-Q', "LUGS Reminder - $title"),
249 'Content-Type' => 'text/plain; charset="UTF-8"',
250 ) or die "Cannot send mail: $Mail::Sendmail::error";
253 printf "[%s] <$mail_subscriber> ($color)\n", scalar localtime;
261 return unless length $$text;
263 my @chunks = fuzzy_wrap
($$text, 70);
266 foreach my $chunk (@chunks) {
267 $wrapped .= ' ' x
(defined $wrapped ?
8 : 0);
268 $wrapped .= "$chunk\n";
277 my $script = File
::Basename
::basename
($0);
278 my $modified = localtime((stat($0))[9]);
280 $modified =~ s/(?<=\b) (?:\d{2}\:?){3} (?=\b)//x;
281 $modified =~ s/\s{2,}/ /g;
285 running $script v$VERSION - last modified: $modified
287 return do { local $_ = $info; chomp while /\n$/; $_ };