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

393 lines
7.7 KiB
Perl
Raw Normal View History

#
# 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;