X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;fp=Debbugs%2FCommon.pm;h=99c68fdfdfd8b846cb517fd183a8ed1cc6ebfca0;hb=a54f07e01f95b7ab702a9f08375dc8dad3394ac9;hp=b940edfef34ca73f06d79fb4fb5568b9d13d9466;hpb=9f108ef05e27f5f725510a94a83523620ccdf10a;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index b940edf..99c68fd 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -1,63 +1,260 @@ -package Debbugs::Common; +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. + +=head1 FUNCTIONS + +=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 = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), + qw(appendfile), + ], + quit => [qw(quit)], + lock => [qw(filelock unfilelock)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(lock quit util)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +#use Debbugs::Config qw(:globals); +use Debbugs::Config qw(:config); +use IO::File; +use Debbugs::MIME qw(decode_rfc1522); + +use Fcntl qw(:flock); + +=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"; + } +} + +=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"; + return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext"; + return 'db' if -r getlocationpath('db')."/$bugnum.$ext"; + return undef; +} + + +=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"; + } +} -BEGIN { - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - # set the version for version checking - $VERSION = 1.00; +=head2 get_hashname - @ISA = qw(Exporter); - @EXPORT = qw(&fail &NameToPathHash &sani &quit); - %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], + get_hashname - # your exported package globals go here, - # as well as any optionally exported functions - @EXPORT_OK = qw(); +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; +} + + +=head2 appendfile + + appendfile($file,'data','to','append'); + +Opens a file for appending and writes data to it. + +=cut + +sub appendfile { + my $file = shift; + if (!open(AP,">>$file")) { + print DEBUG "failed open log<\n"; + print DEBUG "failed open log err $!<\n"; + &quit("opening $file (appendfile): $!"); + } + print(AP @_) || &quit("writing $file (appendfile): $!"); + close(AP) || &quit("closing $file (appendfile): $!"); } -use vars @EXPORT_OK; -use Debbugs::Config qw(%Globals); -use FileHandle; +=head1 LOCK + +These functions are exported with the :lock tag + +=head2 filelock + + filelock + +FLOCKs the passed file. Use unfilelock to unlock it. + +=cut + +my @filelocks; my @cleanups; -my $DEBUG = new FileHandle; - -sub fail -{ - print "$_[0]\n"; - exit 1; -} -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"; + +sub filelock { + # NB - NOT COMPATIBLE WITH `with-lock' + my ($lockfile) = @_; + my ($count,$errors) = @_; + $count= 10; $errors= ''; + for (;;) { + my $fh = eval { + my $fh = new IO::File $lockfile,'w' + or die "Unable to open $lockfile for writing: $!"; + flock($fh,LOCK_EX|LOCK_NB) + or die "Unable to lock $lockfile $!"; + return $fh; + }; + if ($@) { + $errors .= $@; + } + if ($fh) { + push @filelocks, {fh => $fh, file => $lockfile}; + last; + } + if (--$count <=0) { + $errors =~ s/\n+$//; + &quit("failed to get lock on $lockfile -- $errors"); + } + sleep 10; } - $tmp =~ /^.*?(.)(.)(.)$/ ; - return "$3/$2/$1/$name"; + push(@cleanups,\&unfilelock); } -sub DEBUG -{ - print $DEBUG $_; + +=head2 unfilelock + + unfilelock() + +Unlocks the file most recently locked. + +Note that it is not currently possible to unlock a specific file +locked with filelock. + +=cut + +sub unfilelock { + if (@filelocks == 0) { + warn "unfilelock called with no active filelocks!\n"; + return; + } + my %fl = %{pop(@filelocks)}; + pop(@cleanups); + flock($fl{fh},LOCK_UN) + or warn "Unable to unlock lockfile $fl{file}: $!"; + close($fl{fh}) + or warn "Unable to close lockfile $fl{file}: $!"; + unlink($fl{file}) + or warn "Unable to unlink locfile $fl{file}: $!"; } -sub quit -{ - DEBUG("quitting >$_[0]<\n"); - my $u; + + + +=head1 QUIT + +These functions are exported with the :quit tag. + +=head2 quit + + quit() + +Exits the program by calling die after running some cleanups. + +This should be replaced with an END handler which runs the cleanups +instead. (Or possibly a die handler, if the cleanups are important) + +=cut + +sub quit { + print DEBUG "quitting >$_[0]<\n"; + my ($u); while ($u= $cleanups[$#cleanups]) { &$u; } die "*** $_[0]\n"; } -sub sani -{ - HTML::Entities::encode($a); -} + + + + 1; -END { } # module clean-up code here (global destructor) + +__END__