~~META: status = active &relation firstimage = :project:administrativa.jpg ~~
brmlab existence involves some mundane adminsitrativa tasks, mainly tracking of membership fees and donations. So far, this is done manually and there result is a lot of laborous work and a lot of chaos.
Therefore, some simple software tool would do us a lot of good. It should:
#!/usr/bin/perl # Copyright 2012 TMA # License: GNU GPL version 2 use strict; use warnings; use utf8; my $status = 'endmail'; my ($fio,$konto,$castka,$VS,$SS,$zprava,$protiucet,$date); my ($header, $body); my $mul; sub vreset() { ($header,$body) = ('',''); ($fio,$konto,$castka,$VS,$SS,$zprava,$protiucet,$date) = undef; } sub process($) { $status = $_[0]; no warnings; $date =~ s/ +\d+:\d+:\d+ +[+-]\d{4}$//o; $date =~ s/^..., *(\d+) (...|\d+) (\d\d\d\d).*/$3-$2-$1/o; $date =~ s/Jan/01/o; $date =~ s/Feb/02/o; $date =~ s/Mar/03/o; $date =~ s/Apr/04/o; $date =~ s/May/05/o; $date =~ s/Jun/06/o; $date =~ s/Jul/07/o; $date =~ s/Aug/08/o; $date =~ s/Sep/09/o; $date =~ s/Oct/10/o; $date =~ s/Nov/11/o; $date =~ s/Dec/12/o; $date =~ s/ /0/o; $date =~ s/-(\d)-/-0$1-/o; $date =~ s/-(\d)$/-0$1/o; print "-- $ARGV $.\n"; print "insert into ucetni_data (konto, castka, datum, VS, SS, protiucet, zprava, comment) values ($konto, $castka", commanullq($date), commanull($VS), commanull($SS), commanullq($protiucet), commanullq($zprava),commanullq($header."\n\n".$body),");\n"; } sub def_or_empty($) { defined$_[0]?$_[0]:'' } sub quot($) { my ($x) = @_; # ' needs to be doubled $x =~ s/'/''/go; # replace suspicious characters by . $x =~ s{[^][\na-zA-Z0-9 !@#$%^&*()_=+;:"|<>/?,.~`{}'-]}{.}go; # ' "'$x'" } sub commanull_($&) { my ($x, $q) = (@_); #print STDERR "[[$x]]\n"; no warnings; (length $x) ? ", ". $q->($x) : ", NULL" } sub commanull($) { commanull_($_[0],sub {$_[0]}) } sub commanullq($) { commanull_($_[0],\") } sub decimal($) { my ($x) = @_; $x =~ y/,/./; $x =~ s/ //g; $x } my %action = ( endmail => sub { #print "$status: $_\n"; /^From / and do {{ $status = 'header'; vreset }} }, header => sub { $header .= $_."\n"; #print "$status: $_\n"; /^From: automat(?:\@| at )fio\.cz/ and $fio = 1; /^$/ and $status = ($fio ? 'body' : 'endmail'); /^Date: (.*)/ and $date = $1; #print "$status(",def_or_empty($fio),"): $_\n"; }, body => sub { /^From / or $body .= $_."\n"; #print "$status: $_\n"; /^P..jem na kont.: (\d+)/ and ($konto, $mul) = ($1,1); /^V.daj na kont.: (\d+)/ and ($konto, $mul) = ($1,-1); /^..stka: ([0-9 ]+[,.]\d+)?/ and $castka = $mul * decimal($1); /^VS: (\d+)/ and $VS = $1; /^SS: (\d*)/ and $SS = $1; /^Zpr.va p..jemci: (.*)/ and $zprava = $1; /^Proti..et: ([0-9\/-]+)/ and $protiucet = $1; /_____/ and process('endmail'); /^From / and (process('header'),vreset); #/^P[?ř][?í]jem na kont[?ě]: (\d+)/ and $konto = $1; #/^[?Č][?á]stka: (\d+)[,.](\d+)?/ and $castka = $1 + $2/100; #/^VS: (\d+)/ and $VS = $1; #/^SS: (\d*)/ and $SS = $1; #/^Zpr[?á]va p[?ř][?í]jemci: (.*)/ and $zprava = $1; #/^Proti..et: ([0-9\/-]+)/ and $protiucet = $1; #/_____/ and process; } ); my ($drop,$create) = (1,1); my $SEP = ';'; print <<EOF if $drop; drop table if exists ucetni_data; EOF print <<EOF if $create; CREATE TABLE IF NOT EXISTS ucetni_data ( `id` int(11) NOT NULL AUTO_INCREMENT, `konto` decimal(30,0) NOT NULL, `castka` decimal(30,2) NOT NULL, `datum` date NOT NULL, `vs` int(11) DEFAULT NULL, `ss` int(11) DEFAULT NULL, `protiucet` varchar(50) COLLATE utf8_unicode_ci DEFAULT NULL, `zprava` varchar(200) COLLATE utf8_unicode_ci DEFAULT NULL, `comment` varchar(2000) COLLATE utf8_unicode_ci DEFAULT NULL, PRIMARY KEY (`id`) ) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_unicode_ci AUTO_INCREMENT=563 ; EOF while (<>) { chomp; $action{$status}->(); } process('') if $status eq 'body';
#!/usr/bin/perl # Copyright TMA 2014 # Brmlab can use this free of charge as long as TMA is member. For other licensing options contact the author. use strict; use warnings; use Data::Dumper; my $x = 1; # pocet volenych papalasu my $funkci; # prave voleny papalas my $voleny_papalas = 0; # kandidati na papalase my @kand = (undef,); # listky pro papalase my @listky; # stav programu my $st; # pocet listku a neplatnych my ($listky, $neplatne_listky) = (0,0); # stavova masina my %sm; %sm = ( start => sub { $funkci = $_; return 'kand'; }, kand => sub { return 'listky' if /^$/; push @kand,$_; return 'kand'; }, listky => sub { return 'volby' if /^$/; my $listek = [0,split]; # doplnit nuly na konci listku my @tmp = (0,) x scalar @kand; @tmp[0 .. $#$listek] = @$listek; $listek = [ @tmp ]; # je listek platny? my $ok = /^[0-9 ]*1[0-9 ]*$/; @tmp = sort {$a<=>$b} (grep {$_>0} @$listek) if $ok; my $i = 0; #{local$"=" ";print "@tmp\n";} while ($ok && scalar @tmp) { #print "@tmp $i $ok\n"; $ok = (++$i == shift@tmp); } #{local$"=" ";print "$ok/@tmp\n";} #print "$ok listek $_\n"; ++$neplatne_listky unless $ok; ++$listky; push @listky, $listek if $ok; return 'listky'; }, volby => sub { die "Nebyl odevzdan ani jeden platny hlasovaci listek." unless $listky - $neplatne_listky; #print Dumper(\@listky); if (++$voleny_papalas > $funkci) { exit; } my $kolo = 1; my $papalas = undef; my $max; for my $i (1 .. $#kand) { local$"=" "; my @kandidat = prepocti($i); #print "kolo $i, @kandidat\n"; } while ($kolo <= $#kand) { my @kandidat = prepocti($kolo); #print Dumper(kandidat=>\@kandidat); ($max,$papalas) = (0, undef); for my $i (1 .. $#kandidat) { if ($max < $kandidat[$i]) { $max = $kandidat[$i]; $papalas = $i; } elsif ($max == $kandidat[$i]) { undef $papalas; } } #{local$"=" ";print "kolo $kolo, @kandidat\n";} last if defined $papalas; #{local$"=" ";print "$kolo $papalas $zvolen @kandidat\n";} $kolo++; } if (defined $papalas) { print "Byl zvolen $kand[$papalas] v $kolo. kole volby poctem $max hlasu.\n"; uprav($papalas); $sm{volby}->(); } else { $papalas = $_; die "Chybi zaznam o losovani." unless $papalas; print "Byl vylosovan $kand[$papalas].\n"; uprav($papalas); } return 'volby'; }, ); $st = $sm{start}; sub prepocti($) { my ($kolo,) = (@_); my @kandidat = (0,) x $#kand; for my $listek (@listky) { #{no warnings;local$"="| |";print "|@$listek|\n";} for my $i (1 .. $#$listek) { ++$kandidat[int$i] if $listek->[$i] > 0 && $listek->[int$i]<=$kolo; } } return @kandidat; } sub uprav($) { my ($papalas,) = (@_); for my $listek (@listky) { #{no warnings;local$"="| |";print "|@$listek|\n";} #{local$"=" ";print "< @$listek\n";} my $poradi = $listek->[$papalas]; next if $poradi == 0; for my $i (1 .. $#$listek) { $listek->[$i]-- if $listek->[$i] > $poradi; } $listek->[$papalas]=0; #{local$"=" ";print "> @$listek\n";} } } while (<>) { chomp; $st = $sm{$st->()}; } END { print "Odevzdano celkem $listky hlasovacich listku.\n"; my $platne_listky = $listky - $neplatne_listky; print "Z toho $neplatne_listky hlasovacich listku neplatnych a $platne_listky platnych.\n"; }
Priklad pouziti:
2 TMA Mrkva 0 1 1 2 2 1 0
(Pred posledni nulu je mozno vlozit radek s cislem vylosovaneho kandidata, je-li treba losovat.)