2 package Debbugs::Common;
6 Debbugs::Common -- Common routines for all of Debbugs
10 use Debbugs::Common qw(:url :html);
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.
21 This module currently requires /etc/debbugs/config; it should use a
22 general configuration module so that more intelligent things can be
31 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
32 use base qw(Exporter);
36 $DEBUG = 0 unless defined $DEBUG;
39 %EXPORT_TAGS = (#status => [qw(getbugstatus)],
40 read => [qw(readbug)],
41 util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
45 Exporter::export_ok_tags(qw(read util));
46 $EXPORT_TAGS{all} = [@EXPORT_OK];
49 #use Debbugs::Config qw(:globals);
50 use Debbugs::Config qw(:config);
52 use Debbugs::MIME qw(decode_rfc1522);
56 readbug($bug_number,$location)
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>
64 my %fields = (originator => 'submitter',
67 msgid => 'message-id',
68 'package' => 'package',
71 forwarded => 'forwarded-to',
72 mergedwith => 'merged-with',
73 severity => 'severity',
75 found_versions => 'found-in',
76 fixed_versions => 'fixed-in',
78 blockedby => 'blocked-by',
81 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
82 my @rfc1522_fields = qw(originator subject done forwarded owner);
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;
96 while (<$status_fh>) {
99 $version = $1 if /^Format-Version: ([0-9]+)/i;
102 # Version 3 is the latest format version currently supported.
103 return undef if $version > 3;
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};
112 for my $field (keys %fields) {
113 $data{$field} = '' unless exists $data{$field};
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}];
121 for my $field (@rfc1522_fields) {
122 $data{$field} = decode_rfc1522($data{$field});
132 The following functions are exported by the C<:util> tag
134 =head2 getbugcomponent
136 my $file = getbugcomponent($bug_number,$extension,$location)
138 Returns the path to the bug file in location C<$location>, bug number
139 C<$bugnumber> and extension C<$extension>
143 sub getbugcomponent {
144 my ($bugnum, $ext, $location) = @_;
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');
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";
161 my $hash = get_hashname($bugnum);
162 return "$dir/$hash/$bugnum.$ext";
166 =head2 getbuglocation
168 getbuglocation($bug_number,$extension)
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.
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";
186 =head2 getlocationpath
188 getlocationpath($location)
190 Returns the path to a specific location
194 sub getlocationpath {
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";
201 return "$config{spool_dir}/db-h";
210 Returns the hash of the bug which is the location within the archive
215 return "" if ( $_[ 0 ] < 0 );
216 return sprintf "%02d", $_[ 0 ] % 100;