1# ----------------------------------------------------------------------
2#  Utils.pm
3#
4#  Utilities, refactored from other modules for easier maintenance.
5#
6#  Copyright (C) 1996, 1997, Cees de Groot
7#  Copyright (C) 2020,       Agustin Martin
8# ----------------------------------------------------------------------
9
10package LinuxDocTools::Utils;
11use strict;
12
13=head1 NAME
14
15LinuxDocTools::Utils - various supporting routines
16
17=head1 SYNOPSIS
18
19  @files = process_options (@args);
20
21  usage ($msg);
22
23  trap_signals;
24
25  cleanup;
26
27  create_temp($tempfile);
28
29  ldt_log;
30
31  ldt_which;
32
33  remove_tmpfiles
34
35=head1 DESCRIPTION
36
37The B<LinuxDocTools::Utils> module contains a number of generic routines, mainly
38split off from the main module in order to keep file size down.
39
40=head1 FUNCTIONS
41
42=over 4
43
44=cut
45
46use DirHandle;
47use FileHandle;
48use Cwd;
49use File::Basename;
50use base qw(Exporter);
51use subs qw(usage);
52use LinuxDocTools::Vars;
53
54our $in_signal;
55
56# List all unconditionally exported symbols here.
57our @EXPORT = qw(
58  usage
59  process_options
60);
61
62# List all conditionally exported symbols here.
63our @EXPORT_OK = qw(
64  cleanup
65  create_temp
66  ldt_err_log
67  ldt_log
68  ldt_which
69  remove_tmpfiles
70  trap_signals
71  );
72
73# Import :all to get everything.
74our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
75
76
77=item ldt_which
78
79Search for an executable in PATH.
80
81=cut
82
83# ---------------------------------------------------------------------
84sub ldt_which {
85  # -------------------------------------------------------------------
86  # Search for an executable in PATH
87  # -------------------------------------------------------------------
88  die "ldt_which: No filename(s) array given. Aborting ...\n"
89    unless scalar @_;
90
91  foreach my $file ( @_ ){
92    if ( $file =~ m/\// ) {
93      return $file if -x $file;
94    } else {
95      foreach my $path ( split(':',$ENV{'PATH'}) ){
96	$path =~ s/\/+$//;
97	return $file if -x "$path/$file";
98      }
99    }
100  }
101  die "No executable found in path for (", join(' ',@_) ,"). Aborting ...\n";
102}
103
104
105=item ldt_log
106
107Write passed info to $global->{logfile}
108
109=cut
110
111# ---------------------------------------------------------------
112sub ldt_log {
113  # -------------------------------------------------------------
114  # Print string to $global->{logfile} It must be defined and exists
115  # (it is defined per-file in process_file function ). Will fail if
116  # undefined or non existent.
117  # -------------------------------------------------------------
118  my $text = shift;
119
120  if ( defined $global->{logfile} ){
121    open (my $LOGFILE, ">>", "$global->{logfile}")
122      or die "Utils::ldt_log: Could not open \"$global->{logfile}\" logfile for write.\n";
123    print $LOGFILE "$text\n";
124    close $LOGFILE;
125  } else {
126    die "Utils::ldt_log: \$global->{logfile} undefined. Is function used too early? Aborting ...\n";
127  }
128}
129
130
131=item ldt_err_log
132
133Write passed info to $global->{logfile} and STDERR
134
135=cut
136
137# ---------------------------------------------------------------
138sub ldt_err_log {
139  # -------------------------------------------------------------
140  # Print string to STDERR and $global->{logfile}.
141  # $global->{logfile} must be defined and must exist
142  # (it is defined per-file in process_file function ).
143  # Will fail if undefined or non existent.
144  # -------------------------------------------------------------
145  my $text = shift;
146
147  if ( defined $global->{logfile} ){
148    open (my $LOGFILE, ">>", "$global->{logfile}")
149      or die "Utils::ldt_log: Could not open \"$global->{logfile}\" logfile for write.\n";
150    print $LOGFILE "$text\n";
151    close $LOGFILE;
152    print STDERR "$text\n";
153  } else {
154    die "Utils::ldt_log: \$global->{logfile} undefined. Is function used too early? Aborting ...\n";
155  }
156}
157
158# check whether options are unique
159sub check_option_consistency
160{
161    my $owner = {};
162    my ($fmt, $opt);
163    foreach $fmt (keys %FmtList)
164    {
165	my $add = sub {		# add to options of $fmt
166	    my $str = shift;
167	    if ($owner->{$str}) {
168		push(@{$owner->{$str}}, $fmt);
169	    }
170	    else {
171		$owner->{$str} = [$fmt];
172	    }
173	};
174	foreach $opt (@{$Formats{$fmt}{OPTIONS}})
175	{
176	    &$add("--$opt->{option}");
177	    &$add("-$opt->{short}");
178	}
179    }
180    my $error = 0;
181    foreach $opt (keys %$owner)
182    {
183	if (scalar @{$owner->{$opt}} > 1)
184	{
185	    warn "duplicate option: $opt in " .
186		join(', ', @{$owner->{$opt}}) . "\n";
187	    $error = 1;
188	}
189    }
190    die "Internal error detected" if $error;
191}
192
193
194=item process_options
195
196This function processes the command line, and sets the variables associated
197with the options along the way. When successful, it returns the arguments
198on the command line it didn't interpret. Normally, this will be a list of
199filenames.
200
201=cut
202
203sub process_options
204{
205  my @args = @_;
206  my @retval;
207
208  OPTPROC: while ($args[0])
209    {
210      my $long;
211      my $curarg = $args[0];
212      if ($curarg =~ /^--.*/)
213	{
214	  #
215	  #  Long option, --opt[==value]
216	  #
217	  $long = 1;
218	}
219      elsif ($curarg =~ /^-.*/)
220	{
221	  #
222	  #  Short option, -o value
223	  #
224	  $long = 0;
225	}
226      else
227	{
228	  #
229	  #  Filename
230	  #
231	  push @retval, $curarg;
232	  next OPTPROC;
233	}
234
235      #
236      #  Start looking for the option
237      #
238      foreach my $fmt (keys %FmtList)
239	{
240	  foreach my $opt (@{$Formats{$fmt}{OPTIONS}})
241	    {
242	      if (($long && $curarg =~ /^--$opt->{option}.*/) ||
243		  $curarg =~ /^-$opt->{short}/)
244		{
245		  #
246		  #  Found it! Get the argument and see whether all is OK
247		  #  with the option.
248		  #
249		  my $optval = "";
250		  if ($long)
251		   {
252		     if ($curarg =~ /^--$opt->{option}=.*/)
253		       {
254			 $optval = $curarg;
255			 $optval =~ s/[^=]*=(.*)/$1/;
256		       }
257		   }
258		  else
259		   {
260		     if ($args[1] =~ /^[^-].*/)
261		       {
262			 $optval = $args[1];
263		       }
264		   }
265		  $opt->{type} eq "f" && do
266		    {
267		      #
268		      #  "f" -> flag. Increment, so '-v -v' can work.
269		      #
270		      $Formats{$fmt}{$opt->{option}} += 1;
271		      next OPTPROC;
272		    };
273		  #
274		  #  All other types require a value (for now).
275		  #
276		  shift @args unless $long;
277		  if ($optval eq "")
278		    {
279		      usage "Option $curarg: value required";
280		    }
281		  ($opt->{type} eq "i" || $opt->{type} eq "s") && do
282		    {
283		      #
284		      #  "i" -> numeric value.
285		      #  "s" -> string value.
286		      #
287		      #  No type checking yet...
288		      #
289		      if ($opt->{option} eq "define")
290			{
291		          $Formats{$fmt}{$opt->{option}} .= " " . $optval;
292			}
293		      else
294			{
295			  $Formats{$fmt}{$opt->{option}} = $optval;
296			}
297		      next OPTPROC;
298		    };
299		  $opt->{type} eq "l" && do
300		    {
301		      #
302		      #  "l" -> list of values.
303		      #
304		      foreach my $val (@{$opt->{'values'}})
305			{
306			  if ($val eq $optval)
307			    {
308			       $Formats{$fmt}{$opt->{option}} = $optval;
309			       next OPTPROC;
310			    }
311			}
312		      usage "Invalid value '$optval' for '--$opt->{option}'";
313		    };
314		  usage "Unknown option type $opt->{type} in $fmt/$opt";
315		}
316	    }
317	}
318      usage "Unknown option $curarg";
319    }
320  continue
321    {
322      shift @args;
323    }
324  return @retval;
325}
326
327
328=item usage
329
330Prints out a generated help message about calling convention and allowed
331options, then the argument string, and finally exits.
332
333=cut
334
335sub usage
336{
337  my ($msg) = @_;
338
339  print "LinuxDoc-Tools version " . `cat $main::DataDir/VERSION` . "\n";
340  check_option_consistency;
341  print "Usage:\n";
342  print "  " . $global->{myname} . " [options] <infile>\n\n";
343  my @helplist = sort(keys %Formats);
344  @helplist = sort (keys %FmtList) if ($global->{format});
345  foreach my $fmt (@helplist)
346    {
347      if ($fmt eq "global")
348        {
349	  print "General options:\n";
350	}
351      else
352        {
353          print "Format: " . $fmt . "\n";
354	}
355      print $Formats{$fmt}{HELP};
356      for my $opt (@{$Formats{$fmt}{OPTIONS}})
357        {
358	  my $value = '';
359	  if ($opt->{type} eq "i")
360	    {
361	      $value = "number";
362	    }
363          elsif ($opt->{type} eq "l")
364	    {
365	      $value = "{";
366	      my $first = 1;
367	      for my $val (@{$opt->{'values'}})
368	        {
369		  $first || ($value .= ",");
370		  $first = 0;
371		  $value .= $val;
372		}
373	      $value .= "}";
374	    }
375	  elsif ($opt->{type} eq "s")
376            {
377	      $value = "string";
378	    }
379	  print "  --$opt->{option}"; print "=$value" if $value;
380	  print " -$opt->{short}"; print " $value" if $value;
381	  print "\n";
382	}
383      print "\n";
384    }
385
386  $msg && print "Error: $msg\n\n";
387  exit 1;
388}
389
390
391=item cleanup
392
393This function cleans out all temporary files and exits. The unlink step
394is skipped if debugging is turned on.
395
396=cut
397
398sub cleanup
399{
400    my ($signame) = @_;
401
402    if( $signame ) {
403        if ( $in_signal ) {
404            if( $global->{debug} ) {
405                print STDERR "Caught SIG$signame during cleanup -- aborting\n";
406            }
407            exit -1;
408       }
409       else {
410           if( $global->{debug} ) {
411               print STDERR "Caught SIG$signame -- cleaning up\n";
412           }
413           $in_signal = 1;
414       }
415    }
416
417    if( !$global->{debug} && $global->{tmpbase} ) {
418        remove_tmpfiles($global->{tmpbase});
419    }
420    exit 0;
421}
422
423=item remove_tmpfiles( $tmpbase )
424
425This function cleans out all temporary files, using the argument $tmpbase to
426determine the directory and pattern to use to find the temporary files.
427
428=cut
429
430sub remove_tmpfiles($) {
431    my $tmpbase = shift;
432    my ($name,$tmpdir) = fileparse($tmpbase,"");
433    my $namelength = length $name;
434    my $savdir = cwd;
435
436    chdir($tmpdir);
437    my $dir = new DirHandle(".");
438
439    if (!defined($dir) ) {
440        warn "Couldn't open temp directory $tmpdir: $!\n";
441    } else {
442        foreach my $tmpfile ($dir->read()) {
443	    if (substr ($tmpfile, 0, $namelength) eq $name) {
444	      unlink ($tmpfile) || warn "Couldn't unlink $tmpfile: $! \n";
445	    }
446        }
447        $dir->close();
448    }
449
450    chdir($savdir);
451    rmdir($tmpdir) || return -1;
452}
453
454=item trap_signals
455
456This function traps all known signals, making sure that the B<cleanup>
457function is executed on them. It should be called once at initialization
458time.
459
460=cut
461
462sub trap_signals
463{
464  foreach my $sig ( 'HUP',  'INT',  'QUIT', 'ILL',
465                    'TRAP', 'IOT',  'BUS',  'FPE',
466                    'USR1', 'SEGV', 'USR2',
467                    'PIPE', 'ALRM', 'TERM', )
468    {
469      $SIG{$sig} = \&cleanup;
470    }
471}
472
473=item create_temp ( $tmpfile )
474
475This function creates an empty temporary file with the required
476permission for security reasons.
477
478=cut
479
480sub create_temp($) {
481  my $tmpnam = shift;
482  my $fh = new FileHandle($tmpnam,O_CREAT|O_EXCL|O_WRONLY,0600);
483  $fh or die "$0: failed to create temporary file: $!";
484  $fh->close;
485}
486
487=back
488
489=head1 AUTHOR
490
491Cees de Groot,  C<E<lt>cg@pobox.comE<gt>>.
492
493=cut
494
4951;
496