#
#  Utils.pm
#
#  $Id: Utils.pm,v 1.16 1998/10/13 11:50:31 cg Exp $
#
#  Utilities, split off from other modules in order to cut down file size.
#
#  © Copyright 1996, 1997, Cees de Groot
#
package SGMLTools::Utils;
use strict;

=head1 NAME

SGMLTools::Utils - various supporting routines

=head1 SYNOPSIS

  @files = process_options (@args);

  usage ($msg);

  trap_signals;

  cleanup;

=head1 DESCRIPTION

The B<SGMLTools::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 Exporter;
use SGMLTools::Vars;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT = qw(usage process_options);
@EXPORT_OK = qw(cleanup trap_signals remove_tmpfiles);
$VERSION = sprintf("%d.%02d", q$Revision: 1.16 $ =~ /(\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...
		      #
		      $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 "SGML-Tools version " . `cat $main::LibDir/VERSION` . "\n";
  check_option_consistency;
  print "Usage:\n";
  print "  " . $global->{myname} . " [options] <infile>\n";
  my @helplist = keys %Formats;
  @helplist = 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
{
    if( !$global->{debug} ) {
        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($) {
    use Cwd;
    use File::Basename;

    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";
    }
}

=back

=head1 AUTHOR

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

=cut

1;