Debbugs/User.pm

   1
   2 package Debbugs::User;
   3
   4 =head1 NAME
   5
   6 Debbugs::User -- User settings
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::User qw(is_valid_user read_usertags write_usertags);
  11
  12 read_usertags(\%ut, $userid);
  13 write_usertags(\%ut, $userid);
  14
  15 =head1 EXPORT TAGS
  16
  17 =over
  18
  19 =item :all -- all functions that can be exported
  20
  21 =back
  22
  23 =head1 FUNCTIONS
  24
  25 =cut
  26
  27 use warnings;
  28 use strict;
  29 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  30 use base qw(Exporter);
  31
  32 BEGIN {
  33     ($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/;
  34     $DEBUG = 0 unless defined $DEBUG;
  35
  36     @EXPORT = ();
  37     @EXPORT_OK = qw(is_valid_user read_usertags write_usertags);
  38     $EXPORT_TAGS{all} = [@EXPORT_OK];
  39 }
  40
  41
  42 my $gSpoolPath = "/org/bugs.debian.org/spool";
  43
  44 sub esc {
  45     my $s = shift;
  46     if ($s =~ m/^[0-9a-zA-Z_+.-]$/) { return $s; }
  47     else { return sprintf("%%%02X", ord($s)); }
  48 }
  49
  50 sub filefromemail {
  51     my $e = shift;
  52     my $l = length($e) % 7;
  53     return "$gSpoolPath/user/$l/" . join("", map { esc($_); } split //, $e);
  54 }
  55
  56 sub read_stanza {
  57     my $f = shift;
  58     my $field = 0;
  59     my @res;
  60     while (<$f>) {
  61         chomp;
  62         last if (m/^$/);
  63
  64         if ($field && m/^ (.*)$/) {
  65             $res[-1] .= "\n" . $1;
  66         } elsif (m/^([^:]+):\s+(.*)$/) {
  67             $field = $1;
  68             push @res, ($1, $2);
  69         }
  70     }
  71     return @res;
  72 }
  73
  74 sub read_usertags {
  75     my $ut = shift;
  76     my $u = shift;
  77     my $p = filefromemail($u);
  78     my $uf;
  79
  80     open($uf, "< $p") or return;
  81     while(1) {
  82         my @stanza = read_stanza($uf);
  83         last if ($#stanza == -1);
  84         if ($stanza[0] eq "Tag") {
  85             my %tag = @stanza;
  86             my $t = $tag{"Tag"};
  87             $ut->{$t} = [] unless defined $ut->{$t};
  88             push @{$ut->{$t}}, split /\s*,\s*/, $tag{Bugs};
  89         }
  90     }
  91     close($uf);
  92 }
  93
  94 sub fmt {
  95     my $s = shift;
  96     my $n = shift;
  97     my $sofar = 0;
  98     my $res = "";
  99     while ($s =~ m/^([^,]*,\s*)(.*)$/ || $s =~ m/^([^,]+)()$/) {
 100         my $k = $1;
 101         $s = $2;
 102         unless ($sofar == 0 or $sofar + length($k) <= $n) {
 103             $res .= "\n ";
 104             $sofar = 1;
 105         }
 106         $res .= $k;
 107         $sofar += length($k);
 108     }
 109     return $res . $s;
 110 }
 111
 112 sub write_usertags {
 113     my $ut = shift;
 114     my $u = shift;
 115     my $p = filefromemail($u);
 116
 117     open(U, "> $p") or die "couldn't write to $p";
 118     for my $t (keys %{$ut}) {
 119         next if @{$ut->{$t}} == 0;
 120         print U "Tag: $t\n";
 121         print U fmt("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n";
 122         print U "\n";
 123     }
 124     close(U);
 125 }
 126
 127 sub is_valid_user {
 128     my $u = shift;
 129     return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/);
 130 }
 131
 132
 133 1;
 134
 135 __END__