-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__
projects / debbugs.git / blobdiff