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(bug_status),
  44                                 qw(getmaintainers_reverse),
  45                                 qw(getpseudodesc),
  46                                 qw(package_maintainer),
  47                                ],
  48                      misc   => [qw(make_list globify_scalar english_join checkpid),
  49                                 qw(cleanup_eval_fail),
  50                                ],
  51                      date   => [qw(secs_to_english)],
  52                      quit   => [qw(quit)],
  53                      lock   => [qw(filelock unfilelock lockpid)],
  54                     );
  55      @EXPORT_OK = ();
  56      Exporter::export_ok_tags(qw(lock quit date util misc));
  57      $EXPORT_TAGS{all} = [@EXPORT_OK];
  58 }
  59
  60 #use Debbugs::Config qw(:globals);
  61
  62 use Carp;
  63
  64 use Debbugs::Config qw(:config);
  65 use IO::File;
  66 use IO::Scalar;
  67 use Debbugs::MIME qw(decode_rfc1522);
  68 use Mail::Address;
  69 use Cwd qw(cwd);
  70
  71 use Params::Validate qw(validate_with :types);
  72
  73 use Fcntl qw(:flock);
  74
  75 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  76
  77 =head1 UTILITIES
  78
  79 The following functions are exported by the C<:util> tag
  80
  81 =head2 getbugcomponent
  82
  83      my $file = getbugcomponent($bug_number,$extension,$location)
  84
  85 Returns the path to the bug file in location C<$location>, bug number
  86 C<$bugnumber> and extension C<$extension>
  87
  88 =cut
  89
  90 sub getbugcomponent {
  91     my ($bugnum, $ext, $location) = @_;
  92
  93     if (not defined $location) {
  94         $location = getbuglocation($bugnum, $ext);
  95         # Default to non-archived bugs only for now; CGI scripts want
  96         # archived bugs but most of the backend scripts don't. For now,
  97         # anything that is prepared to accept archived bugs should call
  98         # getbuglocation() directly first.
  99         return undef if defined $location and
 100                         ($location ne 'db' and $location ne 'db-h');
 101     }
 102     my $dir = getlocationpath($location);
 103     return undef if not defined $dir;
 104     if (defined $location and $location eq 'db') {
 105         return "$dir/$bugnum.$ext";
 106     } else {
 107         my $hash = get_hashname($bugnum);
 108         return "$dir/$hash/$bugnum.$ext";
 109     }
 110 }
 111
 112 =head2 getbuglocation
 113
 114      getbuglocation($bug_number,$extension)
 115
 116 Returns the the location in which a particular bug exists; valid
 117 locations returned currently are archive, db-h, or db. If the bug does
 118 not exist, returns undef.
 119
 120 =cut
 121
 122 sub getbuglocation {
 123     my ($bugnum, $ext) = @_;
 124     my $archdir = get_hashname($bugnum);
 125     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 126     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 127     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 128     return undef;
 129 }
 130
 131
 132 =head2 getlocationpath
 133
 134      getlocationpath($location)
 135
 136 Returns the path to a specific location
 137
 138 =cut
 139
 140 sub getlocationpath {
 141      my ($location) = @_;
 142      if (defined $location and $location eq 'archive') {
 143           return "$config{spool_dir}/archive";
 144      } elsif (defined $location and $location eq 'db') {
 145           return "$config{spool_dir}/db";
 146      } else {
 147           return "$config{spool_dir}/db-h";
 148      }
 149 }
 150
 151
 152 =head2 get_hashname
 153
 154      get_hashname
 155
 156 Returns the hash of the bug which is the location within the archive
 157
 158 =cut
 159
 160 sub get_hashname {
 161     return "" if ( $_[ 0 ] < 0 );
 162     return sprintf "%02d", $_[ 0 ] % 100;
 163 }
 164
 165 =head2 buglog
 166
 167      buglog($bugnum);
 168
 169 Returns the path to the logfile corresponding to the bug.
 170
 171 Returns undef if the bug does not exist.
 172
 173 =cut
 174
 175 sub buglog {
 176     my $bugnum = shift;
 177     my $location = getbuglocation($bugnum, 'log');
 178     return getbugcomponent($bugnum, 'log', $location) if ($location);
 179     $location = getbuglocation($bugnum, 'log.gz');
 180     return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
 181     return undef;
 182 }
 183
 184 =head2 bug_status
 185
 186      bug_status($bugnum)
 187
 188
 189 Returns the path to the summary file corresponding to the bug.
 190
 191 Returns undef if the bug does not exist.
 192
 193 =cut
 194
 195 sub bug_status{
 196     my ($bugnum) = @_;
 197     my $location = getbuglocation($bugnum, 'summary');
 198     return getbugcomponent($bugnum, 'summary', $location) if ($location);
 199     return undef;
 200 }
 201
 202 =head2 appendfile
 203
 204      appendfile($file,'data','to','append');
 205
 206 Opens a file for appending and writes data to it.
 207
 208 =cut
 209
 210 sub appendfile {
 211         my ($file,@data) = @_;
 212         my $fh = IO::File->new($file,'a') or
 213              die "Unable top open $file for appending: $!";
 214         print {$fh} @data or die "Unable to write to $file: $!";
 215         close $fh or die "Unable to close $file: $!";
 216 }
 217
 218 =head2 getparsedaddrs
 219
 220      my $address = getparsedaddrs($address);
 221      my @address = getparsedaddrs($address);
 222
 223 Returns the output from Mail::Address->parse, or the cached output if
 224 this address has been parsed before. In SCALAR context returns the
 225 first address parsed.
 226
 227 =cut
 228
 229
 230 our %_parsedaddrs;
 231 sub getparsedaddrs {
 232     my $addr = shift;
 233     return () unless defined $addr;
 234     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 235          if exists $_parsedaddrs{$addr};
 236     {
 237          # don't display the warnings from Mail::Address->parse
 238          local $SIG{__WARN__} = sub { };
 239          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 240     }
 241     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 242 }
 243
 244 =head2 getmaintainers
 245
 246      my $maintainer = getmaintainers()->{debbugs}
 247
 248 Returns a hashref of package => maintainer pairs.
 249
 250 =cut
 251
 252 our $_maintainer = undef;
 253 our $_maintainer_rev = undef;
 254 sub getmaintainers {
 255     return $_maintainer if defined $_maintainer;
 256     package_maintainer(rehash => 1);
 257     return $_maintainer;
 258 }
 259
 260 =head2 getmaintainers_reverse
 261
 262      my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
 263
 264 Returns a hashref of maintainer => [qw(list of packages)] pairs.
 265
 266 =cut
 267
 268 sub getmaintainers_reverse{
 269      return $_maintainer_rev if defined $_maintainer_rev;
 270      package_maintainer(rehash => 1);
 271      return $_maintainer_rev;
 272 }
 273
 274 =head2 package_maintainer
 275
 276      my @s = package_maintainer(source => [qw(foo bar baz)],
 277                                 binary => [qw(bleh blah)],
 278                                );
 279
 280 =over
 281
 282 =item source -- scalar or arrayref of source package names to return
 283 maintainers for, defaults to the empty arrayref.
 284
 285 =item binary -- scalar or arrayref of binary package names to return
 286 maintainers for; automatically returns source package maintainer if
 287 the package name starts with 'src:', defaults to the empty arrayref.
 288
 289 =item reverse -- whether to return the source/binary packages a
 290 maintainer maintains instead
 291
 292 =item rehash -- whether to reread the maintainer and source maintainer
 293 files; defaults to 0
 294
 295 =back
 296
 297 =cut
 298
 299 our $_source_maintainer = undef;
 300 our $_source_maintainer_rev = undef;
 301 sub package_maintainer {
 302     my %param = validate_with(params => \@_,
 303                               spec   => {source => {type => SCALAR|ARRAYREF,
 304                                                     default => [],
 305                                                    },
 306                                          binary => {type => SCALAR|ARRAYREF,
 307                                                     default => [],
 308                                                    },
 309                                          maintainer => {type => SCALAR|ARRAYREF,
 310                                                         default => [],
 311                                                        },
 312                                          rehash => {type => BOOLEAN,
 313                                                     default => 0,
 314                                                    },
 315                                          reverse => {type => BOOLEAN,
 316                                                      default => 0,
 317                                                     },
 318                                         },
 319                              );
 320     my @binary = make_list($param{binary});
 321     my @source = make_list($param{source});
 322     my @maintainers = make_list($param{maintainer});
 323     if ((@binary or @source) and @maintainers) {
 324         croak "It is nonsensical to pass both maintainers and source or binary";
 325     }
 326     if ($param{rehash}) {
 327         $_source_maintainer = undef;
 328         $_source_maintainer_rev = undef;
 329         $_maintainer = undef;
 330         $_maintainer_rev = undef;
 331     }
 332     if (not defined $_source_maintainer or
 333         not defined $_source_maintainer_rev) {
 334         $_source_maintainer = {};
 335         $_source_maintainer_rev = {};
 336         for my $fn (@config{('source_maintainer_file',
 337                              'source_maintainer_file_override',
 338                              'pseudo_maint_file')}) {
 339             next unless defined $fn;
 340             if (not -e $fn) {
 341                 warn "Missing source maintainer file '$fn'";
 342                 next;
 343             }
 344             __add_to_hash($fn,$_source_maintainer,
 345                           $_source_maintainer_rev);
 346         }
 347     }
 348     if (not defined $_maintainer or
 349         not defined $_maintainer_rev) {
 350         $_maintainer = {};
 351         $_maintainer_rev = {};
 352         for my $fn (@config{('maintainer_file',
 353                              'maintainer_file_override',
 354                              'pseudo_maint_file')}) {
 355             next unless defined $fn;
 356             if (not -e $fn) {
 357                 warn "Missing maintainer file '$fn'";
 358                 next;
 359             }
 360             __add_to_hash($fn,$_maintainer,
 361                               $_maintainer_rev);
 362         }
 363     }
 364     my @return;
 365     for my $binary (@binary) {
 366         if (not $param{reverse} and $binary =~ /^src:/) {
 367             push @source,$binary;
 368             next;
 369         }
 370         push @return,grep {defined $_} make_list($_maintainer->{$binary});
 371     }
 372     for my $source (@source) {
 373         $source =~ s/^src://;
 374         push @return,grep {defined $_} make_list($_source_maintainer->{$source});
 375     }
 376     for my $maintainer (grep {defined $_} @maintainers) {
 377         push @return,grep {defined $_}
 378             make_list($_maintainer_rev->{$maintainer});
 379         push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
 380             grep {defined $_}
 381                 make_list($_source_maintainer_rev->{$maintainer});
 382     }
 383     return @return;
 384 }
 385
 386 #=head2 __add_to_hash
 387 #
 388 #     __add_to_hash($file,$forward_hash,$reverse_hash,'address');
 389 #
 390 # Reads a maintainer/source maintainer/pseudo desc file and adds the
 391 # maintainers from it to the forward and reverse hashref; assumes that
 392 # the forward is unique; makes no assumptions of the reverse.
 393 #
 394 #=cut
 395
 396 sub __add_to_hash {
 397     my ($fn,$forward,$reverse,$type) = @_;
 398     if (ref($forward) ne 'HASH') {
 399         croak "__add_to_hash must be passed a hashref for the forward";
 400     }
 401     if (defined $reverse and not ref($reverse) eq 'HASH') {
 402         croak "if reverse is passed to __add_to_hash, it must be a hashref";
 403     }
 404     $type //= 'address';
 405     my $fh = IO::File->new($fn,'r') or
 406         die "Unable to open $fn for reading: $!";
 407     while (<$fh>) {
 408         chomp;
 409         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 410         my ($key,$value)=($1,$2);
 411         $key = lc $key;
 412         $forward->{$key}= $value;
 413         if (defined $reverse) {
 414             if ($type eq 'address') {
 415                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
 416                     push @{$reverse->{$m}},$key;
 417                 }
 418             }
 419             else {
 420                 push @{$reverse->{$value}}, $key;
 421             }
 422         }
 423     }
 424 }
 425
 426
 427 =head2 getpseudodesc
 428
 429      my $pseudopkgdesc = getpseudodesc(...);
 430
 431 Returns the entry for a pseudo package from the
 432 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 433 defined, returns an empty arrayref.
 434
 435 This function can be used to see if a particular package is a
 436 pseudopackage or not.
 437
 438 =cut
 439
 440 our $_pseudodesc = undef;
 441 sub getpseudodesc {
 442     return $_pseudodesc if defined $_pseudodesc;
 443     $_pseudodesc = {};
 444     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
 445         defined $config{pseudo_desc_file};
 446     return $_pseudodesc;
 447 }
 448
 449
 450 =head1 DATE
 451
 452     my $english = secs_to_english($seconds);
 453     my ($days,$english) = secs_to_english($seconds);
 454
 455 XXX This should probably be changed to use Date::Calc
 456
 457 =cut
 458
 459 sub secs_to_english{
 460      my ($seconds) = @_;
 461
 462      my $days = int($seconds / 86400);
 463      my $years = int($days / 365);
 464      $days %= 365;
 465      my $result;
 466      my @age;
 467      push @age, "1 year" if ($years == 1);
 468      push @age, "$years years" if ($years > 1);
 469      push @age, "1 day" if ($days == 1);
 470      push @age, "$days days" if ($days > 1);
 471      $result .= join(" and ", @age);
 472
 473      return wantarray?(int($seconds/86400),$result):$result;
 474 }
 475
 476
 477 =head1 LOCK
 478
 479 These functions are exported with the :lock tag
 480
 481 =head2 filelock
 482
 483      filelock
 484
 485 FLOCKs the passed file. Use unfilelock to unlock it.
 486
 487 =cut
 488
 489 our @filelocks;
 490
 491 sub filelock {
 492     # NB - NOT COMPATIBLE WITH `with-lock'
 493     my ($lockfile) = @_;
 494     if ($lockfile !~ m{^/}) {
 495          $lockfile = cwd().'/'.$lockfile;
 496     }
 497     my ($count,$errors);
 498     $count= 10; $errors= '';
 499     for (;;) {
 500         my $fh = eval {
 501              my $fh2 = IO::File->new($lockfile,'w')
 502                   or die "Unable to open $lockfile for writing: $!";
 503              flock($fh2,LOCK_EX|LOCK_NB)
 504                   or die "Unable to lock $lockfile $!";
 505              return $fh2;
 506         };
 507         if ($@) {
 508              $errors .= $@;
 509         }
 510         if ($fh) {
 511              push @filelocks, {fh => $fh, file => $lockfile};
 512              last;
 513         }
 514         if (--$count <=0) {
 515             $errors =~ s/\n+$//;
 516             die "failed to get lock on $lockfile -- $errors";
 517         }
 518         sleep 10;
 519     }
 520 }
 521
 522 # clean up all outstanding locks at end time
 523 END {
 524      while (@filelocks) {
 525           unfilelock();
 526      }
 527 }
 528
 529
 530 =head2 unfilelock
 531
 532      unfilelock()
 533
 534 Unlocks the file most recently locked.
 535
 536 Note that it is not currently possible to unlock a specific file
 537 locked with filelock.
 538
 539 =cut
 540
 541 sub unfilelock {
 542     if (@filelocks == 0) {
 543         warn "unfilelock called with no active filelocks!\n";
 544         return;
 545     }
 546     my %fl = %{pop(@filelocks)};
 547     flock($fl{fh},LOCK_UN)
 548          or warn "Unable to unlock lockfile $fl{file}: $!";
 549     close($fl{fh})
 550          or warn "Unable to close lockfile $fl{file}: $!";
 551     unlink($fl{file})
 552          or warn "Unable to unlink lockfile $fl{file}: $!";
 553 }
 554
 555
 556 =head2 lockpid
 557
 558       lockpid('/path/to/pidfile');
 559
 560 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 561 pid in the file does not respond to kill 0.
 562
 563 Returns 1 on success, false on failure; dies on unusual errors.
 564
 565 =cut
 566
 567 sub lockpid {
 568      my ($pidfile) = @_;
 569      if (-e $pidfile) {
 570           my $pid = checkpid($pidfile);
 571           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 572           return 0 if $pid != 0;
 573           unlink $pidfile or
 574                die "Unable to unlink stale pidfile $pidfile $!";
 575      }
 576      my $pidfh = IO::File->new($pidfile,'w') or
 577           die "Unable to open $pidfile for writing: $!";
 578      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 579      close $pidfh or die "Unable to close $pidfile $!";
 580      return 1;
 581 }
 582
 583 =head2 checkpid
 584
 585      checkpid('/path/to/pidfile');
 586
 587 Checks a pid file and determines if the process listed in the pidfile
 588 is still running. Returns the pid if it is, 0 if it isn't running, and
 589 undef if the pidfile doesn't exist or cannot be read.
 590
 591 =cut
 592
 593 sub checkpid{
 594      my ($pidfile) = @_;
 595      if (-e $pidfile) {
 596           my $pidfh = IO::File->new($pidfile, 'r') or
 597                return undef;
 598           local $/;
 599           my $pid = <$pidfh>;
 600           close $pidfh;
 601           ($pid) = $pid =~ /(\d+)/;
 602           if (defined $pid and kill(0,$pid)) {
 603                return $pid;
 604           }
 605           return 0;
 606      }
 607      else {
 608           return undef;
 609      }
 610 }
 611
 612
 613 =head1 QUIT
 614
 615 These functions are exported with the :quit tag.
 616
 617 =head2 quit
 618
 619      quit()
 620
 621 Exits the program by calling die.
 622
 623 Usage of quit is deprecated; just call die instead.
 624
 625 =cut
 626
 627 sub quit {
 628      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 629      carp "quit() is deprecated; call die directly instead";
 630 }
 631
 632
 633 =head1 MISC
 634
 635 These functions are exported with the :misc tag
 636
 637 =head2 make_list
 638
 639      LIST = make_list(@_);
 640
 641 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 642 into a list.
 643
 644 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 645 b)],[qw(c d)] returns qw(a b c d);
 646
 647 =cut
 648
 649 sub make_list {
 650      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 651 }
 652
 653
 654 =head2 english_join
 655
 656      print english_join(list => \@list);
 657      print english_join(\@list);
 658
 659 Joins list properly to make an english phrase.
 660
 661 =over
 662
 663 =item normal -- how to separate most values; defaults to ', '
 664
 665 =item last -- how to separate the last two values; defaults to ', and '
 666
 667 =item only_two -- how to separate only two values; defaults to ' and '
 668
 669 =item list -- ARRAYREF values to join; if the first argument is an
 670 ARRAYREF, it's assumed to be the list of values to join
 671
 672 =back
 673
 674 In cases where C<list> is empty, returns ''; when there is only one
 675 element, returns that element.
 676
 677 =cut
 678
 679 sub english_join {
 680     if (ref $_[0] eq 'ARRAY') {
 681         return english_join(list=>$_[0]);
 682     }
 683     my %param = validate_with(params => \@_,
 684                               spec  => {normal => {type => SCALAR,
 685                                                    default => ', ',
 686                                                   },
 687                                         last   => {type => SCALAR,
 688                                                    default => ', and ',
 689                                                   },
 690                                         only_two => {type => SCALAR,
 691                                                      default => ' and ',
 692                                                     },
 693                                         list     => {type => ARRAYREF,
 694                                                     },
 695                                        },
 696                              );
 697     my @list = @{$param{list}};
 698     if (@list <= 1) {
 699         return @list?$list[0]:'';
 700     }
 701     elsif (@list == 2) {
 702         return join($param{only_two},@list);
 703     }
 704     my $ret = $param{last} . pop(@list);
 705     return join($param{normal},@list) . $ret;
 706 }
 707
 708
 709 =head2 globify_scalar
 710
 711      my $handle = globify_scalar(\$foo);
 712
 713 if $foo isn't already a glob or a globref, turn it into one using
 714 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 715
 716 Will carp if given a scalar which isn't a scalarref or a glob (or
 717 globref), and return /dev/null. May return undef if IO::Scalar or
 718 IO::File fails. (Check $!)
 719
 720 =cut
 721
 722 sub globify_scalar {
 723      my ($scalar) = @_;
 724      my $handle;
 725      if (defined $scalar) {
 726           if (defined ref($scalar)) {
 727                if (ref($scalar) eq 'SCALAR' and
 728                    not UNIVERSAL::isa($scalar,'GLOB')) {
 729                     return IO::Scalar->new($scalar);
 730                }
 731                else {
 732                     return $scalar;
 733                }
 734           }
 735           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 736                return $scalar;
 737           }
 738           else {
 739                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 740           }
 741      }
 742      return IO::File->new('/dev/null','w');
 743 }
 744
 745 =head2 cleanup_eval_fail()
 746
 747      print "Something failed with: ".cleanup_eval_fail($@);
 748
 749 Does various bits of cleanup on the failure message from an eval (or
 750 any other die message)
 751
 752 Takes at most two options; the first is the actual failure message
 753 (usually $@ and defaults to $@), the second is the debug level
 754 (defaults to $DEBUG).
 755
 756 If debug is non-zero, the code at which the failure occured is output.
 757
 758 =cut
 759
 760 sub cleanup_eval_fail {
 761     my ($error,$debug) = @_;
 762     if (not defined $error or not @_) {
 763         $error = $@ // 'unknown reason';
 764     }
 765     if (@_ <= 1) {
 766         $debug = $DEBUG // 0;
 767     }
 768     $debug = 0 if not defined $debug;
 769
 770     if ($debug > 0) {
 771         return $error;
 772     }
 773     # ditch the "at foo/bar/baz.pm line 5"
 774     $error =~ s/\sat\s\S+\sline\s\d+//;
 775     # ditch trailing multiple periods in case there was a cascade of
 776     # die messages.
 777     $error =~ s/\.+$/\./;
 778     return $error;
 779 }
 780
 781
 782 1;
 783
 784 __END__