use warnings;
use strict;
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
+use Exporter qw(import);
BEGIN{
$VERSION = 1.00;
@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),
],
date => [qw(secs_to_english)],
quit => [qw(quit)],
- lock => [qw(filelock unfilelock lockpid)],
+ lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
);
@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::MIME qw(decode_rfc1522);
use Mail::Address;
use Cwd qw(cwd);
+use Storable qw(dclone);
+use Time::HiRes qw(usleep);
use Params::Validate qw(validate_with :types);
use Fcntl qw(:DEFAULT :flock);
+use Encode qw(is_utf8 decode_utf8);
our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
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);
$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*$/;
- my ($key,$value)=($1,$2);
+ next unless m/^(\S+)\s+(\S.*\S)\s*$/;
+ my ($key,$value)=($1,$2);
$key = lc $key;
$forward->{$key}= $value;
if (defined $reverse) {
confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
}
}
- my ($count,$errors);
- $count= 10; $errors= '';
- for (;;) {
- my $fh = eval {
+ my ($fh,$t_lockfile,$errors) =
+ simple_filelock($lockfile,10,1);
+ if ($fh) {
+ push @filelocks, {fh => $fh, file => $lockfile};
+ if (defined $locks) {
+ $locks->{locks}{$lockfile}++;
+ push @{$locks->{lockorder}},$lockfile;
+ }
+ } else {
+ use Data::Dumper;
+ croak "failed to get lock on $lockfile -- $errors".
+ (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
+ }
+}
+
+=head2 simple_filelock
+
+ my ($fh,$t_lockfile,$errors) =
+ simple_filelock($lockfile,$count,$wait);
+
+Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
+Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
+seconds in between.
+
+In list context, returns the lockfile filehandle, lockfile name, and
+any errors which occured.
+
+When the lockfile filehandle is undef, locking failed.
+
+These lockfiles must be unlocked manually at process end.
+
+
+=cut
+
+sub simple_filelock {
+ my ($lockfile,$count,$wait) = @_;
+ if (not defined $count) {
+ $count = 10;
+ }
+ if ($count < 0) {
+ $count = 0;
+ }
+ if (not defined $wait) {
+ $wait = 1;
+ }
+ my $errors= '';
+ my $fh;
+ while (1) {
+ $fh = eval {
my $fh2 = IO::File->new($lockfile,'w')
or die "Unable to open $lockfile for writing: $!";
- flock($fh2,LOCK_EX|LOCK_NB)
+ # Do a blocking lock if count is zero
+ flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
or die "Unable to lock $lockfile $!";
return $fh2;
};
if ($@) {
$errors .= $@;
}
- 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+$//;
- use Data::Dumper;
- croak "failed to get lock on $lockfile -- $errors".
- (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
+ if ($fh) {
+ last;
}
-# sleep 10;
+ # use usleep for fractional wait seconds
+ usleep($wait * 1_000_000);
+ } continue {
+ last unless (--$count > 0);
+ }
+ if ($fh) {
+ return wantarray?($fh,$lockfile,$errors):$fh
}
+ return wantarray?(undef,$lockfile,$errors):undef;
}
# clean up all outstanding locks at end time
}
}
+=head2 simple_unlockfile
+
+ simple_unlockfile($fh,$lockfile);
+
+
+=cut
+
+sub simple_unlockfile {
+ my ($fh,$lockfile) = @_;
+ flock($fh,LOCK_UN)
+ or warn "Unable to unlock lockfile $lockfile: $!";
+ close($fh)
+ or warn "Unable to close lockfile $lockfile: $!";
+ unlink($lockfile)
+ or warn "Unable to unlink lockfile $lockfile: $!";
+}
+
=head2 unfilelock
delete $locks->{locks}{$lockfile};
}
my %fl = %{pop(@filelocks)};
- 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 lockfile $fl{file}: $!";
+ simple_unlockfile($fl{fh},$fl{file});
}
globref), and return /dev/null. May return undef if IO::Scalar or
IO::File fails. (Check $!)
+The scalar will fill with octets, not perl's internal encoding, so you
+must use decode_utf8() after on the scalar, and encode_utf8() on it
+before. This appears to be a bug in the underlying modules.
+
=cut
sub globify_scalar {
if (defined ref($scalar)) {
if (ref($scalar) eq 'SCALAR' and
not UNIVERSAL::isa($scalar,'GLOB')) {
- return IO::Scalar->new($scalar);
+ if (is_utf8(${$scalar})) {
+ ${$scalar} = decode_utf8(${$scalar});
+ carp(q(\$scalar must not be in perl's internal encoding));
+ }
+ open $handle, '>:scalar:utf8', $scalar;
+ return $handle;
}
else {
return $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()
}
# ditch the "at foo/bar/baz.pm line 5"
$error =~ s/\sat\s\S+\sline\s\d+//;
+ # ditch croak messages
+ $error =~ s/^\t+.+\n?//mg;
# ditch trailing multiple periods in case there was a cascade of
# die messages.
$error =~ s/\.+$/\./;
return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
}
+
1;
__END__