Debbugs/Common.pm

   1
   2 package Debbugs::Common;
   3
   4 =head1 NAME
   5
   6 Debbugs::Common -- Common routines for all of Debbugs
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::Common qw(:url :html);
  11
  12
  13 =head1 DESCRIPTION
  14
  15 This module is a replacement for the general parts of errorlib.pl.
  16 subroutines in errorlib.pl will be gradually phased out and replaced
  17 with equivalent (or better) functionality here.
  18
  19 =head1 BUGS
  20
  21 This module currently requires /etc/debbugs/config; it should use a
  22 general configuration module so that more intelligent things can be
  23 done.
  24
  25 =head1 FUNCTIONS
  26
  27 =cut
  28
  29 use warnings;
  30 use strict;
  31 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  32 use base qw(Exporter);
  33
  34 BEGIN{
  35      $VERSION = 1.00;
  36      $DEBUG = 0 unless defined $DEBUG;
  37
  38      @EXPORT = ();
  39      %EXPORT_TAGS = (#status => [qw(getbugstatus)],
  40                      read   => [qw(readbug)],
  41                      util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
  42                                ],
  43                     );
  44      @EXPORT_OK = ();
  45      Exporter::export_ok_tags(qw(read util));
  46      $EXPORT_TAGS{all} = [@EXPORT_OK];
  47 }
  48
  49 #use Debbugs::Config qw(:globals);
  50 use Debbugs::Config qw(:config);
  51 use IO::File;
  52 use Debbugs::MIME qw(decode_rfc1522);
  53
  54 =head2 readbug
  55
  56      readbug($bug_number,$location)
  57
  58 Reads a summary file from the archive given a bug number and a bug
  59 location. Valid locations are those understood by L</getbugcomponent>
  60
  61 =cut
  62
  63
  64 my %fields = (originator     => 'submitter',
  65               date           => 'date',
  66               subject        => 'subject',
  67               msgid          => 'message-id',
  68               'package'      => 'package',
  69               keywords       => 'tags',
  70               done           => 'done',
  71               forwarded      => 'forwarded-to',
  72               mergedwith     => 'merged-with',
  73               severity       => 'severity',
  74               owner          => 'owner',
  75               found_versions => 'found-in',
  76               fixed_versions => 'fixed-in',
  77               blocks         => 'blocks',
  78               blockedby      => 'blocked-by',
  79              );
  80
  81 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
  82 my @rfc1522_fields = qw(originator subject done forwarded owner);
  83
  84 sub readbug {
  85     my ($lref, $location) = @_;
  86     my $status = getbugcomponent($lref, 'summary', $location);
  87     return undef unless defined $status;
  88     my $status_fh = new IO::File $status, 'r' or
  89          warn "Unable to open $status for reading: $!" and return undef;
  90
  91     my %data;
  92     my @lines;
  93     my $version = 2;
  94     local $_;
  95
  96     while (<$status_fh>) {
  97         chomp;
  98         push @lines, $_;
  99         $version = $1 if /^Format-Version: ([0-9]+)/i;
 100     }
 101
 102     # Version 3 is the latest format version currently supported.
 103     return undef if $version > 3;
 104
 105     my %namemap = reverse %fields;
 106     for my $line (@lines) {
 107         if ($line =~ /(\S+?): (.*)/) {
 108             my ($name, $value) = (lc $1, $2);
 109             $data{$namemap{$name}} = $value if exists $namemap{$name};
 110         }
 111     }
 112     for my $field (keys %fields) {
 113         $data{$field} = '' unless exists $data{$field};
 114     }
 115
 116     $data{severity} = $config{default_severity} if $data{severity} eq '';
 117     $data{found_versions} = [split ' ', $data{found_versions}];
 118     $data{fixed_versions} = [split ' ', $data{fixed_versions}];
 119
 120     if ($version < 3) {
 121         for my $field (@rfc1522_fields) {
 122             $data{$field} = decode_rfc1522($data{$field});
 123         }
 124     }
 125
 126     return \%data;
 127 }
 128
 129
 130 =head1 UTILITIES
 131
 132 The following functions are exported by the C<:util> tag
 133
 134 =head2 getbugcomponent
 135
 136      my $file = getbugcomponent($bug_number,$extension,$location)
 137
 138 Returns the path to the bug file in location C<$location>, bug number
 139 C<$bugnumber> and extension C<$extension>
 140
 141 =cut
 142
 143 sub getbugcomponent {
 144     my ($bugnum, $ext, $location) = @_;
 145
 146     if (not defined $location) {
 147         $location = getbuglocation($bugnum, $ext);
 148         # Default to non-archived bugs only for now; CGI scripts want
 149         # archived bugs but most of the backend scripts don't. For now,
 150         # anything that is prepared to accept archived bugs should call
 151         # getbuglocation() directly first.
 152         return undef if defined $location and
 153                         ($location ne 'db' and $location ne 'db-h');
 154     }
 155     return undef if not defined $location;
 156     my $dir = getlocationpath($location);
 157     return undef if not defined $dir;
 158     if ($location eq 'db') {
 159         return "$dir/$bugnum.$ext";
 160     } else {
 161         my $hash = get_hashname($bugnum);
 162         return "$dir/$hash/$bugnum.$ext";
 163     }
 164 }
 165
 166 =head2 getbuglocation
 167
 168      getbuglocation($bug_number,$extension)
 169
 170 Returns the the location in which a particular bug exists; valid
 171 locations returned currently are archive, db-h, or db. If the bug does
 172 not exist, returns undef.
 173
 174 =cut
 175
 176 sub getbuglocation {
 177     my ($bugnum, $ext) = @_;
 178     my $archdir = get_hashname($bugnum);
 179     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 180     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 181     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 182     return undef;
 183 }
 184
 185
 186 =head2 getlocationpath
 187
 188      getlocationpath($location)
 189
 190 Returns the path to a specific location
 191
 192 =cut
 193
 194 sub getlocationpath {
 195      my ($location) = @_;
 196      if (defined $location and $location eq 'archive') {
 197           return "$config{spool_dir}/archive";
 198      } elsif (defined $location and $location eq 'db') {
 199           return "$config{spool_dir}/db";
 200      } else {
 201           return "$config{spool_dir}/db-h";
 202      }
 203 }
 204
 205
 206 =head2 get_hashname
 207
 208      get_hashname
 209
 210 Returns the hash of the bug which is the location within the archive
 211
 212 =cut
 213
 214 sub get_hashname {
 215     return "" if ( $_[ 0 ] < 0 );
 216     return sprintf "%02d", $_[ 0 ] % 100;
 217 }
 218
 219
 220
 221
 222 1;
 223
 224 __END__