X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=11c339bf6665ced76095684d01c8c147af5d5d9f;hb=e5cda269a9c62363a31d2a9f53e8c5850bcb52eb;hp=ef1b8bbe96cb75e746ed00be5fd52b0b620a97f1;hpb=5b550d03e9214a7980a5cd4897cf9de09d89749b;p=debbugs.git

diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm
index ef1b8bb..11c339b 100644
--- a/Debbugs/Common.pm
+++ b/Debbugs/Common.pm
@@ -39,7 +39,7 @@ BEGIN{
 
      @EXPORT = ();
      %EXPORT_TAGS = (util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
-				qw(appendfile buglog getparsedaddrs getmaintainers),
+				qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
 				qw(bug_status),
 				qw(getmaintainers_reverse),
 				qw(getpseudodesc),
@@ -48,19 +48,21 @@ BEGIN{
 			       ],
 		     misc   => [qw(make_list globify_scalar english_join checkpid),
 				qw(cleanup_eval_fail),
+				qw(hash_slice),
 			       ],
 		     date   => [qw(secs_to_english)],
 		     quit   => [qw(quit)],
 		     lock   => [qw(filelock unfilelock lockpid)],
 		    );
      @EXPORT_OK = ();
-     Exporter::export_ok_tags(qw(lock quit date util misc));
+     Exporter::export_ok_tags(keys %EXPORT_TAGS);
      $EXPORT_TAGS{all} = [@EXPORT_OK];
 }
 
 #use Debbugs::Config qw(:globals);
 
 use Carp;
+$Carp::Verbose = 1;
 
 use Debbugs::Config qw(:config);
 use IO::File;
@@ -68,10 +70,11 @@ use IO::Scalar;
 use Debbugs::MIME qw(decode_rfc1522);
 use Mail::Address;
 use Cwd qw(cwd);
+use Storable qw(dclone);
 
 use Params::Validate qw(validate_with :types);
 
-use Fcntl qw(:flock);
+use Fcntl qw(:DEFAULT :flock);
 
 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
 
@@ -216,6 +219,28 @@ sub appendfile {
 	close $fh or die "Unable to close $file: $!";
 }
 
+=head2 overwritefile
+
+     ovewritefile($file,'data','to','append');
+
+Opens file.new, writes data to it, then moves file.new to file.
+
+=cut
+
+sub overwritefile {
+	my ($file,@data) = @_;
+	my $fh = IO::File->new("${file}.new",'w') or
+	     die "Unable top open ${file}.new for writing: $!";
+	print {$fh} @data or die "Unable to write to ${file}.new: $!";
+	close $fh or die "Unable to close ${file}.new: $!";
+	rename("${file}.new",$file) or
+	    die "Unable to rename ${file}.new to $file: $!";
+}
+
+
+
+
+
 =head2 getparsedaddrs
 
      my $address = getparsedaddrs($address);
