Debbugs/User.pm

   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.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2004 by Anthony Towns
   9 # Copyright 2008 by Don Armstrong <don@donarmstrong.com>
  10
  11
  12 package Debbugs::User;
  13
  14 =head1 NAME
  15
  16 Debbugs::User -- User settings
  17
  18 =head1 SYNOPSIS
  19
  20 use Debbugs::User qw(is_valid_user read_usertags write_usertags);
  21
  22 Debbugs::User::is_valid_user($userid);
  23
  24 $u = Debbugs::User::open($userid);
  25 $u = Debbugs::User::open(user => $userid, locked => 0);
  26
  27 $u = Debbugs::User::open(user => $userid, locked => 1);
  28 $u->write();
  29
  30 $u->{"tags"}
  31 $u->{"categories"}
  32 $u->{"is_locked"}
  33 $u->{"name"}
  34
  35
  36 read_usertags(\%ut, $userid);
  37 write_usertags(\%ut, $userid);
  38
  39 =head1 USERTAG FILE FORMAT
  40
  41 Usertags are in a file which has (roughly) RFC822 format, with stanzas
  42 separated by newlines. For example:
  43
  44  Tag: search
  45  Bugs: 73671, 392392
  46
  47  Value: priority
  48  Bug-73671: 5
  49  Bug-73487: 2
  50
  51  Value: bugzilla
  52  Bug-72341: http://bugzilla/2039471
  53  Bug-1022: http://bugzilla/230941
  54
  55  Category: normal
  56  Cat1: status
  57  Cat2: debbugs.tasks
  58
  59  Category: debbugs.tasks
  60  Hidden: yes
  61  Cat1: debbugs.tasks
  62
  63  Cat1Options:
  64   tag=quick
  65   tag=medium
  66   tag=arch
  67   tag=not-for-me
  68
  69
  70 =head1 EXPORT TAGS
  71
  72 =over
  73
  74 =item :all -- all functions that can be exported
  75
  76 =back
  77
  78 =head1 FUNCTIONS
  79
  80 =cut
  81
  82 use warnings;
  83 use strict;
  84 use Fcntl ':flock';
  85 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  86 use Exporter qw(import);
  87
  88 use Debbugs::Config qw(:config);
  89 use List::AllUtils qw(min);
  90
  91 use Carp;
  92 use IO::File;
  93
  94 BEGIN {
  95     ($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/;
  96     $DEBUG = 0 unless defined $DEBUG;
  97
  98     @EXPORT = ();
  99     @EXPORT_OK = qw(is_valid_user read_usertags write_usertags);
 100     $EXPORT_TAGS{all} = [@EXPORT_OK];
 101 }
 102
 103
 104 #######################################################################
 105 # Helper functions
 106
 107 sub is_valid_user {
 108     my $u = shift;
 109     return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/);
 110 }
 111
 112 =head2 usertag_file_from_email
 113
 114      my $filename = usertag_file_from_email($email)
 115
 116 Turns an email into the filename where the usertag can be located.
 117
 118 =cut
 119
 120 sub usertag_file_from_email {
 121     my ($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";
 126 }
 127
 128
 129 #######################################################################
 130 # The real deal
 131
 132 sub get_user {
 133      return Debbugs::User->new(@_);
 134 }
 135
 136 =head2 new
 137
 138      my $user = Debbugs::User->new('foo@bar.com',$lock);
 139
 140 Reads the user file associated with 'foo@bar.com' and returns a
 141 Debbugs::User object.
 142
 143 =cut
 144
 145 sub new {
 146     my $class = shift;
 147     $class = ref($class) || $class;
 148     my ($email,$need_lock) = @_;
 149     $need_lock ||= 0;
 150
 151     my $ut = {};
 152     my $self = {"tags" => $ut,
 153                 "categories" => {},
 154                 "visible_cats" => [],
 155                 "unknown_stanzas" => [],
 156                 values => {},
 157                 bug_tags => {},
 158                 email => $email,
 159                };
 160     bless $self, $class;
 161
 162     $self->{filename} = usertag_file_from_email($self->{email});
 163     if (not -r $self->{filename}) {
 164          return $self;
 165     }
 166     my $uf = IO::File->new($self->{filename},'r')
 167          or die "Unable to open file $self->{filename} for reading: $!";
 168     if ($need_lock) {
 169         flock($uf, LOCK_EX);
 170         $self->{"locked"} = $uf;
 171     }
 172
 173     while(1) {
 174         my @stanza = _read_stanza($uf);
 175         last unless @stanza;
 176         if ($stanza[0] eq "Tag") {
 177             my %tag = @stanza;
 178             my $t = $tag{"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}},
 184                     $t;
 185             }
 186         } elsif ($stanza[0] eq "Category") {
 187             my @cat = ();
 188             my %stanza = @stanza;
 189             my $catname = $stanza{"Category"};
 190             my $i = 0;
 191             while (++$i && defined $stanza{"Cat${i}"}) {
 192                 if (defined $stanza{"Cat${i}Options"}) {
 193                     # parse into a hash
 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"};
 199                          my %temp;
 200                          my $min = min(@temp);
 201                          # Order to 0 minimum; strip duplicates
 202                          $c{ord} = [map {$temp{$_}++;
 203                                          $temp{$_}>1?():($_-$min);
 204                                     } @temp
 205                                    ];
 206                     }
 207                     my @pri; my @ttl;
 208                     for my $l (split /\n/, $stanza{"Cat${i}Options"}) {
 209                         if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) {
 210                             push @pri, $1;
 211                             push @ttl, $2;
 212                         } elsif ($l =~ m/^\s*(\S+)\s*$/) {
 213                             push @pri, $1;
 214                             push @ttl, $1;
 215                         }
 216                     }
 217                     $c{"ttl"} = [@ttl];
 218                     $c{"pri"} = [@pri];
 219                     push @cat, { %c };
 220                 } else {
 221                     push @cat, $stanza{"Cat${i}"};
 222                 }
 223             }
 224             $self->{"categories"}->{$catname} = [@cat];
 225             push @{$self->{"visible_cats"}}, $catname
 226                 unless ($stanza{"Hidden"} || "no") eq "yes";
 227         }
 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;
 234             }
 235         }
 236         else {
 237             push @{$self->{"unknown_stanzas"}}, [@stanza];
 238         }
 239     }
 240
 241     return $self;
 242 }
 243
 244 sub email {
 245     my $self = shift;
 246     return $self->{email};
 247 }
 248
 249 sub tags {
 250     my $self = shift;
 251
 252     return $self->{"tags"};
 253 }
 254
 255 sub tags_on_bug {
 256     my $self = shift;
 257     return map {@{$self->{"bug_tags"}{$_}//[]}} @_;
 258 }
 259
 260 sub has_bug_tags {
 261     my $self = shift;
 262     return keys %{$self->{bug_tags}} > 0;
 263 }
 264
 265 sub write {
 266     my $self = shift;
 267
 268     my $ut = $self->{"tags"};
 269     my $p = $self->{"filename"};
 270
 271     if (not defined $self->{filename} or not
 272         length $self->{filename}) {
 273          carp "Tried to write a usertag with no filename defined";
 274          return;
 275     }
 276     my $uf = IO::File->new($self->{filename},'w');
 277     if (not $uf) {
 278          carp "Unable to open $self->{filename} for writing: $!";
 279          return;
 280     }
 281
 282     for my $us (@{$self->{"unknown_stanzas"}}) {
 283         my @us = @{$us};
 284         while (my ($k,$v) = splice (@us,0,2)) {
 285             $v =~ s/\n/\n /g;
 286             print {$uf} "$k: $v\n";
 287         }
 288         print {$uf} "\n";
 289     }
 290
 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";
 295         print $uf "\n";
 296     }
 297
 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;
 302
 303         print $uf "Category: $c\n";
 304         print $uf "Hidden: yes\n" unless defined $vis{$c};
 305         my $i = 0;
 306         for my $cat (@{$uc->{$c}}) {
 307             $i++;
 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];
 315                     } else {
 316                         printf $uf " %s\n", $cat->{"pri"}->[$j];
 317                     }
 318                 }
 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"};
 323             } else {
 324                 printf $uf "Cat%d: %s\n", $i, $cat;
 325             }
 326         }
 327         print $uf "\n";
 328     }
 329     # handle the value stanzas
 330     my %value;
 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}
 335          }
 336     }
 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";
 343          }
 344          print {$uf} "\n";
 345     }
 346
 347     close($uf);
 348     delete $self->{"locked"};
 349 }
 350
 351 =head1 OBSOLETE FUNCTIONS
 352
 353 =cut
 354
 355 =head2 read_usertags
 356
 357      read_usertags($usertags,$email)
 358
 359
 360 =cut
 361
 362 sub read_usertags {
 363     my ($usertags,$email) = @_;
 364
 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}};
 370     }
 371     return $usertags;
 372 }
 373
 374 =head2 write_usertags
 375
 376      write_usertags($usertags,$email);
 377
 378 Gets a lock on the usertags, applies the usertags passed, and writes
 379 them out.
 380
 381 =cut
 382
 383 sub write_usertags {
 384     my ($usertags,$email) = @_;
 385
 386 #    carp "write_usertags is deprecated";
 387     my $user = Debbugs::User->new($email,1); # locked
 388     $user->{"tags"} = { %{$usertags} };
 389     $user->write();
 390 }
 391
 392
 393 =head1 PRIVATE FUNCTIONS
 394
 395 =head2 _read_stanza
 396
 397      my @stanza = _read_stanza($fh);
 398
 399 Reads a single stanza from a filehandle and returns it
 400
 401 =cut
 402
 403 sub _read_stanza {
 404     my ($file_handle) = @_;
 405     my $field = 0;
 406     my @res;
 407     while (<$file_handle>) {
 408          chomp;
 409          last if (m/^$/);
 410          if ($field && m/^ (.*)$/) {
 411               $res[-1] .= "\n" . $1;
 412          } elsif (m/^([^:]+):(\s+(.*))?$/) {
 413               $field = $1;
 414               push @res, ($1, $3||'');
 415          }
 416     }
 417     return @res;
 418 }
 419
 420
 421 =head2 _wrap_to_length
 422
 423      _wrap_to_length
 424
 425 Wraps a line to a specific length by splitting at commas
 426
 427 =cut
 428
 429 sub _wrap_to_length {
 430     my ($content,$line_length) = @_;
 431     my $current_line_length = 0;
 432     my $result = "";
 433     while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) {
 434         my $current_word = $1;
 435         $content = $2;
 436         if ($current_line_length != 0 and
 437             $current_line_length + length($current_word) <= $line_length) {
 438             $result .= "\n ";
 439             $current_line_length = 1;
 440         }
 441         $result .= $current_word;
 442         $current_line_length += length($current_word);
 443     }
 444     return $result . $content;
 445 }
 446
 447
 448
 449
 450 1;
 451
 452 __END__