pts/perl/common.pl

# Configuration and some common code

use vars qw($pts_dir $spool_dir $conf_sub_template $db_filename $db_tags_filename
            $conf_unsub_template $conf_unsuball_template
            $sendmail $sendmaildefault $sendmailnobody $sources $pts_email
            @available_tags @default_tags %db_content $db %db_tags_content
            $db_tags %db_bounces $db_bounces
            %bin2src %src $open_count);

# Configuration variables
$pts_dir = "/org/packages.qa.debian.org";
$spool_dir = "$pts_dir/spool";
$conf_sub_template = "$pts_dir/etc/conf_tpl.txt";
$conf_unsub_template = "$pts_dir/etc/conf_unsub_tpl.txt";
$conf_unsuball_template = "$pts_dir/etc/conf_unsuball_tpl.txt";
$db_filename = "$pts_dir/db/subscription.db";
$db_tags_filename = "$pts_dir/db/tags.db";
$db_bounces_filename = "$pts_dir/db/bounces.db";
$sendmail = '/usr/sbin/sendmail';
$sendmaildefault = '/usr/sbin/sendmail -f bounces@packages.qa.debian.org';
$sendmailnobody = '/usr/sbin/sendmail -f bounces-likely-spam@packages.qa.debian.org';
$sources = "/org/packages.qa.debian.org/www/incoming/sources";
$pts_email = 'pts@qa.debian.org';
@available_tags = qw(default bts bts-control cvs summary ddtp
                     upload-source upload-binary katie-other
                     derivatives);
@default_tags = qw(default bts bts-control summary upload-source katie-other);

# Global variables
%db_content = ();
$db = undef;
%db_tags_content = ();
$db_tags = undef;
%db_bounces_content = ();
$db_bounces = undef;
%bin2src = ();
%src = ();
$open_count = 0;

# Common code
sub open_db_write {
    $DB_BTREE->{'flags'} = R_DUP;
    if ($open_count <= 0) {
        $db = tie %db_content, "DB_File", $db_filename, O_RDWR|O_CREAT,
                      0660, $DB_BTREE
            or die "Can't open database $db_filename : $!\n";
        $db_tags = tie %db_tags_content, "DB_File", $db_tags_filename,
                    O_RDWR|O_CREAT, 0660, $DB_HASH
            or die "Can't open database $db_tags_filename : $!\n";
    }
    $open_count++;
}
sub open_db_read {
    $DB_BTREE->{'flags'} = R_DUP;
    if ($open_count <= 0) {
        if (-f $db_filename and -f $db_tags_filename) {
            $db = tie %db_content, "DB_File", $db_filename, O_RDONLY,
                          0660, $DB_BTREE
                or die "Can't open database $db_filename : $!\n";
            $db_tags = tie %db_tags_content, "DB_File", $db_tags_filename,
                        O_RDONLY, 0660, $DB_HASH
                or die "Can't open database $db_tags_filename : $!\n";
        } else {
            open_db_write();
        }
    }
    $open_count++;
}
sub close_db {
    $open_count--;
    if ($open_count <= 0) {
        undef $db;
        untie %db_content;
        undef $db_tags;
        untie %db_tags_content;
    }
}

sub open_db_bounces {
    $db_bounces = tie %db_bounces_content, "DB_File", $db_bounces_filename,
                O_RDWR|O_CREAT, 0660, $DB_HASH
        or die "Can't open database $db_bounces_filename : $!\n";
}

sub close_db_bounces {
    undef $db_bounces;
    untie %db_bounces_content;
}

sub update_bounces_db {
    my ($date, $email, $sent) = @_;
    # $sent: 1=>new mail sent, 0=> bounces received
    my @stats = split(" ", $db_bounces_content{$email});
    my $found = 0;
    for(my $i = 0; $i < scalar(@stats); $i += 3) {
        if ($stats[$i] eq $date) {
            if ($found) {
                $stats[$i+1]++;
            } else {
                $stats[$i+2]++;
            }
            $found = 1;
        }
    }
    if ($sent && (!$found)) {
        push @stats, $date, 1, 0;
    }
    if (scalar(@stats) > 12) {
        shift @stats; shift @stats; shift @stats;
    }
    $db_bounces_content{$email} = join(" ", @stats);
}

