Debbugs/Common.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::Common;
  11
  12 =head1 NAME
  13
  14 Debbugs::Common -- Common routines for all of Debbugs
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::Common qw(:url :html);
  19
  20
  21 =head1 DESCRIPTION
  22
  23 This module is a replacement for the general parts of errorlib.pl.
  24 subroutines in errorlib.pl will be gradually phased out and replaced
  25 with equivalent (or better) functionality here.
  26
  27 =head1 FUNCTIONS
  28
  29 =cut
  30
  31 use warnings;
  32 use strict;
  33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  34 use base qw(Exporter);
  35
  36 BEGIN{
  37      $VERSION = 1.00;
  38      $DEBUG = 0 unless defined $DEBUG;
  39
  40      @EXPORT = ();
  41      %EXPORT_TAGS = (util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
  42                                 qw(appendfile buglog getparsedaddrs getmaintainers),
  43                                 qw(getmaintainers_reverse),
  44                                 qw(getpseudodesc),
  45                                ],
  46                      misc   => [qw(make_list globify_scalar)],
  47                      date   => [qw(secs_to_english)],
  48                      quit   => [qw(quit)],
  49                      lock   => [qw(filelock unfilelock @cleanups lockpid)],
  50                     );
  51      @EXPORT_OK = ();
  52      Exporter::export_ok_tags(qw(lock quit date util misc));
  53      $EXPORT_TAGS{all} = [@EXPORT_OK];
  54 }
  55
  56 #use Debbugs::Config qw(:globals);
  57 use Debbugs::Config qw(:config);
  58 use IO::File;
  59 use IO::Scalar;
  60 use Debbugs::MIME qw(decode_rfc1522);
  61 use Mail::Address;
  62 use Cwd qw(cwd);
  63
  64 use Fcntl qw(:flock);
  65
  66 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  67
  68 =head1 UTILITIES
  69
  70 The following functions are exported by the C<:util> tag
  71
  72 =head2 getbugcomponent
  73
  74      my $file = getbugcomponent($bug_number,$extension,$location)
  75
  76 Returns the path to the bug file in location C<$location>, bug number
  77 C<$bugnumber> and extension C<$extension>
  78
  79 =cut
  80
  81 sub getbugcomponent {
  82     my ($bugnum, $ext, $location) = @_;
  83
  84     if (not defined $location) {
  85         $location = getbuglocation($bugnum, $ext);
  86         # Default to non-archived bugs only for now; CGI scripts want
  87         # archived bugs but most of the backend scripts don't. For now,
  88         # anything that is prepared to accept archived bugs should call
  89         # getbuglocation() directly first.
  90         return undef if defined $location and
  91                         ($location ne 'db' and $location ne 'db-h');
  92     }
  93     my $dir = getlocationpath($location);
  94     return undef if not defined $dir;
  95     if (defined $location and $location eq 'db') {
  96         return "$dir/$bugnum.$ext";
  97     } else {
  98         my $hash = get_hashname($bugnum);
  99         return "$dir/$hash/$bugnum.$ext";
 100     }
 101 }
 102
 103 =head2 getbuglocation
 104
 105      getbuglocation($bug_number,$extension)
 106
 107 Returns the the location in which a particular bug exists; valid
 108 locations returned currently are archive, db-h, or db. If the bug does
 109 not exist, returns undef.
 110
 111 =cut
 112
 113 sub getbuglocation {
 114     my ($bugnum, $ext) = @_;
 115     my $archdir = get_hashname($bugnum);
 116     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 117     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 118     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 119     return undef;
 120 }
 121
 122
 123 =head2 getlocationpath
 124
 125      getlocationpath($location)
 126
 127 Returns the path to a specific location
 128
 129 =cut
 130
 131 sub getlocationpath {
 132      my ($location) = @_;
 133      if (defined $location and $location eq 'archive') {
 134           return "$config{spool_dir}/archive";
 135      } elsif (defined $location and $location eq 'db') {
 136           return "$config{spool_dir}/db";
 137      } else {
 138           return "$config{spool_dir}/db-h";
 139      }
 140 }
 141
 142
 143 =head2 get_hashname
 144
 145      get_hashname
 146
 147 Returns the hash of the bug which is the location within the archive
 148
 149 =cut
 150
 151 sub get_hashname {
 152     return "" if ( $_[ 0 ] < 0 );
 153     return sprintf "%02d", $_[ 0 ] % 100;
 154 }
 155
 156 =head2 buglog
 157
 158      buglog($bugnum);
 159
 160 Returns the path to the logfile corresponding to the bug.
 161
 162 =cut
 163
 164 sub buglog {
 165     my $bugnum = shift;
 166     my $location = getbuglocation($bugnum, 'log');
 167     return getbugcomponent($bugnum, 'log', $location) if ($location);
 168     $location = getbuglocation($bugnum, 'log.gz');
 169     return getbugcomponent($bugnum, 'log.gz', $location);
 170 }
 171
 172
 173 =head2 appendfile
 174
 175      appendfile($file,'data','to','append');
 176
 177 Opens a file for appending and writes data to it.
 178
 179 =cut
 180
 181 sub appendfile {
 182         my $file = shift;
 183         if (!open(AP,">>$file")) {
 184                 print $DEBUG_FH "failed open log<\n" if $DEBUG;
 185                 print $DEBUG_FH "failed open log err $!<\n" if $DEBUG;
 186                 &quit("opening $file (appendfile): $!");
 187         }
 188         print(AP @_) || &quit("writing $file (appendfile): $!");
 189         close(AP) || &quit("closing $file (appendfile): $!");
 190 }
 191
 192 =head2 getparsedaddrs
 193
 194      my $address = getparsedaddrs($address);
 195      my @address = getparsedaddrs($address);
 196
 197 Returns the output from Mail::Address->parse, or the cached output if
 198 this address has been parsed before. In SCALAR context returns the
 199 first address parsed.
 200
 201 =cut
 202
 203
 204 our %_parsedaddrs;
 205 sub getparsedaddrs {
 206     my $addr = shift;
 207     return () unless defined $addr;
 208     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 209          if exists $_parsedaddrs{$addr};
 210     {
 211          # don't display the warnings from Mail::Address->parse
 212          local $SIG{__WARN__} = sub { };
 213          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 214     }
 215     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 216 }
 217
 218 our $_maintainer;
 219 our $_maintainer_rev;
 220 sub getmaintainers {
 221     return $_maintainer if $_maintainer;
 222     my %maintainer;
 223     my %maintainer_rev;
 224     for my $file (@config{qw(maintainer_file maintainer_file_override pseduo_maint_file)}) {
 225          next unless defined $file;
 226          my $maintfile = new IO::File $file,'r' or
 227               &quitcgi("Unable to open $file: $!");
 228          while(<$maintfile>) {
 229               next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 230               ($a,$b)=($1,$2);
 231               $a =~ y/A-Z/a-z/;
 232               $maintainer{$a}= $b;
 233               for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
 234                    push @{$maintainer_rev{$maint}},$a;
 235               }
 236          }
 237          close($maintfile);
 238     }
 239     $_maintainer = \%maintainer;
 240     $_maintainer_rev = \%maintainer_rev;
 241     return $_maintainer;
 242 }
 243 sub getmaintainers_reverse{
 244      return $_maintainer_rev if $_maintainer_rev;
 245      getmaintainers();
 246      return $_maintainer_rev;
 247 }
 248
 249 =head2 getpseudodesc
 250
 251      my $pseudopkgdesc = getpseudodesc(...);
 252
 253 Returns the entry for a pseudo package from the
 254 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 255 defined, returns an empty arrayref.
 256
 257 This function can be used to see if a particular package is a
 258 pseudopackage or not.
 259
 260 =cut
 261
 262 our $_pseudodesc;
 263 sub getpseudodesc {
 264     return $_pseudodesc if $_pseudodesc;
 265     my %pseudodesc;
 266
 267     if (not defined $config{pseudo_desc_file}) {
 268          $_pseudodesc = {};
 269          return $_pseudodesc;
 270     }
 271     my $pseudo = IO::File->new($config{pseudo_desc_file},'r')
 272          or die "Unable to open $config{pseudo_desc_file}: $!";
 273     while(<$pseudo>) {
 274         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 275         $pseudodesc{lc $1} = $2;
 276     }
 277     close($pseudo);
 278     $_pseudodesc = \%pseudodesc;
 279     return $_pseudodesc;
 280 }
 281
 282
 283 =head1 DATE
 284
 285     my $english = secs_to_english($seconds);
 286     my ($days,$english) = secs_to_english($seconds);
 287
 288 XXX This should probably be changed to use Date::Calc
 289
 290 =cut
 291
 292 sub secs_to_english{
 293      my ($seconds) = @_;
 294
 295      my $days = int($seconds / 86400);
 296      my $years = int($days / 365);
 297      $days %= 365;
 298      my $result;
 299      my @age;
 300      push @age, "1 year" if ($years == 1);
 301      push @age, "$years years" if ($years > 1);
 302      push @age, "1 day" if ($days == 1);
 303      push @age, "$days days" if ($days > 1);
 304      $result .= join(" and ", @age);
 305
 306      return wantarray?(int($seconds/86400),$result):$result;
 307 }
 308
 309
 310 =head1 LOCK
 311
 312 These functions are exported with the :lock tag
 313
 314 =head2 filelock
 315
 316      filelock
 317
 318 FLOCKs the passed file. Use unfilelock to unlock it.
 319
 320 =cut
 321
 322 our @filelocks;
 323 our @cleanups;
 324
 325 sub filelock {
 326     # NB - NOT COMPATIBLE WITH `with-lock'
 327     my ($lockfile) = @_;
 328     if ($lockfile !~ m{^/}) {
 329          $lockfile = cwd().'/'.$lockfile;
 330     }
 331     my ($count,$errors);
 332     $count= 10; $errors= '';
 333     for (;;) {
 334         my $fh = eval {
 335              my $fh2 = IO::File->new($lockfile,'w')
 336                   or die "Unable to open $lockfile for writing: $!";
 337              flock($fh2,LOCK_EX|LOCK_NB)
 338                   or die "Unable to lock $lockfile $!";
 339              return $fh2;
 340         };
 341         if ($@) {
 342              $errors .= $@;
 343         }
 344         if ($fh) {
 345              push @filelocks, {fh => $fh, file => $lockfile};
 346              last;
 347         }
 348         if (--$count <=0) {
 349             $errors =~ s/\n+$//;
 350             &quit("failed to get lock on $lockfile -- $errors");
 351         }
 352         sleep 10;
 353     }
 354     push(@cleanups,\&unfilelock);
 355 }
 356
 357
 358 =head2 unfilelock
 359
 360      unfilelock()
 361
 362 Unlocks the file most recently locked.
 363
 364 Note that it is not currently possible to unlock a specific file
 365 locked with filelock.
 366
 367 =cut
 368
 369 sub unfilelock {
 370     if (@filelocks == 0) {
 371         warn "unfilelock called with no active filelocks!\n";
 372         return;
 373     }
 374     my %fl = %{pop(@filelocks)};
 375     pop(@cleanups);
 376     flock($fl{fh},LOCK_UN)
 377          or warn "Unable to unlock lockfile $fl{file}: $!";
 378     close($fl{fh})
 379          or warn "Unable to close lockfile $fl{file}: $!";
 380     unlink($fl{file})
 381          or warn "Unable to unlink lockfile $fl{file}: $!";
 382 }
 383
 384 =head2 lockpid
 385
 386       lockpid('/path/to/pidfile');
 387
 388 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 389 pid in the file does not respond to kill 0.
 390
 391 Returns 1 on success, false on failure; dies on unusual errors.
 392
 393 =cut
 394
 395 sub lockpid {
 396      my ($pidfile) = @_;
 397      if (-e $pidfile) {
 398           my $pidfh = IO::File->new($pidfile, 'r') or
 399                die "Unable to open pidfile $pidfile: $!";
 400           local $/;
 401           my $pid = <$pidfh>;
 402           ($pid) = $pid =~ /(\d+)/;
 403           if (defined $pid and kill(0,$pid)) {
 404                return 0;
 405           }
 406           close $pidfh;
 407           unlink $pidfile or
 408                die "Unable to unlink stale pidfile $pidfile $!";
 409      }
 410      my $pidfh = IO::File->new($pidfile,'w') or
 411           die "Unable to open $pidfile for writing: $!";
 412      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 413      close $pidfh or die "Unable to close $pidfile $!";
 414      return 1;
 415 }
 416
 417
 418 =head1 QUIT
 419
 420 These functions are exported with the :quit tag.
 421
 422 =head2 quit
 423
 424      quit()
 425
 426 Exits the program by calling die after running some cleanups.
 427
 428 This should be replaced with an END handler which runs the cleanups
 429 instead. (Or possibly a die handler, if the cleanups are important)
 430
 431 =cut
 432
 433 sub quit {
 434     print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 435     my ($u);
 436     while ($u= $cleanups[$#cleanups]) { &$u; }
 437     die "*** $_[0]\n";
 438 }
 439
 440 =head1 MISC
 441
 442 These functions are exported with the :misc tag
 443
 444 =head2 make_list
 445
 446      LIST = make_list(@_);
 447
 448 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 449 into a list.
 450
 451 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 452 b)],[qw(c d)] returns qw(a b c d);
 453
 454 =cut
 455
 456 sub make_list {
 457      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 458 }
 459
 460
 461 =head2 globify_scalar
 462
 463      my $handle = globify_scalar(\$foo);
 464
 465 if $foo isn't already a glob or a globref, turn it into one using
 466 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 467
 468 Will carp if given a scalar which isn't a scalarref or a glob (or
 469 globref), and return /dev/null. May return undef if IO::Scalar or
 470 IO::File fails. (Check $!)
 471
 472 =cut
 473
 474 sub globify_scalar {
 475      my ($scalar) = @_;
 476      my $handle;
 477      if (defined $scalar) {
 478           if (defined ref($scalar)) {
 479                if (ref($scalar) eq 'SCALAR' and
 480                    not UNIVERSAL::isa($scalar,'GLOB')) {
 481                     return IO::Scalar->new($scalar);
 482                }
 483                else {
 484                     return $scalar;
 485                }
 486           }
 487           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 488                return $scalar;
 489           }
 490           else {
 491                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 492           }
 493      }
 494      return IO::File->new('/dev/null','w');
 495 }
 496
 497
 498 1;
 499
 500 __END__