From ca9c40eefc0587ed7a876370a393913a29237cc5 Mon Sep 17 00:00:00 2001 From: ajt <> Date: Sun, 9 Oct 2005 13:17:41 -0800 Subject: [PATCH] [project @ 2005-10-09 14:17:41 by ajt] restructure User.pm (deal with perl objects by preference instead of a usertag hash) and add support for user categories. darcs changelog: * first pass refactoring of User.pm * make locking functional * add support for unknown stanzas, and first pass at reading usercategories * fix writing of unknown stanzas with multiline fields * deal with multiline fields that don't have a summary line * remove categories-by-cookie support, restructure category handling for proper user-categories * convert from add_usertags to add_user syntax * cope with new user ids * drop support for Prefix in the user files * add support for recording categories * finish off support for usercategory command * finish adding support for user categories --- Debbugs/User.pm | 238 ++++++++++++++++++++++++------- cgi/pkgreport.cgi | 339 ++++++++++++++++++++------------------------- scripts/service.in | 77 +++++++++- 3 files changed, 416 insertions(+), 238 deletions(-) diff --git a/Debbugs/User.pm b/Debbugs/User.pm index fff2eea..68ae1c4 100644 --- a/Debbugs/User.pm +++ b/Debbugs/User.pm @@ -9,6 +9,20 @@ Debbugs::User -- User settings use Debbugs::User qw(is_valid_user read_usertags write_usertags); +Debbugs::User::is_valid_user($userid); + +$u = Debbugs::User::open($userid); +$u = Debbugs::User::open(user => $userid, locked => 0); + +$u = Debbugs::User::open(user => $userid, locked => 1); +$u->write(); + +$u->{"tags"} +$u->{"categories"} +$u->{"is_locked"} +$u->{"name"} + + read_usertags(\%ut, $userid); write_usertags(\%ut, $userid); @@ -26,31 +40,52 @@ write_usertags(\%ut, $userid); use warnings; use strict; +use Fcntl ':flock'; use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use base qw(Exporter); BEGIN { - ($VERSION) = q$Revision: 1.2 $ =~ /^Revision:\s+([^\s+])/; + ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; $DEBUG = 0 unless defined $DEBUG; @EXPORT = (); - @EXPORT_OK = qw(is_valid_user read_usertags write_usertags); + @EXPORT_OK = qw(is_valid_user open); $EXPORT_TAGS{all} = [@EXPORT_OK]; } - my $gSpoolPath = "/org/bugs.debian.org/spool"; -sub esc { - my $s = shift; - if ($s =~ m/^[0-9a-zA-Z_+.-]$/) { return $s; } - else { return sprintf("%%%02X", ord($s)); } -} +# Obsolete compatability functions + +sub read_usertags { + my $ut = shift; + my $u = shift; + + my $user = get_user($u); + for my $t (keys %{$user->{"tags"}}) { + $ut->{$t} = [] unless defined $ut->{$t}; + push @{$ut->{$t}}, @{$user->{"tags"}->{$t}}; + } +} + +sub write_usertags { + my $ut = shift; + my $u = shift; + + my $user = get_user($u, 1); # locked + $user->{"tags"} = { %{$ut} }; + $user->write(); +} + +####################################################################### +# Helper functions sub filefromemail { my $e = shift; my $l = length($e) % 7; - return "$gSpoolPath/user/$l/" . join("", map { esc($_); } split //, $e); + return "$gSpoolPath/user/$l/" . join("", + map { m/^[0-9a-zA-Z_+.-]$/ ? $_ : sprintf("%%%02X", ord($_)) } + split //, $e); } sub read_stanza { @@ -58,39 +93,19 @@ sub read_stanza { my $field = 0; my @res; while (<$f>) { - chomp; - last if (m/^$/); + chomp; + last if (m/^$/); if ($field && m/^ (.*)$/) { $res[-1] .= "\n" . $1; - } elsif (m/^([^:]+):\s+(.*)$/) { + } elsif (m/^([^:]+):(\s+(.*))?$/) { $field = $1; - push @res, ($1, $2); + push @res, ($1, $3); } } return @res; } -sub read_usertags { - my $ut = shift; - my $u = shift; - my $p = filefromemail($u); - my $uf; - - open($uf, "< $p") or return; - while(1) { - my @stanza = read_stanza($uf); - last if ($#stanza == -1); - if ($stanza[0] eq "Tag") { - my %tag = @stanza; - my $t = $tag{"Tag"}; - $ut->{$t} = [] unless defined $ut->{$t}; - push @{$ut->{$t}}, split /\s*,\s*/, $tag{Bugs}; - } - } - close($uf); -} - sub fmt { my $s = shift; my $n = shift; @@ -98,37 +113,158 @@ sub fmt { my $res = ""; while ($s =~ m/^([^,]*,\s*)(.*)$/ || $s =~ m/^([^,]+)()$/) { my $k = $1; - $s = $2; + $s = $2; unless ($sofar == 0 or $sofar + length($k) <= $n) { - $res .= "\n "; - $sofar = 1; - } - $res .= $k; - $sofar += length($k); + $res .= "\n "; + $sofar = 1; + } + $res .= $k; + $sofar += length($k); } return $res . $s; } -sub write_usertags { - my $ut = shift; +sub is_valid_user { + my $u = shift; + return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/); +} + +####################################################################### +# The real deal + +sub get_user { + my $ut = {}; + my $user = { + "tags" => $ut, + "categories" => {}, + "visible_cats" => [], + "unknown_stanzas" => [] + }; + my $u = shift; + my $need_lock = shift || 0; my $p = filefromemail($u); - open(U, "> $p") or die "couldn't write to $p"; + my $uf; + $user->{"filename"} = $p; + open($uf, "< $p") or bless $user, "Debbugs::User"; + if ($need_lock) { + flock($uf, LOCK_EX); + $user->{"locked"} = $uf; + } + + while(1) { + my @stanza = read_stanza($uf); + last if ($#stanza == -1); + if ($stanza[0] eq "Tag") { + my %tag = @stanza; + my $t = $tag{"Tag"}; + $ut->{$t} = [] unless defined $ut->{$t}; + push @{$ut->{$t}}, split /\s*,\s*/, $tag{Bugs}; + } elsif ($stanza[0] eq "Category") { + my @cat = (); + my %stanza = @stanza; + my $catname = $stanza{"Category"}; + my $i = 0; + while (++$i && defined $stanza{"Cat${i}"}) { + if (defined $stanza{"Cat${i}Options"}) { + # parse into a hash + my %c = ("nam" => $stanza{"Cat${i}"}); + $c{"def"} = $stanza{"Cat${i}Default"} + if defined $stanza{"Cat${i}Default"}; + $c{"ord"} = [ split /,/, $stanza{"Cat${i}Order"} ] + if defined $stanza{"Cat${i}Order"}; + my @pri; my @ttl; + for my $l (split /\n/, $stanza{"Cat${i}Options"}) { + if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) { + push @pri, $1; + push @ttl, $2; + } elsif ($l =~ m/^\s*(\S+)\s*$/) { + push @pri, $1; + push @ttl, $1; + } + } + $c{"ttl"} = [@ttl]; + $c{"pri"} = [@pri]; + push @cat, { %c }; + } else { + push @cat, $stanza{"Cat${i}"}; + } + } + $user->{"categories"}->{$catname} = [@cat]; + push @{$user->{"visible_cats"}}, $catname + unless ($stanza{"Hidden"} || "no") eq "yes"; + } else { + push @{$user->{"unknown_stanzas"}}, [@stanza]; + } + } + close($uf) unless $need_lock; + + bless $user, "Debbugs::User"; + return $user; +} + +sub write { + my $user = shift; + my $uf; + my $ut = $user->{"tags"}; + my $p = $user->{"filename"}; + + if ($p =~ m/^(.+)$/) { $p = $1; } else { return; } + open $uf, "> $p" or return; + + for my $us (@{$user->{"unknown_stanzas"}}) { + my @us = @{$us}; + while (@us) { + my $k = shift @us; my $v = shift @us; + $v =~ s/\n/\n /g; + print $uf "$k: $v\n"; + } + print $uf "\n"; + } + for my $t (keys %{$ut}) { next if @{$ut->{$t}} == 0; - print U "Tag: $t\n"; - print U fmt("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n"; - print U "\n"; + print $uf "Tag: $t\n"; + print $uf fmt("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n"; + print $uf "\n"; } - close(U); -} -sub is_valid_user { - my $u = shift; - return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/); -} + my $uc = $user->{"categories"}; + my %vis = map { $_, 1 } @{$user->{"visible_cats"}}; + for my $c (keys %{$uc}) { + next if @{$uc->{$c}} == 0; + print $uf "Category: $c\n"; + print $uf "Hidden: yes\n" unless defined $vis{$c}; + my $i = 0; + for my $cat (@{$uc->{$c}}) { + $i++; + if (ref($cat) eq "HASH") { + printf $uf "Cat%d: %s\n", $i, $cat->{"nam"}; + printf $uf "Cat%dOptions:\n", $i; + for my $j (0..$#{$cat->{"pri"}}) { + if (defined $cat->{"ttl"}->[$j]) { + printf $uf " %s - %s\n", + $cat->{"pri"}->[$j], $cat->{"ttl"}->[$j]; + } else { + printf $uf " %s\n", $cat->{"pri"}->[$j]; + } + } + printf $uf "Cat%dDefault: %s\n", $i, $cat->{"def"} + if defined $cat->{"def"}; + printf $uf "Cat%dOrder: %s\n", $i, join(", ", @{$cat->{"ord"}}) + if defined $cat->{"ord"}; + } else { + printf $uf "Cat%d: %s\n", $i, $cat; + } + } + print $uf "\n"; + } + + close($uf); + delete $user->{"locked"}; +} 1; diff --git a/cgi/pkgreport.cgi b/cgi/pkgreport.cgi index afbf4a6..9387f59 100755 --- a/cgi/pkgreport.cgi +++ b/cgi/pkgreport.cgi @@ -12,9 +12,8 @@ require '/etc/debbugs/config'; require '/etc/debbugs/text'; use Debbugs::User; -my $cats = 5; -use vars qw($gPackagePages $gWebDomain); +use vars qw($gPackagePages $gWebDomain %gSeverityDisplay @gSeverityList); if (defined $ENV{REQUEST_METHOD} and $ENV{REQUEST_METHOD} eq 'HEAD') { print "Content-Type: text/html; charset=utf-8\n\n"; @@ -38,7 +37,7 @@ my $raw_sort = ($param{'raw'} || "no") eq "yes"; my $old_view = ($param{'oldview'} || "no") eq "yes"; unless (defined $ordering) { $ordering = "normal"; - $ordering = "old" if $old_view; + $ordering = "oldview" if $old_view; $ordering = "raw" if $raw_sort; } @@ -57,97 +56,6 @@ my $arch = $param{'arch'} || undef; my $show_list_header = ($param{'show_list_header'} || $userAgent->{'show_list_header'} || "yes" ) eq "yes"; my $show_list_footer = ($param{'show_list_footer'} || $userAgent->{'show_list_footer'} || "yes" ) eq "yes"; -my @p = ( - "pending:pending,forwarded,pending-fixed,fixed,done,absent", - "severity:critical,grave,serious,important,normal,minor,wishlist", - "pending=pending+tag=wontfix,pending=pending+tag=moreinfo,pending=pending+tag=patch,pending=pending+tag=confirmed,pending=pending"); -my @t = ( - "Outstanding,Forwarded,Pending Upload,Fixed in NMU,Resolved,From other Branch,Unknown Pending Status", - "Critical,Grave,Serious,Important,Normal,Minor,Wishlist,Unknown Severity", - "Will Not Fix,More information needed,Patch Available,Confirmed,Unclassified"); -my @o = ("0,1,2,3,4,5,6","0,1,2,3,4,5,6,7","2,3,4,1,0,5"); -my @n = ("Status", "Severity", "Classification"); - -if ($ordering eq "old") { - splice @p, 2, 1; - splice @t, 2, 1; - splice @o, 2, 1; - splice @n, 2, 1; -} -$o[0] = scalar reverse($o[0]) if ($pend_rev); -$o[1] = scalar reverse($o[1]) if ($sev_rev); - -if (!defined $param{"pri0"} && $ordering =~ m/^user(\d+)$/) { - my $id = $1; - my $l = 0; - if (defined $param{"cat${id}_users"}) { - $users .= "," . $param{"cat${id}_users"}; - } - while (defined $param{"cat${id}_nam$l"}) { - my ($n, $p, $t, $o) = - map { $param{"cat${id}_${_}$l"} || "" } - ("nam", "pri", "ttl", "ord"); - if ($p eq "") { - if ($n eq "status") { - ($p, $t, $o) = ($p[0], $t[0], $o[0]); - } elsif ($n eq "severity") { - ($p, $t, $o) = ($p[1], $t[1], $o[1]) - } else { - $ordering = "raw"; - last; - } - } - $param{"nam$l"} = $n; - $param{"pri$l"} = $p; - $param{"ttl$l"} = $t; - $param{"ord$l"} = $o; - $l++; - } -} -if (defined $param{"pri0"}) { - my $i = 0; - @p = (); @o = (); @t = (); @n = (); - while (defined $param{"pri$i"}) { - push @p, $param{"pri$i"}; - push @o, $param{"ord$i"} || ""; - push @t, $param{"ttl$i"} || ""; - push @n, $param{"nam$i"} || ""; - $i++; - } -} -for my $x (@p) { - next if "$x," =~ m/^(pending|severity|tag):(([*]|[a-z0-9.-]+),)+$/; - next if "$x," =~ m/^((pending|severity|tag)=([*]|[a-z0-9.-]+)[,+])+/; - quitcgi("Bad syntax in Priority: $x"); -} - -my @names; my @prior; my @title; my @order; -for my $i (0..$#p) { - push @prior, [ make_order_list($p[$i]) ]; - if ($n[$i]) { - push @names, $n[$i]; - } elsif ($p[$i] =~ m/^([^:]+):/) { - push @names, $1; - } else { - push @names, "Bug attribute #" . (1+$i); - } - if ($o[$i]) { - push @order, [ split /,/, $o[$i] ]; - } else { - push @order, [ 0..$#{$prior[$i]} ]; - } - my @t = split /,/, $t[$i]; - push @t, map { toenglish($prior[$i]->[$_]) } ($#t+1)..($#{$prior[$i]}); - push @title, [@t]; -} - -sub toenglish { - my $expr = shift; - $expr =~ s/[+]/ and /g; - $expr =~ s/[a-z]+=//g; - return $expr; -} - { if (defined $param{'vt'}) { my $vt = $param{'vt'}; @@ -169,6 +77,40 @@ sub toenglish { } +my %hidden = map { $_, 1 } qw(status severity classification); +my %cats = ( + "status" => [ { + "nam" => "Status", + "pri" => [map { "pending=$_" } + qw(pending forwarded pending-fixed fixed done absent)], + "ttl" => ["Outstanding","Forwarded","Pending Upload", + "Fixed in NMU","Resolved","From other Branch"], + "def" => "Unknown Pending Status", + "ord" => [0,1,2,3,4,5,6], + } ], + "severity" => [ { + "nam" => "Severity", + "pri" => [map { "severity=$_" } @debbugs::gSeverityList], + "ttl" => [map { $debbugs::gSeverityDisplay{$_} } @debbugs::gSeverityList], + "def" => "Unknown Severity", + "ord" => [0,1,2,3,4,5,6,7], + } ], + "classification" => [ { + "nam" => "Classification", + "pri" => [qw(pending=pending+tag=wontfix + pending=pending+tag=moreinfo + pending=pending+tag=patch + pending=pending+tag=confirmed + pending=pending)], + "ttl" => ["Will Not Fix","More information needed", + "Patch Available","Confirmed"], + "def" => "Unclassified", + "ord" => [2,3,4,1,0,5], + } ], + "oldview" => [ qw(status severity) ], + "normal" => [ qw(status severity classification) ], +); + my ($pkg, $src, $maint, $maintenc, $submitter, $severity, $status, $tag, $usertag); my %which = ( @@ -217,7 +159,7 @@ my %bugusertags; my %ut; for my $user (split /[\s*,]+/, $users) { next unless ($user =~ m/..../); - add_usertags(\%ut, $user); + add_user($user); } if (defined $usertag) { @@ -228,7 +170,7 @@ if (defined $usertag) { $t = join(",", keys(%select_ut)); } - add_usertags(\%ut, $u); + add_user($u); $tag = $t; } @@ -264,10 +206,22 @@ set_option("use-bug-idx", defined($param{'use-bug-idx'}) ? $param{'use-bug-idx'} set_option("show_list_header", $show_list_header); set_option("show_list_footer", $show_list_footer); -sub add_usertags { - my $ut = shift; +sub add_user { + my $ut = \%ut; my $u = shift; - Debbugs::User::read_usertags($ut, $u); + + my $user = Debbugs::User::get_user($u); + + my %vis = map { $_, 1 } @{$user->{"visible_cats"}}; + for my $c (keys %{$user->{"categories"}}) { + $cats{$c} = $user->{"categories"}->{$c}; + $hidden{$c} = 1 unless defined $vis{$c}; + } + + for my $t (keys %{$user->{"tags"}}) { + $ut->{$t} = [] unless defined $ut->{$t}; + push @{$ut->{$t}}, @{$user->{"tags"}->{$t}}; + } %bugusertags = (); for my $t (keys %{$ut}) { @@ -278,13 +232,12 @@ sub add_usertags { } set_option("bugusertags", \%bugusertags); } - my $title; my @bugs; if (defined $pkg) { $title = "package $pkg"; - add_usertags(\%ut, "$pkg\@packages.debian.org"); + add_user("$pkg\@packages.debian.org"); if (defined $version) { $title .= " (version $version)"; } elsif (defined $dist) { @@ -300,7 +253,7 @@ if (defined $pkg) { return 0; }, 'package', @pkgs)}; } elsif (defined $src) { - add_usertags(\%ut, "$src\@packages.debian.org"); + add_user("$src\@packages.debian.org"); $title = "source $src"; set_option('arch', 'source'); if (defined $version) { @@ -324,7 +277,7 @@ if (defined $pkg) { }, 'package', @pkgs)}; } elsif (defined $maint) { my %maintainers = %{getmaintainers()}; - add_usertags(\%ut, $maint); + add_user($maint); $title = "maintainer $maint"; $title .= " in $dist" if defined $dist; if ($maint eq "") { @@ -365,7 +318,7 @@ if (defined $pkg) { return 0; })}; } elsif (defined $submitter) { - add_usertags(\%ut, $submitter); + add_user($submitter); $title = "submitter $submitter"; $title .= " in $dist" if defined $dist; my @submitters = split /,/, $submitter; @@ -408,6 +361,9 @@ if (defined $pkg) { })}; } +my @names; my @prior; my @title; my @order; +determine_ordering(); + my $result = pkg_htmlizebugs(\@bugs); print "Content-Type: text/html; charset=utf-8\n\n"; @@ -549,7 +505,7 @@ my $vismaxdays = ($maxdays == -1 ? "" : $maxdays); my $sel_rmy = ($repeatmerged ? " selected" : ""); my $sel_rmn = ($repeatmerged ? "" : " selected"); my $sel_ordraw = ($ordering eq "raw" ? " selected" : ""); -my $sel_ordold = ($ordering eq "old" ? " selected" : ""); +my $sel_ordold = ($ordering eq "oldview" ? " selected" : ""); my $sel_ordnor = ($ordering eq "normal" ? " selected" : ""); my $chk_bugrev = ($bug_rev ? " checked" : ""); @@ -572,22 +528,27 @@ print <Categorise bugs by \n"; -my $default = 1; -for my $i (1..$cats) { - my $name = get_cat_name($i); - unless (defined $name) { - $name = "(unused)"; - $default = $i if $default == 0; - } - printf "\n", - $i, ($default == $i ? " selected" : ""), $i, $name; -} -my $defusers = $param{"cat${default}_users"} || $users; -print "\n"; -print "Include usertags set by\n"; -print "\n"; -print " \n"; - -for my $level (0..3) { - my $hlevel = $level + 1; - my ($n, $s, $t, $o) = - map { $param{"cat${default}_${_}${level}"} || "" } - ("nam", "pri", "ttl", "ord"); - - print <Level$hlevel -Name -Sections -Titles -Ordering -  -EOF -} - -print <Commit new ordering -EOF - -print "\n"; - print "
\n"; print "