sub has_too_many_bounces {
    my ($email) = @_;
    my @stats = split(" ", $db_bounces_content{$email});
    my $count = 0;
    for(my $i = 0; $i < scalar(@stats); $i += 3) {
        if ($stats[$i+2] >= $stats[$i+1]) {
            $count++;
        }
    }
    return ($count >= 3) ? 1: 0;
}

sub subscribe {
    my ($address, $package) = @_;
    open_db_write();
    my @emails = $db->get_dup($package);
    my $found = 0;
    foreach (@emails) {
        $found = 1 if ($_ eq $address);
    }
    $db_content{$package} = $address if (! $found);
    close_db();
    return ! $found;
}
sub unsubscribe {
    my ($address, $package) = @_;
    my $ok = 1;
    open_db_write();
    if ($db->find_dup($package, $address) == 0) {
        $db->del_dup($package, $address);
    } else {
        $ok = 0;
    }
    close_db();
    return $ok;
}
sub which {
    my ($address) = @_;
    my @l;
    my %seen;
    open_db_read();
    foreach my $p (keys %db_content) {
        next if (exists $seen{$p});
        $seen{$p} = 1;
        my %list = $db->get_dup($p, 1);
        if ((exists $list{lc($address)}) && $list{lc($address)}) {
            push @l, $p;
        }
    }
    close_db();
    return @l;
}
sub list {
    my ($package) = @_;
    open_db_read();
    my @l = $db->get_dup($package);
    close_db();
    return @l;
}
sub load_sources {
    return if (scalar(keys %bin2src));
    open(SOURCES, "< $sources") || warn "Can't open $sources: $!\n";
    while(defined($_=<SOURCES>)) {
        my ($bin, $comp, $src) = (split(/\s+/));
        $bin2src{lc($bin)} = lc($src);
        $src{lc($src)} = 1;
    }
    close(SOURCES);
}
sub map_package {
    my ($pkg) = @_;
    my ($package, @msg);
    load_sources();
    if (exists $src{$pkg}) {
        $package = $pkg;
    } elsif (exists $bin2src{$pkg}) {
        $package = $bin2src{$pkg};
        push @msg, "$pkg is not a source package. However $package is \n";
        push @msg, "the source package for the $pkg binary package.\n";
        push @msg, "\n";
    } else {
        $package = $pkg;
        push @msg, "$pkg is neither a source package nor a binary package. \n";
        push @msg, "It may be a 'pseudo package' or a mistake...\n";
        push @msg, "\n";
    }
    return ($package, @msg);
}
sub available_tags {
    return @available_tags;
}
sub is_valid_tag {
    my ($tag) = @_;
    $tag = lc($tag);
    foreach (available_tags()) {
        return 1 if ($tag eq $_);
    }
    return 0;
}
sub clean_tags {
    my %h;
    foreach (@_) { $h{lc($_)} = 1 }
    return grep { defined($h{$_}) && $h{$_} } available_tags();
}
sub get_default_tags {
    my ($email) = @_;
    $email = lc($email);
    open_db_read();
    my @res;
    if (exists $db_tags_content{$email}) {
        @res = split(/,/, $db_tags_content{$email});
    } else {
        @res = @default_tags;
    }
    close_db();
    return @res;
}
sub set_default_tags {
    my ($email, @tags) = @_;
    open_db_write();
    $db_tags_content{lc($email)} = join(",", clean_tags(@tags));
    close_db();
}
sub get_tags {
    my ($email, $package) = @_;
    $email = lc($email);
    $package = lc($package);
    open_db_read();
    my @res;
    if (exists $db_tags_content{"$email#$package"}) {
        @res = split(/,/, $db_tags_content{"$email#$package"});
    } elsif (exists $db_tags_content{$email}) {
        @res = split(/,/, $db_tags_content{$email});
    } else {
        @res = @default_tags;
    }
    close_db();
    return @res;
}
sub set_tags {
    my ($email, $package, @tags) = @_;
    open_db_write();
    $db_tags_content{lc("$email#$package")} = join(",", clean_tags(@tags));
    close_db();
}

