1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2004 by Anthony Towns
9 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>
12 package Debbugs::User;
16 Debbugs::User -- User settings
20 use Debbugs::User qw(is_valid_user read_usertags write_usertags);
22 Debbugs::User::is_valid_user($userid);
24 $u = Debbugs::User::open($userid);
25 $u = Debbugs::User::open(user => $userid, locked => 0);
27 $u = Debbugs::User::open(user => $userid, locked => 1);
36 read_usertags(\%ut, $userid);
37 write_usertags(\%ut, $userid);
39 =head1 USERTAG FILE FORMAT
41 Usertags are in a file which has (roughly) RFC822 format, with stanzas
42 separated by newlines. For example:
52 Bug-72341: http://bugzilla/2039471
53 Bug-1022: http://bugzilla/230941
59 Category: debbugs.tasks
74 =item :all -- all functions that can be exported
85 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
86 use Exporter qw(import);
88 use Debbugs::Config qw(:config);
89 use List::Util qw(min);
95 ($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/;
96 $DEBUG = 0 unless defined $DEBUG;
99 @EXPORT_OK = qw(is_valid_user read_usertags write_usertags);
100 $EXPORT_TAGS{all} = [@EXPORT_OK];
104 #######################################################################
109 return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/);
112 =head2 usertag_file_from_email
114 my $filename = usertag_file_from_email($email)
116 Turns an email into the filename where the usertag can be located.
120 sub usertag_file_from_email {
122 my $email_length = length($email) % 7;
123 my $escaped_email = $email;
124 $escaped_email =~ s/([^0-9a-zA-Z_+.-])/sprintf("%%%02X", ord($1))/eg;
125 return "$config{usertag_dir}/$email_length/$escaped_email";
129 #######################################################################
133 return Debbugs::User->new(@_);
138 my $user = Debbugs::User->new('foo@bar.com',$lock);
140 Reads the user file associated with 'foo@bar.com' and returns a
141 Debbugs::User object.
147 $class = ref($class) || $class;
148 my ($email,$need_lock) = @_;
152 my $self = {"tags" => $ut,
154 "visible_cats" => [],
155 "unknown_stanzas" => [],
161 $self->{filename} = usertag_file_from_email($self->{email});
162 if (not -r $self->{filename}) {
165 my $uf = IO::File->new($self->{filename},'r')
166 or die "Unable to open file $self->{filename} for reading: $!";
169 $self->{"locked"} = $uf;
173 my @stanza = _read_stanza($uf);
175 if ($stanza[0] eq "Tag") {
178 $ut->{$t} = [] unless defined $ut->{$t};
179 push @{$ut->{$t}}, split /\s*,\s*/, $tag{Bugs};
180 } elsif ($stanza[0] eq "Category") {
182 my %stanza = @stanza;
183 my $catname = $stanza{"Category"};
185 while (++$i && defined $stanza{"Cat${i}"}) {
186 if (defined $stanza{"Cat${i}Options"}) {
188 my %c = ("nam" => $stanza{"Cat${i}"});
189 $c{"def"} = $stanza{"Cat${i}Default"}
190 if defined $stanza{"Cat${i}Default"};
191 if (defined $stanza{"Cat${i}Order"}) {
192 my @temp = split /\s*,\s*/, $stanza{"Cat${i}Order"};
194 my $min = min(@temp);
195 # Order to 0 minimum; strip duplicates
196 $c{ord} = [map {$temp{$_}++;
197 $temp{$_}>1?():($_-$min);
202 for my $l (split /\n/, $stanza{"Cat${i}Options"}) {
203 if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) {
206 } elsif ($l =~ m/^\s*(\S+)\s*$/) {
215 push @cat, $stanza{"Cat${i}"};
218 $self->{"categories"}->{$catname} = [@cat];
219 push @{$self->{"visible_cats"}}, $catname
220 unless ($stanza{"Hidden"} || "no") eq "yes";
222 elsif ($stanza[0] eq 'Value') {
223 my ($value,$value_name,%bug_values) = @stanza;
224 while (my ($k,$v) = each %bug_values) {
225 my ($bug) = $k =~ m/^Bug-(\d+)/;
226 next unless defined $bug;
227 $self->{values}{$bug}{$value_name} = $v;
231 push @{$self->{"unknown_stanzas"}}, [@stanza];
241 my $ut = $self->{"tags"};
242 my $p = $self->{"filename"};
244 if (not defined $self->{filename} or not
245 length $self->{filename}) {
246 carp "Tried to write a usertag with no filename defined";
249 my $uf = IO::File->new($self->{filename},'w');
251 carp "Unable to open $self->{filename} for writing: $!";
255 for my $us (@{$self->{"unknown_stanzas"}}) {
257 while (my ($k,$v) = splice (@us,0,2)) {
259 print {$uf} "$k: $v\n";
264 for my $t (keys %{$ut}) {
265 next if @{$ut->{$t}} == 0;
266 print {$uf} "Tag: $t\n";
267 print {$uf} _wrap_to_length("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n";
271 my $uc = $self->{"categories"};
272 my %vis = map { $_, 1 } @{$self->{"visible_cats"}};
273 for my $c (keys %{$uc}) {
274 next if @{$uc->{$c}} == 0;
276 print $uf "Category: $c\n";
277 print $uf "Hidden: yes\n" unless defined $vis{$c};
279 for my $cat (@{$uc->{$c}}) {
281 if (ref($cat) eq "HASH") {
282 printf $uf "Cat%d: %s\n", $i, $cat->{"nam"};
283 printf $uf "Cat%dOptions:\n", $i;
284 for my $j (0..$#{$cat->{"pri"}}) {
285 if (defined $cat->{"ttl"}->[$j]) {
286 printf $uf " %s - %s\n",
287 $cat->{"pri"}->[$j], $cat->{"ttl"}->[$j];
289 printf $uf " %s\n", $cat->{"pri"}->[$j];
292 printf $uf "Cat%dDefault: %s\n", $i, $cat->{"def"}
293 if defined $cat->{"def"};
294 printf $uf "Cat%dOrder: %s\n", $i, join(", ", @{$cat->{"ord"}})
295 if defined $cat->{"ord"};
297 printf $uf "Cat%d: %s\n", $i, $cat;
302 # handle the value stanzas
304 # invert the bug->value hash slightly
305 for my $bug (keys %{$self->{values}}) {
306 for my $value (keys %{$self->{values}{$bug}}) {
307 $value{$value}{$bug} = $self->{values}{$bug}{$value}
310 for my $value (keys %value) {
311 print {$uf} "Value: $value\n";
312 for my $bug (keys %{$value{$value}}) {
313 my $bug_value = $value{$value}{$bug};
314 $bug_value =~ s/\n/\n /g;
315 print {$uf} "Bug-$bug: $bug_value\n";
321 delete $self->{"locked"};
324 =head1 OBSOLETE FUNCTIONS
330 read_usertags($usertags,$email)
336 my ($usertags,$email) = @_;
338 # carp "read_usertags is deprecated";
339 my $user = get_user($email);
340 for my $tag (keys %{$user->{"tags"}}) {
341 $usertags->{$tag} = [] unless defined $usertags->{$tag};
342 push @{$usertags->{$tag}}, @{$user->{"tags"}->{$tag}};
347 =head2 write_usertags
349 write_usertags($usertags,$email);
351 Gets a lock on the usertags, applies the usertags passed, and writes
357 my ($usertags,$email) = @_;
359 # carp "write_usertags is deprecated";
360 my $user = Debbugs::User->new($email,1); # locked
361 $user->{"tags"} = { %{$usertags} };
366 =head1 PRIVATE FUNCTIONS
370 my @stanza = _read_stanza($fh);
372 Reads a single stanza from a filehandle and returns it
377 my ($file_handle) = @_;
380 while (<$file_handle>) {
383 if ($field && m/^ (.*)$/) {
384 $res[-1] .= "\n" . $1;
385 } elsif (m/^([^:]+):(\s+(.*))?$/) {
387 push @res, ($1, $3||'');
394 =head2 _wrap_to_length
398 Wraps a line to a specific length by splitting at commas
402 sub _wrap_to_length {
403 my ($content,$line_length) = @_;
404 my $current_line_length = 0;
406 while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) {
407 my $current_word = $1;
409 if ($current_line_length != 0 and
410 $current_line_length + length($current_word) <= $line_length) {
412 $current_line_length = 1;
414 $result .= $current_word;
415 $current_line_length += length($current_word);
417 return $result . $content;