bird/tools/linuxdoc-tools/LinuxDocTools/Utils.pm

#
#  Utils.pm
#
#  $Id: Utils.pm,v 1.2 2001/08/31 22:39:44 sano Exp $
#
#  Utilities, split off from other modules in order to cut down file size.
#
#  <20> Copyright 1996, 1997, Cees de Groot
#
package LinuxDocTools::Utils;
use strict;

=head1 NAME

LinuxDocTools::Utils - various supporting routines

=head1 SYNOPSIS

  @files = process_options (@args);

  usage ($msg);

  trap_signals;

  cleanup;

  create_temp($tempfile)

=head1 DESCRIPTION

The B<LinuxDocTools::Utils> module contains a number of generic routines, mainly
split off from the main module in order to keep file size down.

=head1 FUNCTIONS

=over 4

=cut

use DirHandle;
use FileHandle;
use Cwd;
use File::Basename;
use Exporter;
use LinuxDocTools::Vars;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $in_signal);
@ISA = qw(Exporter);
@EXPORT = qw(usage process_options);
@EXPORT_OK = qw(cleanup trap_signals remove_tmpfiles create_temp);
$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);

use subs qw(usage);

# check whether options are unique
sub check_option_consistency
{
    my $owner = {};
    my ($fmt, $opt);
    foreach $fmt (keys %FmtList)
    {
	my $add = sub {		# add to options of $fmt
	    my $str = shift;
	    if ($owner->{$str}) {
		push(@{$owner->{$str}}, $fmt);
	    }
	    else {
		$owner->{$str} = [$fmt];
	    }
	};
	foreach $opt (@{$Formats{$fmt}{OPTIONS}})
	{
	    &$add("--$opt->{option}");
	    &$add("-$opt->{short}");
	}
    }
    my $error = 0;
    foreach $opt (keys %$owner)
    {
	if (scalar @{$owner->{$opt}} > 1)
	{
	    warn "duplicate option: $opt in " .
		join(', ', @{$owner->{$opt}}) . "\n";
	    $error = 1;
	}
    }
    die "Internal error detected" if $error;
}


=item process_options

This function processes the command line, and sets the variables associated
with the options along the way. When successful, it returns the arguments
on the command line it didn't interpret. Normally, this will be a list of
filenames.

=cut

sub process_options
{
  my @args = @_;
  my @retval;

  OPTPROC: while ($args[0]) 
    {
      my $long;
      my $curarg = $args[0];  
      if ($curarg =~ /^--.*/)
	{
	  #
	  #  Long option, --opt[==value]
	  #
	  $long = 1;
	}
      elsif ($curarg =~ /^-.*/)
	{
	  #
	  #  Short option, -o value
	  #
	  $long = 0;
	}
      else
	{
	  #
	  #  Filename
	  #
	  push @retval, $curarg;
	  next OPTPROC;
	}

      #
      #  Start looking for the option
      #
      foreach my $fmt (keys %FmtList)
	{
	  foreach my $opt (@{$Formats{$fmt}{OPTIONS}})
	    {
	      if (($long && $curarg =~ /^--$opt->{option}.*/) ||
		  $curarg =~ /^-$opt->{short}/)
		{
		  #
		  #  Found it! Get the argument and see whether all is OK
		  #  with the option.
		  #
		  my $optval = "";
		  if ($long)
		   {
		     if ($curarg =~ /^--$opt->{option}=.*/)
		       {
			 $optval = $curarg;
			 $optval =~ s/[^=]*=(.*)/$1/;
		       }
		   }
		  else
		   {
		     if ($args[1] =~ /^[^-].*/)
		       {
			 $optval = $args[1];
		       }
		   }
		  $opt->{type} eq "f" && do
		    {
		      #
		      #  "f" -> flag. Increment, so '-v -v' can work.
		      #
		      $Formats{$fmt}{$opt->{option}} += 1;
		      next OPTPROC;
		    };
		  #
		  #  All other types require a value (for now).
		  #
		  shift @args unless $long;
		  if ($optval eq "") 
		    {
		      usage "Option $curarg: value required";
		    }
		  ($opt->{type} eq "i" || $opt->{type} eq "s") && do
		    {
		      #
		      #  "i" -> numeric value.
		      #  "s" -> string value.
		      #
		      #  No type checking yet...
		      #
		      if ($opt->{option} eq "define")
			{
		          $Formats{$fmt}{$opt->{option}} .= " " . $optval;
			}
		      else
			{
			  $Formats{$fmt}{$opt->{option}} = $optval;
			}
		      next OPTPROC;
		    };
		  $opt->{type} eq "l" && do
		    {
		      #
		      #  "l" -> list of values.
		      #
		      foreach my $val (@{$opt->{'values'}})
			{
			  if ($val eq $optval)
			    {
			       $Formats{$fmt}{$opt->{option}} = $optval; 
			       next OPTPROC;
			    }
			}
		      usage "Invalid value '$optval' for '--$opt->{option}'";
		    };
		  usage "Unknown option type $opt->{type} in $fmt/$opt";
		}
	    } 
	}
      usage "Unknown option $curarg";
    }
  continue
    {
      shift @args;
    }
  return @retval;
}