$tail_html"; @@ -821,7 +711,6 @@ sub pkg_htmlizebugs { my $key = ""; for my $i (0..$#prior) { my $v = get_bug_order_index($prior[$i], \%status); - my $k = $prior[$i]->[$v]; $count{"g_${i}_${v}"}++; $key .= "_$v"; } @@ -852,7 +741,7 @@ sub pkg_htmlizebugs { my $title = $title[0]->[$ttl[0]] . " bugs"; if ($#ttl > 0) { $title .= " -- "; - $title .= join("; ", grep {$_ ne ""} + $title .= join("; ", grep {($_ || "") ne ""} map { $title[$_]->[$ttl[$_]] } 1..$#ttl); } @@ -1104,7 +993,7 @@ sub get_bug_order_index { last; } } - return -1; + return $pos + 1; } sub buglinklist { @@ -1117,3 +1006,81 @@ sub buglinklist { } return $r; } + + +# sets: my @names; my @prior; my @title; my @order; + +sub determine_ordering { + $cats{"status"}->{"ord"} = [ reverse @{$cats{"status"}->{"ord"}} ] + if ($pend_rev); + $cats{"severity"}->{"ord"} = [ reverse @{$cats{"severity"}->{"ord"}} ] + if ($sev_rev); + + if (defined $param{"pri0"}) { + my @c = (); + my $i = 0; + while (defined $param{"pri$i"}) { + my $h = {}; + + my $pri = $param{"pri$i"}; + if ($pri =~ m/^([^:]*):(.*)$/) { + $h->{"nam"} = $1; # overridden later if necesary + $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ]; + } else { + $h->{"pri"} = [ split /,/, $pri ]; + } + + $h->{"nam"} = $param{"nam$i"} + if (defined $param{"nam$i"}); + $h->{"ord"} = [ split /,/, $param{"ord$i"} ] + if (defined $param{"ord$i"}); + $h->{"ttl"} = [ split /,/, $param{"ttl$i"} ] + if (defined $param{"ttl$i"}); + + push @c, $h; + $i++; + } + $cats{"_"} = [@c]; + $ordering = "_"; + } + + $ordering = "normal" unless defined $cats{$ordering}; + + sub get_ordering { + my @res; + my $cats = shift; + my $o = shift; + for my $c (@{$cats->{$o}}) { + if (ref($c) eq "HASH") { + push @res, $c; + } else { + push @res, get_ordering($cats, $c); + } + } + return @res; + } + my @cats = get_ordering(\%cats, $ordering); + + sub toenglish { + my $expr = shift; + $expr =~ s/[+]/ and /g; + $expr =~ s/[a-z]+=//g; + return $expr; + } + + my $i = 0; + for my $c (@cats) { + $i++; + push @prior, $c->{"pri"}; + push @names, ($c->{"nam"} || "Bug attribute #" . $i); + if (defined $c->{"ord"}) { + push @order, $c->{"ord"}; + } else { + push @order, [ 0..$#{$prior[-1]} ]; + } + my @t = @{ $c->{"ttl"} }; + push @t, map { toenglish($prior[-1]->[$_]) } ($#t+1)..($#{$prior[-1]}); + push @t, $c->{"def"} || ""; + push @title, [@t]; + } +} diff --git a/scripts/service.in b/scripts/service.in index 382b0cd..35d4946 100755 --- a/scripts/service.in +++ b/scripts/service.in @@ -1,5 +1,5 @@ #!/usr/bin/perl -# $Id: service.in,v 1.116 2005/10/09 14:03:32 ajt Exp $ +# $Id: service.in,v 1.117 2005/10/09 14:17:41 ajt Exp $ # # Usage: service .nn # Temps: incoming/P.nn @@ -254,6 +254,81 @@ END &transcript("Selected user id ($newuser) invalid, sorry\n"); $user = ""; } + } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) { + $ok++; + my $catname = $1; + my $hidden = ($2 ne ""); + + my $prefix = ""; + my @cats; + my $bad = 0; + my $catsec = 0; + while (++$procline <= $#bodylines) { + unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) { + $procline--; + last; + } + &transcript("> $bodylines[$procline]\n"); + next if $bad; + my ($o, $txt) = ($1, $2); + if ($#cats == -1 && $o eq "+") { + &transcript("User defined category specification must start with a category name. Skipping.\n\n"); + $bad = 1; + next; + } + if ($o eq "+") { + unless (ref($cats[-1]) eq "HASH") { + $cats[-1] = { "nam" => $cats[-1], + "pri" => [], "ttl" => [] }; + } + $catsec++; + my ($desc, $ord, $op); + if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) { + $desc = $1; $ord = $3; $op = ""; + } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) { + $desc = $1; $ord = $3; $op = $4; + } elsif ($txt =~ m/^([^[\s]+)\s*$/) { + $desc = ""; $op = $1; + } else { + &transcript("Unrecognised syntax for category section. Skipping.\n\n"); + $bad = 1; + next; + } + $ord = 999 unless defined $ord; + + if ($op) { + push @{$cats[-1]->{"pri"}}, $prefix . $op; + push @{$cats[-1]->{"ttl"}}, $desc; + push @ords, "$ord $catsec"; + } else { + @cats[-1]->{"def"} = $desc; + push @ords, "$ord DEF"; + $catsec--; + } + @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b"; + $a1 <=> $b1 || $a2 <=> $b2; } @ords; + $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords]; + } elsif ($o eq "*") { + $catsec = 0; + my ($name); + if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) { + $name = $1; $prefix = $3; + } else { + $name = $txt; $prefix = ""; + } + push @cats, $name; + } + } + # XXX: got @cats, now do something with it + my $u = Debbugs::User::get_user($user); + if (@cats) { + &transcript("Added usercategory $catname.\n\n"); + $u->{"categories"}->{$catname} = [ @cats ]; + } else { + &transcript("Removed usercategory $catname.\n\n"); + delete $u->{"categories"}->{$catname}; + } + $u->write(); } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) { $ok++; $ref = $1; $addsubcode = $3 || "+"; $tags = $4; -- 2.39.2