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 =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                 email => $email,
 158                };
 159     bless $self, $class;
 160
 161     $self->{filename} = usertag_file_from_email($self->{email});
 162     if (not -r $self->{filename}) {
 163          return $self;
 164     }
 165     my $uf = IO::File->new($self->{filename},'r')
 166          or die "Unable to open file $self->{filename} for reading: $!";
 167     if ($need_lock) {
 168         flock($uf, LOCK_EX);
 169         $self->{"locked"} = $uf;
 170     }
 171
 172     while(1) {
 173         my @stanza = _read_stanza($uf);
 174         last unless @stanza;
 175         if ($stanza[0] eq "Tag") {
 176             my %tag = @stanza;
 177             my $t = $tag{"Tag"};
 178             $ut->{$t} = [] unless defined $ut->{$t};
 179             push @{$ut->{$t}}, split /\s*,\s*/, $tag{Bugs};
 180         } elsif ($stanza[0] eq "Category") {
 181             my @cat = ();
 182             my %stanza = @stanza;
 183             my $catname = $stanza{"Category"};
 184             my $i = 0;
 185             while (++$i && defined $stanza{"Cat${i}"}) {
 186                 if (defined $stanza{"Cat${i}Options"}) {
 187                     # parse into a hash
 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"};
 193                          my %temp;
 194                          my $min = min(@temp);
 195                          # Order to 0 minimum; strip duplicates
 196                          $c{ord} = [map {$temp{$_}++;
 197                                          $temp{$_}>1?():($_-$min);
 198                                     } @temp
 199                                    ];
 200                     }
 201                     my @pri; my @ttl;
 202                     for my $l (split /\n/, $stanza{"Cat${i}Options"}) {
 203                         if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) {
 204                             push @pri, $1;
 205                             push @ttl, $2;
 206                         } elsif ($l =~ m/^\s*(\S+)\s*$/) {
 207                             push @pri, $1;
 208                             push @ttl, $1;
 209                         }
 210                     }
 211                     $c{"ttl"} = [@ttl];
 212                     $c{"pri"} = [@pri];
 213                     push @cat, { %c };
 214                 } else {
 215                     push @cat, $stanza{"Cat${i}"};
 216                 }
 217             }
 218             $self->{"categories"}->{$catname} = [@cat];
 219             push @{$self->{"visible_cats"}}, $catname
 220                 unless ($stanza{"Hidden"} || "no") eq "yes";
 221         }
 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;
 228             }
 229         }
 230         else {
 231             push @{$self->{"unknown_stanzas"}}, [@stanza];
 232         }
 233     }
 234
 235     return $self;
 236 }
 237
 238 sub write {
 239     my $self = shift;
 240
 241     my $ut = $self->{"tags"};
 242     my $p = $self->{"filename"};
 243
 244     if (not defined $self->{filename} or not
 245         length $self->{filename}) {
 246          carp "Tried to write a usertag with no filename defined";
 247          return;
 248     }
 249     my $uf = IO::File->new($self->{filename},'w');
 250     if (not $uf) {
 251          carp "Unable to open $self->{filename} for writing: $!";
 252          return;
 253     }
 254
 255     for my $us (@{$self->{"unknown_stanzas"}}) {
 256         my @us = @{$us};
 257         while (my ($k,$v) = splice (@us,0,2)) {
 258             $v =~ s/\n/\n /g;
 259             print {$uf} "$k: $v\n";
 260         }
 261         print {$uf} "\n";
 262     }
 263
 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";
 268         print $uf "\n";
 269     }
 270
 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;
 275
 276         print $uf "Category: $c\n";
 277         print $uf "Hidden: yes\n" unless defined $vis{$c};
 278         my $i = 0;
 279         for my $cat (@{$uc->{$c}}) {
 280             $i++;
 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];
 288                     } else {
 289                         printf $uf " %s\n", $cat->{"pri"}->[$j];
 290                     }
 291                 }
 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"};
 296             } else {
 297                 printf $uf "Cat%d: %s\n", $i, $cat;
 298             }
 299         }
 300         print $uf "\n";
 301     }
 302     # handle the value stanzas
 303     my %value;
 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}
 308          }
 309     }
 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";
 316          }
 317          print {$uf} "\n";
 318     }
 319
 320     close($uf);
 321     delete $self->{"locked"};
 322 }
 323
 324 =head1 OBSOLETE FUNCTIONS
 325
 326 =cut
 327
 328 =head2 read_usertags
 329
 330      read_usertags($usertags,$email)
 331
 332
 333 =cut
 334
 335 sub read_usertags {
 336     my ($usertags,$email) = @_;
 337
 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}};
 343     }
 344     return $usertags;
 345 }
 346
 347 =head2 write_usertags
 348
 349      write_usertags($usertags,$email);
 350
 351 Gets a lock on the usertags, applies the usertags passed, and writes
 352 them out.
 353
 354 =cut
 355
 356 sub write_usertags {
 357     my ($usertags,$email) = @_;
 358
 359 #    carp "write_usertags is deprecated";
 360     my $user = Debbugs::User->new($email,1); # locked
 361     $user->{"tags"} = { %{$usertags} };
 362     $user->write();
 363 }
 364
 365
 366 =head1 PRIVATE FUNCTIONS
 367
 368 =head2 _read_stanza
 369
 370      my @stanza = _read_stanza($fh);
 371
 372 Reads a single stanza from a filehandle and returns it
 373
 374 =cut
 375
 376 sub _read_stanza {
 377     my ($file_handle) = @_;
 378     my $field = 0;
 379     my @res;
 380     while (<$file_handle>) {
 381          chomp;
 382          last if (m/^$/);
 383          if ($field && m/^ (.*)$/) {
 384               $res[-1] .= "\n" . $1;
 385          } elsif (m/^([^:]+):(\s+(.*))?$/) {
 386               $field = $1;
 387               push @res, ($1, $3||'');
 388          }
 389     }
 390     return @res;
 391 }
 392
 393
 394 =head2 _wrap_to_length
 395
 396      _wrap_to_length
 397
 398 Wraps a line to a specific length by splitting at commas
 399
 400 =cut
 401
 402 sub _wrap_to_length {
 403     my ($content,$line_length) = @_;
 404     my $current_line_length = 0;
 405     my $result = "";
 406     while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) {
 407         my $current_word = $1;
 408         $content = $2;
 409         if ($current_line_length != 0 and
 410             $current_line_length + length($current_word) <= $line_length) {
 411             $result .= "\n ";
 412             $current_line_length = 1;
 413         }
 414         $result .= $current_word;
 415         $current_line_length += length($current_word);
 416     }
 417     return $result . $content;
 418 }
 419
 420
 421
 422
 423 1;
 424
 425 __END__