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