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::AllUtils 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" => [],
162 $self->{filename} = usertag_file_from_email($self->{email});
163 if (not -r $self->{filename}) {
166 my $uf = IO::File->new($self->{filename},'r')
167 or die "Unable to open file $self->{filename} for reading: $!";
170 $self->{"locked"} = $uf;
174 my @stanza = _read_stanza($uf);
176 if ($stanza[0] eq "Tag") {
179 $ut->{$t} = [] unless defined $ut->{$t};
180 my @bugs = split /\s*,\s*/, $tag{Bugs};
181 push @{$ut->{$t}}, @bugs;
182 for my $bug (@bugs) {
183 push @{$self->{bug_tags}{$bug}},
186 } elsif ($stanza[0] eq "Category") {
188 my %stanza = @stanza;
189 my $catname = $stanza{"Category"};
191 while (++$i && defined $stanza{"Cat${i}"}) {
192 if (defined $stanza{"Cat${i}Options"}) {
194 my %c = ("nam" => $stanza{"Cat${i}"});
195 $c{"def"} = $stanza{"Cat${i}Default"}
196 if defined $stanza{"Cat${i}Default"};
197 if (defined $stanza{"Cat${i}Order"}) {
198 my @temp = split /\s*,\s*/, $stanza{"Cat${i}Order"};
200 my $min = min(@temp);
201 # Order to 0 minimum; strip duplicates
202 $c{ord} = [map {$temp{$_}++;
203 $temp{$_}>1?():($_-$min);
208 for my $l (split /\n/, $stanza{"Cat${i}Options"}) {
209 if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) {
212 } elsif ($l =~ m/^\s*(\S+)\s*$/) {
221 push @cat, $stanza{"Cat${i}"};
224 $self->{"categories"}->{$catname} = [@cat];
225 push @{$self->{"visible_cats"}}, $catname
226 unless ($stanza{"Hidden"} || "no") eq "yes";
228 elsif ($stanza[0] eq 'Value') {
229 my ($value,$value_name,%bug_values) = @stanza;
230 while (my ($k,$v) = each %bug_values) {
231 my ($bug) = $k =~ m/^Bug-(\d+)/;
232 next unless defined $bug;
233 $self->{values}{$bug}{$value_name} = $v;
237 push @{$self->{"unknown_stanzas"}}, [@stanza];
246 return $self->{email};
252 return $self->{"tags"};
257 return map {@{$self->{"bug_tags"}{$_}//[]}} @_;
262 return keys %{$self->{bug_tags}} > 0;
268 my $ut = $self->{"tags"};
269 my $p = $self->{"filename"};
271 if (not defined $self->{filename} or not
272 length $self->{filename}) {
273 carp "Tried to write a usertag with no filename defined";
276 my $uf = IO::File->new($self->{filename},'w');
278 carp "Unable to open $self->{filename} for writing: $!";
282 for my $us (@{$self->{"unknown_stanzas"}}) {
284 while (my ($k,$v) = splice (@us,0,2)) {
286 print {$uf} "$k: $v\n";
291 for my $t (keys %{$ut}) {
292 next if @{$ut->{$t}} == 0;
293 print {$uf} "Tag: $t\n";
294 print {$uf} _wrap_to_length("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n";
298 my $uc = $self->{"categories"};
299 my %vis = map { $_, 1 } @{$self->{"visible_cats"}};
300 for my $c (keys %{$uc}) {
301 next if @{$uc->{$c}} == 0;
303 print $uf "Category: $c\n";
304 print $uf "Hidden: yes\n" unless defined $vis{$c};
306 for my $cat (@{$uc->{$c}}) {
308 if (ref($cat) eq "HASH") {
309 printf $uf "Cat%d: %s\n", $i, $cat->{"nam"};
310 printf $uf "Cat%dOptions:\n", $i;
311 for my $j (0..$#{$cat->{"pri"}}) {
312 if (defined $cat->{"ttl"}->[$j]) {
313 printf $uf " %s - %s\n",
314 $cat->{"pri"}->[$j], $cat->{"ttl"}->[$j];
316 printf $uf " %s\n", $cat->{"pri"}->[$j];
319 printf $uf "Cat%dDefault: %s\n", $i, $cat->{"def"}
320 if defined $cat->{"def"};
321 printf $uf "Cat%dOrder: %s\n", $i, join(", ", @{$cat->{"ord"}})
322 if defined $cat->{"ord"};
324 printf $uf "Cat%d: %s\n", $i, $cat;
329 # handle the value stanzas
331 # invert the bug->value hash slightly
332 for my $bug (keys %{$self->{values}}) {
333 for my $value (keys %{$self->{values}{$bug}}) {
334 $value{$value}{$bug} = $self->{values}{$bug}{$value}
337 for my $value (keys %value) {
338 print {$uf} "Value: $value\n";
339 for my $bug (keys %{$value{$value}}) {
340 my $bug_value = $value{$value}{$bug};
341 $bug_value =~ s/\n/\n /g;
342 print {$uf} "Bug-$bug: $bug_value\n";
348 delete $self->{"locked"};
351 =head1 OBSOLETE FUNCTIONS
357 read_usertags($usertags,$email)
363 my ($usertags,$email) = @_;
365 # carp "read_usertags is deprecated";
366 my $user = get_user($email);
367 for my $tag (keys %{$user->{"tags"}}) {
368 $usertags->{$tag} = [] unless defined $usertags->{$tag};
369 push @{$usertags->{$tag}}, @{$user->{"tags"}->{$tag}};
374 =head2 write_usertags
376 write_usertags($usertags,$email);
378 Gets a lock on the usertags, applies the usertags passed, and writes
384 my ($usertags,$email) = @_;
386 # carp "write_usertags is deprecated";
387 my $user = Debbugs::User->new($email,1); # locked
388 $user->{"tags"} = { %{$usertags} };
393 =head1 PRIVATE FUNCTIONS
397 my @stanza = _read_stanza($fh);
399 Reads a single stanza from a filehandle and returns it
404 my ($file_handle) = @_;
407 while (<$file_handle>) {
410 if ($field && m/^ (.*)$/) {
411 $res[-1] .= "\n" . $1;
412 } elsif (m/^([^:]+):(\s+(.*))?$/) {
414 push @res, ($1, $3||'');
421 =head2 _wrap_to_length
425 Wraps a line to a specific length by splitting at commas
429 sub _wrap_to_length {
430 my ($content,$line_length) = @_;
431 my $current_line_length = 0;
433 while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) {
434 my $current_word = $1;
436 if ($current_line_length != 0 and
437 $current_line_length + length($current_word) <= $line_length) {
439 $current_line_length = 1;
441 $result .= $current_word;
442 $current_line_length += length($current_word);
444 return $result . $content;