From: Don Armstrong Date: Sat, 27 May 2006 07:04:10 +0000 (-0700) Subject: * Add more functions to Debbugs::Common, which will eventually X-Git-Tag: release/2.6.0~585^2^2~103^2~13 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=e6a4d1a692cd24284c9fb69c06aba7e5dcf5ba44;p=debbugs.git * Add more functions to Debbugs::Common, which will eventually replace errorlib.pl --- diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index b940edf..cb788e3 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -1,63 +1,225 @@ -package Debbugs::Common; -use strict; +package Debbugs::Common; + +=head1 NAME + +Debbugs::Common -- Common routines for all of Debbugs + +=head1 SYNOPSIS + +use Debbugs::Common qw(:url :html); + + +=head1 DESCRIPTION + +This module is a replacement for the general parts of errorlib.pl. +subroutines in errorlib.pl will be gradually phased out and replaced +with equivalent (or better) functionality here. -BEGIN { - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +=head1 BUGS - # set the version for version checking - $VERSION = 1.00; +This module currently requires /etc/debbugs/config; it should use a +general configuration module so that more intelligent things can be +done. - @ISA = qw(Exporter); - @EXPORT = qw(&fail &NameToPathHash &sani &quit); - %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], +=head1 FUNCTIONS - # your exported package globals go here, - # as well as any optionally exported functions - @EXPORT_OK = qw(); +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter); + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (#status => [qw(getbugstatus)], + read => [qw(readbug)], + util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(read util)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; } -use vars @EXPORT_OK; -use Debbugs::Config qw(%Globals); -use FileHandle; -my @cleanups; -my $DEBUG = new FileHandle; +#use Debbugs::Config qw(:globals); +use Debbugs::Config qw(:config); +use IO::File; +use Debbugs::MIME qw(decode_rfc1522); + +=head2 readbug + + readbug($bug_number,$location) + +Reads a summary file from the archive given a bug number and a bug +location. Valid locations are those understood by L + +=cut -sub fail -{ - print "$_[0]\n"; - exit 1; + +my %fields = (originator => 'submitter', + date => 'date', + subject => 'subject', + msgid => 'message-id', + 'package' => 'package', + keywords => 'tags', + done => 'done', + forwarded => 'forwarded-to', + mergedwith => 'merged-with', + severity => 'severity', + owner => 'owner', + found_versions => 'found-in', + fixed_versions => 'fixed-in', + blocks => 'blocks', + blockedby => 'blocked-by', + ); + +# Fields which need to be RFC1522-decoded in format versions earlier than 3. +my @rfc1522_fields = qw(originator subject done forwarded owner); + +sub readbug { + my ($lref, $location) = @_; + my $status = getbugcomponent($lref, 'summary', $location); + return undef unless defined $status; + my $status_fh = new IO::File $status, 'r' or + warn "Unable to open $status for reading: $!" and return undef; + + my %data; + my @lines; + my $version = 2; + local $_; + + while (<$status_fh>) { + chomp; + push @lines, $_; + $version = $1 if /^Format-Version: ([0-9]+)/i; + } + + # Version 3 is the latest format version currently supported. + return undef if $version > 3; + + my %namemap = reverse %fields; + for my $line (@lines) { + if ($line =~ /(\S+?): (.*)/) { + my ($name, $value) = (lc $1, $2); + $data{$namemap{$name}} = $value if exists $namemap{$name}; + } + } + for my $field (keys %fields) { + $data{$field} = '' unless exists $data{$field}; + } + + $data{severity} = $config{default_severity} if $data{severity} eq ''; + $data{found_versions} = [split ' ', $data{found_versions}]; + $data{fixed_versions} = [split ' ', $data{fixed_versions}]; + + if ($version < 3) { + for my $field (@rfc1522_fields) { + $data{$field} = decode_rfc1522($data{$field}); + } + } + + return \%data; } -sub NameToPathHash -{ -# 12345 -> 5/4/3/12345 -# 12 -> s/2/1/12 - my $name = $_[0]; - my $tmp = $name; - $name =~ /^.*?(.)(.)(.)$/ ; - if(!defined($1)) { - $name =~ /^(.*?)(.)(.)$/ ; - $tmp = "$1$2$3"."s"; + + +=head1 UTILITIES + +The following functions are exported by the C<:util> tag + +=head2 getbugcomponent + + my $file = getbugcomponent($bug_number,$extension,$location) + +Returns the path to the bug file in location C<$location>, bug number +C<$bugnumber> and extension C<$extension> + +=cut + +sub getbugcomponent { + my ($bugnum, $ext, $location) = @_; + + if (not defined $location) { + $location = getbuglocation($bugnum, $ext); + # Default to non-archived bugs only for now; CGI scripts want + # archived bugs but most of the backend scripts don't. For now, + # anything that is prepared to accept archived bugs should call + # getbuglocation() directly first. + return undef if defined $location and + ($location ne 'db' and $location ne 'db-h'); + } + return undef if not defined $location; + my $dir = getlocationpath($location); + return undef if not defined $dir; + if ($location eq 'db') { + return "$dir/$bugnum.$ext"; + } else { + my $hash = get_hashname($bugnum); + return "$dir/$hash/$bugnum.$ext"; } - $tmp =~ /^.*?(.)(.)(.)$/ ; - return "$3/$2/$1/$name"; } -sub DEBUG -{ - print $DEBUG $_; +=head2 getbuglocation + + getbuglocation($bug_number,$extension) + +Returns the the location in which a particular bug exists; valid +locations returned currently are archive, db-h, or db. If the bug does +not exist, returns undef. + +=cut + +sub getbuglocation { + my ($bugnum, $ext) = @_; + my $archdir = get_hashname($bugnum); + return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext"; + print STDERR getlocationpath('db-h')."/$archdir/$bugnum.$ext\n"; + return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext"; + return 'db' if -r getlocationpath('db')."/$bugnum.$ext"; + return undef; } -sub quit -{ - DEBUG("quitting >$_[0]<\n"); - my $u; - while ($u= $cleanups[$#cleanups]) { &$u; } - die "*** $_[0]\n"; + + +=head2 getlocationpath + + getlocationpath($location) + +Returns the path to a specific location + +=cut + +sub getlocationpath { + my ($location) = @_; + if (defined $location and $location eq 'archive') { + return "$config{spool_dir}/archive"; + } elsif (defined $location and $location eq 'db') { + return "$config{spool_dir}/db"; + } else { + return "$config{spool_dir}/db-h"; + } } -sub sani -{ - HTML::Entities::encode($a); + + +=head2 get_hashname + + get_hashname + +Returns the hash of the bug which is the location within the archive + +=cut + +sub get_hashname { + return "" if ( $_[ 0 ] < 0 ); + return sprintf "%02d", $_[ 0 ] % 100; } + + + + 1; -END { } # module clean-up code here (global destructor) + +__END__