=item usage

Prints out a generated help message about calling convention and allowed
options, then the argument string, and finally exits. 

=cut

sub usage
{
  my ($msg) = @_;

  print "LinuxDoc-Tools version " . `cat $main::DataDir/VERSION` . "\n";
  check_option_consistency;
  print "Usage:\n";
  print "  " . $global->{myname} . " [options] <infile>\n\n";
  my @helplist = sort(keys %Formats);
  @helplist = sort (keys %FmtList) if ($global->{format});
  foreach my $fmt (@helplist)
    {
      if ($fmt eq "global")
        {
	  print "General options:\n";
	}
      else
        {
          print "Format: " . $fmt . "\n";
	}
      print $Formats{$fmt}{HELP};
      for my $opt (@{$Formats{$fmt}{OPTIONS}})
        {
	  my $value = '';
	  if ($opt->{type} eq "i")
	    {
	      $value = "number";
	    }
          elsif ($opt->{type} eq "l")
	    {
	      $value = "{";
	      my $first = 1;
	      for my $val (@{$opt->{'values'}})
	        {
		  $first || ($value .= ",");
		  $first = 0;
		  $value .= $val;
		}
	      $value .= "}";
	    }
	  elsif ($opt->{type} eq "s")
            {
	      $value = "string";
	    }
	  print "  --$opt->{option}"; print "=$value" if $value;
	  print " -$opt->{short}"; print " $value" if $value;
	  print "\n";
	}
      print "\n";
    }

  $msg && print "Error: $msg\n\n";
  exit 1;
}


=item cleanup

This function cleans out all temporary files and exits. The unlink step
is skipped if debugging is turned on.

=cut

sub cleanup
{
    my ($signame) = @_;

    if( $signame ) {
        if ( $in_signal ) {
            if( $global->{debug} ) {
                print STDERR "Caught SIG$signame during cleanup -- aborting\n";
            }
            exit -1;
       }
       else {
           if( $global->{debug} ) {
               print STDERR "Caught SIG$signame -- cleaning up\n";
           }
           $in_signal = 1;
       }
    }

    if( !$global->{debug} && $global->{tmpbase} ) {
        remove_tmpfiles($global->{tmpbase});
    }
    exit 0;
}

=item remove_tmpfiles( $tmpbase )

This function cleans out all temporary files, using the argument $tmpbase to
determine the directory and pattern to use to find the temporary files.

=cut

sub remove_tmpfiles($) {
    my $tmpbase = shift;
    my ($name,$tmpdir) = fileparse($tmpbase,"");
    my $namelength = length $name;
    my $savdir = cwd;

    chdir($tmpdir);
    my $dir = new DirHandle(".");
    
    if (!defined($dir) ) {
        warn "Couldn't open temp directory $tmpdir: $!\n";
    } else {
        foreach my $tmpfile ($dir->read()) {
	    if (substr ($tmpfile, 0, $namelength) eq $name) {
	      unlink ($tmpfile) || warn "Couldn't unlink $tmpfile: $! \n";
	    }
        }
        $dir->close();
    }

    chdir($savdir);
    rmdir($tmpdir) || return -1;
}

=item trap_signals

This function traps all known signals, making sure that the B<cleanup>
function is executed on them. It should be called once at initialization
time.

=cut

sub trap_signals
{
  foreach my $sig ( 'HUP',  'INT',  'QUIT', 'ILL',
                    'TRAP', 'IOT',  'BUS',  'FPE',
                    'USR1', 'SEGV', 'USR2',
                    'PIPE', 'ALRM', 'TERM', )
    {
      $SIG{$sig} = \&cleanup;
    }
}

=item create_temp ( $tmpfile )

This function creates an empty temporary file with the required
permission for security reasons.

=cut

sub create_temp($) {
  my $tmpnam = shift;
  my $fh = new FileHandle($tmpnam,O_CREAT|O_EXCL|O_WRONLY,0600);
  $fh or die "$0: failed to create temporary file: $!";
  $fh->close;
}

=back

=head1 AUTHOR

Cees de Groot,  C<E<lt>cg@pobox.comE<gt>>.

=cut

1;