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 base qw(Exporter);
  87
  88 use Debbugs::Config qw(:config);
  89 use List::Util 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 #######################################################################
 113 # The real deal
 114
 115 sub get_user {
 116      return Debbugs::User->new(@_);
 117 }
 118
 119 =head2 new
 120
 121      my $user = Debbugs::User->new('foo@bar.com',$lock);
 122
 123 Reads the user file associated with 'foo@bar.com' and returns a
 124 Debbugs::User object.
 125
 126 =cut
 127
 128 sub new {
 129     my $class = shift;
 130     $class = ref($class) || $class;
 131     my ($email,$need_lock) = @_;
 132     $need_lock ||= 0;
 133
 134     my $ut = {};
 135     my $self = {"tags" => $ut,
 136                 "categories" => {},
 137                 "visible_cats" => [],
 138                 "unknown_stanzas" => [],
 139                 values => {},
 140                 email => $email,
 141                };
 142     bless $self, $class;
 143
 144     $self->{filename} = _file_from_email($self->{email});
 145     if (not -r $self->{filename}) {
 146          return $self;
 147     }
 148     my $uf = IO::File->new($self->{filename},'r')
 149          or die "Unable to open file $self->{filename} for reading: $!";
 150     if ($need_lock) {
 151         flock($uf, LOCK_EX);
 152         $self->{"locked"} = $uf;
 153     }
 154
 155     while(1) {
 156         my @stanza = _read_stanza($uf);
 157         last unless @stanza;
 158         if ($stanza[0] eq "Tag") {
 159             my %tag = @stanza;
 160             my $t = $tag{"Tag"};
 161             $ut->{$t} = [] unless defined $ut->{$t};
 162             push @{$ut->{$t}}, split /\s*,\s*/, $tag{Bugs};
 163         } elsif ($stanza[0] eq "Category") {
 164             my @cat = ();
 165             my %stanza = @stanza;
 166             my $catname = $stanza{"Category"};
 167             my $i = 0;
 168             while (++$i && defined $stanza{"Cat${i}"}) {
 169                 if (defined $stanza{"Cat${i}Options"}) {
 170                     # parse into a hash
 171                     my %c = ("nam" => $stanza{"Cat${i}"});
 172                     $c{"def"} = $stanza{"Cat${i}Default"}
 173                         if defined $stanza{"Cat${i}Default"};
 174                     if (defined $stanza{"Cat${i}Order"}) {
 175                          my @temp = split /\s*,\s*/, $stanza{"Cat${i}Order"};
 176                          my %temp;
 177                          my $min = min(@temp);
 178                          # Order to 0 minimum; strip duplicates
 179                          $c{ord} = [map {$temp{$_}++;
 180                                          $temp{$_}>1?():($_-$min);
 181                                     } @temp
 182                                    ];
 183                     }
 184                     my @pri; my @ttl;
 185                     for my $l (split /\n/, $stanza{"Cat${i}Options"}) {
 186                         if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) {
 187                             push @pri, $1;
 188                             push @ttl, $2;
 189                         } elsif ($l =~ m/^\s*(\S+)\s*$/) {
 190                             push @pri, $1;
 191                             push @ttl, $1;
 192                         }
 193                     }
 194                     $c{"ttl"} = [@ttl];
 195                     $c{"pri"} = [@pri];
 196                     push @cat, { %c };
 197                 } else {
 198                     push @cat, $stanza{"Cat${i}"};
 199                 }
 200             }
 201             $self->{"categories"}->{$catname} = [@cat];
 202             push @{$self->{"visible_cats"}}, $catname
 203                 unless ($stanza{"Hidden"} || "no") eq "yes";
 204         }
 205         elsif ($stanza[0] eq 'Value') {
 206             my ($value,$value_name,%bug_values) = @stanza;
 207             while (my ($k,$v) = each %bug_values) {
 208                 my ($bug) = $k =~ m/^Bug-(\d+)/;
 209                 next unless defined $bug;
 210                 $self->{values}{$bug}{$value_name} = $v;
 211             }
 212         }
 213         else {
 214             push @{$self->{"unknown_stanzas"}}, [@stanza];
 215         }
 216     }
 217
 218     return $self;
 219 }
 220
 221 sub write {
 222     my $self = shift;
 223
 224     my $ut = $self->{"tags"};
 225     my $p = $self->{"filename"};
 226
 227     if (not defined $self->{filename} or not
 228         length $self->{filename}) {
 229          carp "Tried to write a usertag with no filename defined";
 230          return;
 231     }
 232     my $uf = IO::File->new($self->{filename},'w');
 233     if (not $uf) {
 234          carp "Unable to open $self->{filename} for writing: $!";
 235          return;
 236     }
 237
 238     for my $us (@{$self->{"unknown_stanzas"}}) {
 239         my @us = @{$us};
 240         while (my ($k,$v) = splice (@us,0,2)) {
 241             $v =~ s/\n/\n /g;
 242             print {$uf} "$k: $v\n";
 243         }
 244         print {$uf} "\n";
 245     }
 246
 247     for my $t (keys %{$ut}) {
 248         next if @{$ut->{$t}} == 0;
 249         print {$uf} "Tag: $t\n";
 250         print {$uf} _wrap_to_length("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n";
 251         print $uf "\n";
 252     }
 253
 254     my $uc = $self->{"categories"};
 255     my %vis = map { $_, 1 } @{$self->{"visible_cats"}};
 256     for my $c (keys %{$uc}) {
 257         next if @{$uc->{$c}} == 0;
 258
 259         print $uf "Category: $c\n";
 260         print $uf "Hidden: yes\n" unless defined $vis{$c};
 261         my $i = 0;
 262         for my $cat (@{$uc->{$c}}) {
 263             $i++;
 264             if (ref($cat) eq "HASH") {
 265                 printf $uf "Cat%d: %s\n", $i, $cat->{"nam"};
 266                 printf $uf "Cat%dOptions:\n", $i;
 267                 for my $j (0..$#{$cat->{"pri"}}) {
 268                     if (defined $cat->{"ttl"}->[$j]) {
 269                         printf $uf " %s - %s\n",
 270                             $cat->{"pri"}->[$j], $cat->{"ttl"}->[$j];
 271                     } else {
 272                         printf $uf " %s\n", $cat->{"pri"}->[$j];
 273                     }
 274                 }
 275                 printf $uf "Cat%dDefault: %s\n", $i, $cat->{"def"}
 276                     if defined $cat->{"def"};
 277                 printf $uf "Cat%dOrder: %s\n", $i, join(", ", @{$cat->{"ord"}})
 278                     if defined $cat->{"ord"};
 279             } else {
 280                 printf $uf "Cat%d: %s\n", $i, $cat;
 281             }
 282         }
 283         print $uf "\n";
 284     }
 285     # handle the value stanzas
 286     my %value;
 287     # invert the bug->value hash slightly
 288     for my $bug (keys %{$self->{values}}) {
 289          for my $value (keys %{$self->{values}{$bug}}) {
 290               $value{$value}{$bug} = $self->{values}{$bug}{$value}
 291          }
 292     }
 293     for my $value (keys %value) {
 294          print {$uf} "Value: $value\n";
 295          for my $bug (keys %{$value{$value}}) {
 296               my $bug_value = $value{$value}{$bug};
 297               $bug_value =~ s/\n/\n /g;
 298               print {$uf} "Bug-$bug: $bug_value\n";
 299          }
 300          print {$uf} "\n";
 301     }
 302
 303     close($uf);
 304     delete $self->{"locked"};
 305 }
 306
 307 =head1 OBSOLETE FUNCTIONS
 308
 309 =cut
 310
 311 =head2 read_usertags
 312
 313      read_usertags($usertags,$email)
 314
 315
 316 =cut
 317
 318 sub read_usertags {
 319     my ($usertags,$email) = @_;
 320
 321 #    carp "read_usertags is deprecated";
 322     my $user = get_user($email);
 323     for my $tag (keys %{$user->{"tags"}}) {
 324         $usertags->{$tag} = [] unless defined $usertags->{$tag};
 325         push @{$usertags->{$tag}}, @{$user->{"tags"}->{$tag}};
 326     }
 327     return $usertags;
 328 }
 329
 330 =head2 write_usertags
 331
 332      write_usertags($usertags,$email);
 333
 334 Gets a lock on the usertags, applies the usertags passed, and writes
 335 them out.
 336
 337 =cut
 338
 339 sub write_usertags {
 340     my ($usertags,$email) = @_;
 341
 342 #    carp "write_usertags is deprecated";
 343     my $user = Debbugs::User->new($email,1); # locked
 344     $user->{"tags"} = { %{$usertags} };
 345     $user->write();
 346 }
 347
 348
 349 =head1 PRIVATE FUNCTIONS
 350
 351 =head2 _file_from_email
 352
 353      my $filename = _file_from_email($email)
 354
 355 Turns an email into the filename where the usertag can be located.
 356
 357 =cut
 358
 359 sub _file_from_email {
 360     my ($email) = @_;
 361     my $email_length = length($email) % 7;
 362     my $escaped_email = $email;
 363     $escaped_email =~ s/([^0-9a-zA-Z_+.-])/sprintf("%%%02X", ord($1))/eg;
 364     return "$config{usertag_dir}/$email_length/$escaped_email";
 365 }
 366
 367 =head2 _read_stanza
 368
 369      my @stanza = _read_stanza($fh);
 370
 371 Reads a single stanza from a filehandle and returns it
 372
 373 =cut
 374
 375 sub _read_stanza {
 376     my ($file_handle) = @_;
 377     my $field = 0;
 378     my @res;
 379     while (<$file_handle>) {
 380          chomp;
 381          last if (m/^$/);
 382          if ($field && m/^ (.*)$/) {
 383               $res[-1] .= "\n" . $1;
 384          } elsif (m/^([^:]+):(\s+(.*))?$/) {
 385               $field = $1;
 386               push @res, ($1, $3||'');
 387          }
 388     }
 389     return @res;
 390 }
 391
 392
 393 =head2 _wrap_to_length
 394
 395      _wrap_to_length
 396
 397 Wraps a line to a specific length by splitting at commas
 398
 399 =cut
 400
 401 sub _wrap_to_length {
 402     my ($content,$line_length) = @_;
 403     my $current_line_length = 0;
 404     my $result = "";
 405     while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) {
 406         my $current_word = $1;
 407         $content = $2;
 408         if ($current_line_length != 0 and
 409             $current_line_length + length($current_word) <= $line_length) {
 410             $result .= "\n ";
 411             $current_line_length = 1;
 412         }
 413         $result .= $current_word;
 414         $current_line_length += length($current_word);
 415     }
 416     return $result . $content;
 417 }
 418
 419
 420
 421
 422 1;
 423
 424 __END__