@@ -405,6 +430,7 @@ sub __add_to_hash {
     $type //= 'address';
     my $fh = IO::File->new($fn,'r') or
 	die "Unable to open $fn for reading: $!";
+    binmode($fh,':encoding(UTF-8)');
     while (<$fh>) {
 	chomp;
 	next unless m/^(\S+)\s+(\S.*\S)\s*$/;
@@ -508,20 +534,44 @@ These functions are exported with the :lock tag
 
 =head2 filelock
 
-     filelock
+     filelock($lockfile);
+     filelock($lockfile,$locks);
 
 FLOCKs the passed file. Use unfilelock to unlock it.
 
+Can be passed an optional $locks hashref, which is used to track which
+files are locked (and how many times they have been locked) to allow
+for cooperative locking.
+
 =cut
 
 our @filelocks;
 
+use Carp qw(cluck);
+
 sub filelock {
     # NB - NOT COMPATIBLE WITH `with-lock'
-    my ($lockfile) = @_;
+    my ($lockfile,$locks) = @_;
     if ($lockfile !~ m{^/}) {
 	 $lockfile = cwd().'/'.$lockfile;
     }
+    # This is only here to allow for relocking bugs inside of
+    # Debbugs::Control. Nothing else should be using it.
+    if (defined $locks and exists $locks->{locks}{$lockfile} and
+	$locks->{locks}{$lockfile} >= 1) {
+	if (exists $locks->{relockable} and
+	    exists $locks->{relockable}{$lockfile}) {
+	    $locks->{locks}{$lockfile}++;
+	    # indicate that the bug for this lockfile needs to be reread
+	    $locks->{relockable}{$lockfile} = 1;
+	    push @{$locks->{lockorder}},$lockfile;
+	    return;
+	}
+	else {
+	    use Data::Dumper;
+	    confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
+	}
+    }
     my ($count,$errors);
     $count= 10; $errors= '';
     for (;;) {
@@ -537,13 +587,19 @@ sub filelock {
 	}
 	if ($fh) {
 	     push @filelocks, {fh => $fh, file => $lockfile};
+	     if (defined $locks) {
+		 $locks->{locks}{$lockfile}++;
+		 push @{$locks->{lockorder}},$lockfile;
+	     }
 	     last;
 	}
         if (--$count <=0) {
             $errors =~ s/\n+$//;
-            die "failed to get lock on $lockfile -- $errors";
+	    use Data::Dumper;
+            croak "failed to get lock on $lockfile -- $errors".
+		(defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
         }
-        sleep 10;
+#        sleep 10;
     }
 }
 
@@ -558,6 +614,7 @@ END {
 =head2 unfilelock
 
      unfilelock()
+     unfilelock($locks);
 
 Unlocks the file most recently locked.
 
@@ -567,10 +624,24 @@ locked with filelock.
 =cut
 
 sub unfilelock {
+    my ($locks) = @_;
     if (@filelocks == 0) {
-        warn "unfilelock called with no active filelocks!\n";
+        carp "unfilelock called with no active filelocks!\n";
         return;
     }
+    if (defined $locks and ref($locks) ne 'HASH') {
+	croak "hash not passsed to unfilelock";
+    }
+    if (defined $locks and exists $locks->{lockorder} and
+	@{$locks->{lockorder}} and
+	exists $locks->{locks}{$locks->{lockorder}[-1]}) {
+	my $lockfile = pop @{$locks->{lockorder}};
+	$locks->{locks}{$lockfile}--;
+	if ($locks->{locks}{$lockfile} > 0) {
+	    return
+	}
+	delete $locks->{locks}{$lockfile};
+    }
     my %fl = %{pop(@filelocks)};
     flock($fl{fh},LOCK_UN)
 	 or warn "Unable to unlock lockfile $fl{file}: $!";
@@ -601,7 +672,7 @@ sub lockpid {
 	  unlink $pidfile or
 	       die "Unable to unlink stale pidfile $pidfile $!";
      }
-     my $pidfh = IO::File->new($pidfile,'w') or
+     my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
 	  die "Unable to open $pidfile for writing: $!";
      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
      close $pidfh or die "Unable to close $pidfile $!";
@@ -754,7 +825,8 @@ sub globify_scalar {
 	  if (defined ref($scalar)) {
 	       if (ref($scalar) eq 'SCALAR' and
 		   not UNIVERSAL::isa($scalar,'GLOB')) {
-		    return IO::Scalar->new($scalar);
+		    open $handle, '>:scalar:utf8', $scalar;
+		    return $handle;
 	       }
 	       else {
 		    return $scalar;
@@ -767,7 +839,7 @@ sub globify_scalar {
 	       carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 	  }
      }
-     return IO::File->new('/dev/null','w');
+     return IO::File->new('/dev/null','>:encoding(UTF-8)');
 }
 
 =head2 cleanup_eval_fail()
@@ -800,12 +872,31 @@ sub cleanup_eval_fail {
     }
     # ditch the "at foo/bar/baz.pm line 5"
     $error =~ s/\sat\s\S+\sline\s\d+//;
+    # ditch croak messages
+    $error =~ s/^\t+.+\n?//g;
     # ditch trailing multiple periods in case there was a cascade of
     # die messages.
     $error =~ s/\.+$/\./;
     return $error;
 }
 
+=head2 hash_slice
+
+     hash_slice(%hash,qw(key1 key2 key3))
+
+For each key, returns matching values and keys of the hash if they exist
+
+=cut
+
+
+# NB: We use prototypes here SPECIFICALLY so that we can be passed a
+# hash without uselessly making a reference to first. DO NOT USE
+# PROTOTYPES USELESSLY ELSEWHERE.
+sub hash_slice(\%@) {
+    my ($hashref,@keys) = @_;
+    return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
+}
+
 
 1;