1;
1	# Configuration and some common code
2
3	use vars qw($pts_dir $spool_dir $conf_sub_template $db_filename $db_tags_filename
4	$conf_unsub_template $conf_unsuball_template
5	$sendmail $sendmaildefault $sendmailnobody $sources $pts_email
6	@available_tags @default_tags %db_content $db %db_tags_content
7	$db_tags %db_bounces $db_bounces
8	%bin2src %src $open_count);
9
10	# Configuration variables
11	$pts_dir = "/org/packages.qa.debian.org";
12	$spool_dir = "$pts_dir/spool";
13	$conf_sub_template = "$pts_dir/etc/conf_tpl.txt";
14	$conf_unsub_template = "$pts_dir/etc/conf_unsub_tpl.txt";
15	$conf_unsuball_template = "$pts_dir/etc/conf_unsuball_tpl.txt";
16	$db_filename = "$pts_dir/db/subscription.db";
17	$db_tags_filename = "$pts_dir/db/tags.db";
18	$db_bounces_filename = "$pts_dir/db/bounces.db";
19	$sendmail = '/usr/sbin/sendmail';
20	$sendmaildefault = '/usr/sbin/sendmail -f bounces@packages.qa.debian.org';
21	$sendmailnobody = '/usr/sbin/sendmail -f bounces-likely-spam@packages.qa.debian.org';
22	$sources = "/org/packages.qa.debian.org/www/incoming/sources";
23	$pts_email = 'pts@qa.debian.org';
24	@available_tags = qw(default bts bts-control cvs summary ddtp
25	upload-source upload-binary katie-other
26	derivatives);
27	@default_tags = qw(default bts bts-control summary upload-source katie-other);
28
29	# Global variables
30	%db_content = ();
31	$db = undef;
32	%db_tags_content = ();
33	$db_tags = undef;
34	%db_bounces_content = ();
35	$db_bounces = undef;
36	%bin2src = ();
37	%src = ();
38	$open_count = 0;
39
40	# Common code
41	sub open_db_write {
42	$DB_BTREE->{'flags'} = R_DUP;
43	if ($open_count <= 0) {
44	$db = tie %db_content, "DB_File", $db_filename, O_RDWR\|O_CREAT,
45	0660, $DB_BTREE
46	or die "Can't open database $db_filename : $!\n";
47	$db_tags = tie %db_tags_content, "DB_File", $db_tags_filename,
48	O_RDWR\|O_CREAT, 0660, $DB_HASH
49	or die "Can't open database $db_tags_filename : $!\n";
50	}
51	$open_count++;
52	}
53	sub open_db_read {
54	$DB_BTREE->{'flags'} = R_DUP;
55	if ($open_count <= 0) {
56	if (-f $db_filename and -f $db_tags_filename) {
57	$db = tie %db_content, "DB_File", $db_filename, O_RDONLY,
58	0660, $DB_BTREE
59	or die "Can't open database $db_filename : $!\n";
60	$db_tags = tie %db_tags_content, "DB_File", $db_tags_filename,
61	O_RDONLY, 0660, $DB_HASH
62	or die "Can't open database $db_tags_filename : $!\n";
63	} else {
64	open_db_write();
65	}
66	}
67	$open_count++;
68	}
69	sub close_db {
70	$open_count--;
71	if ($open_count <= 0) {
72	undef $db;
73	untie %db_content;
74	undef $db_tags;
75	untie %db_tags_content;
76	}
77	}
78
79	sub open_db_bounces {
80	$db_bounces = tie %db_bounces_content, "DB_File", $db_bounces_filename,
81	O_RDWR\|O_CREAT, 0660, $DB_HASH
82	or die "Can't open database $db_bounces_filename : $!\n";
83	}
84
85	sub close_db_bounces {
86	undef $db_bounces;
87	untie %db_bounces_content;
88	}
89
90	sub update_bounces_db {
91	my ($date, $email, $sent) = @_;
92	# $sent: 1=>new mail sent, 0=> bounces received
93	my @stats = split(" ", $db_bounces_content{$email});
94	my $found = 0;
95	for(my $i = 0; $i < scalar(@stats); $i += 3) {
96	if ($stats[$i] eq $date) {
97	if ($found) {
98	$stats[$i+1]++;
99	} else {
100	$stats[$i+2]++;
101	}
102	$found = 1;
103	}
104	}
105	if ($sent && (!$found)) {
106	push @stats, $date, 1, 0;
107	}
108	if (scalar(@stats) > 12) {
109	shift @stats; shift @stats; shift @stats;
110	}
111	$db_bounces_content{$email} = join(" ", @stats);
112	}
113
114	sub has_too_many_bounces {
115	my ($email) = @_;
116	my @stats = split(" ", $db_bounces_content{$email});
117	my $count = 0;
118	for(my $i = 0; $i < scalar(@stats); $i += 3) {
119	if ($stats[$i+2] >= $stats[$i+1]) {
120	$count++;
121	}
122	}
123	return ($count >= 3) ? 1: 0;
124	}
125
126	sub subscribe {
127	my ($address, $package) = @_;
128	open_db_write();
129	my @emails = $db->get_dup($package);
130	my $found = 0;
131	foreach (@emails) {
132	$found = 1 if ($_ eq $address);
133	}
134	$db_content{$package} = $address if (! $found);
135	close_db();
136	return ! $found;
137	}
138	sub unsubscribe {
139	my ($address, $package) = @_;
140	my $ok = 1;
141	open_db_write();
142	if ($db->find_dup($package, $address) == 0) {
143	$db->del_dup($package, $address);
144	} else {
145	$ok = 0;
146	}
147	close_db();
148	return $ok;
149	}
150	sub which {
151	my ($address) = @_;
152	my @l;
153	my %seen;
154	open_db_read();
155	foreach my $p (keys %db_content) {
156	next if (exists $seen{$p});
157	$seen{$p} = 1;
158	my %list = $db->get_dup($p, 1);
159	if ((exists $list{lc($address)}) && $list{lc($address)}) {
160	push @l, $p;
161	}
162	}
163	close_db();
164	return @l;
165	}
166	sub list {
167	my ($package) = @_;
168	open_db_read();
169	my @l = $db->get_dup($package);
170	close_db();
171	return @l;
172	}
173	sub load_sources {
174	return if (scalar(keys %bin2src));
175	open(SOURCES, "< $sources") \|\| warn "Can't open $sources: $!\n";
176	while(defined($_=<SOURCES>)) {
177	my ($bin, $comp, $src) = (split(/\s+/));
178	$bin2src{lc($bin)} = lc($src);
179	$src{lc($src)} = 1;
180	}
181	close(SOURCES);
182	}
183	sub map_package {
184	my ($pkg) = @_;
185	my ($package, @msg);
186	load_sources();
187	if (exists $src{$pkg}) {
188	$package = $pkg;
189	} elsif (exists $bin2src{$pkg}) {
190	$package = $bin2src{$pkg};
191	push @msg, "$pkg is not a source package. However $package is \n";
192	push @msg, "the source package for the $pkg binary package.\n";
193	push @msg, "\n";
194	} else {
195	$package = $pkg;
196	push @msg, "$pkg is neither a source package nor a binary package. \n";
197	push @msg, "It may be a 'pseudo package' or a mistake...\n";
198	push @msg, "\n";
199	}
200	return ($package, @msg);
201	}
202	sub available_tags {
203	return @available_tags;
204	}
205	sub is_valid_tag {
206	my ($tag) = @_;
207	$tag = lc($tag);
208	foreach (available_tags()) {
209	return 1 if ($tag eq $_);
210	}
211	return 0;
212	}
213	sub clean_tags {
214	my %h;
215	foreach (@_) { $h{lc($_)} = 1 }
216	return grep { defined($h{$_}) && $h{$_} } available_tags();
217	}
218	sub get_default_tags {
219	my ($email) = @_;
220	$email = lc($email);
221	open_db_read();
222	my @res;
223	if (exists $db_tags_content{$email}) {
224	@res = split(/,/, $db_tags_content{$email});
225	} else {
226	@res = @default_tags;
227	}
228	close_db();
229	return @res;
230	}
231	sub set_default_tags {
232	my ($email, @tags) = @_;
233	open_db_write();
234	$db_tags_content{lc($email)} = join(",", clean_tags(@tags));
235	close_db();
236	}
237	sub get_tags {
238	my ($email, $package) = @_;
239	$email = lc($email);
240	$package = lc($package);
241	open_db_read();
242	my @res;
243	if (exists $db_tags_content{"$email#$package"}) {
244	@res = split(/,/, $db_tags_content{"$email#$package"});
245	} elsif (exists $db_tags_content{$email}) {
246	@res = split(/,/, $db_tags_content{$email});
247	} else {
248	@res = @default_tags;
249	}
250	close_db();
251	return @res;
252	}
253	sub set_tags {
254	my ($email, $package, @tags) = @_;
255	open_db_write();
256	$db_tags_content{lc("$email#$package")} = join(",", clean_tags(@tags));
257	close_db();
258	}
259
260	1;
Name	Value
svn:eol-style	native
svn:keywords	Author Date Id Revision