autoconf/build-aux/help-extract.pl

# help-extract -- extract --help and --version output from a script.
# Copyright (C) 2020 Free Software Foundation, Inc.

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

# Written by Zack Weinberg.

use strict;
use warnings;

# File::Spec itself was added in 5.005.
# File::Spec::Functions was added in 5.6.1 which is just barely too new.
use File::Spec;

# This script is not intended to be used directly.  It's run by
# help2man via wrappers in man/, e.g.  man/autoconf.w, as if it were
# one of autoconf's executable scripts.  It extracts the --help and
# --version output of that script from its source form, without
# actually running it.  The script to work from is set by the wrapper,
# and several other parameters are passed down from the Makefile as
# environment variables; see parse_args below.

# The point of this script is, the preprocessed forms of the
# executable scripts, and their wrappers for uninstalled use
# (e.g. <build-dir>/{bin,tests}/autoconf) do not need to exist to
# generate the corresponding manpages.  This is desirable because we
# can't put those dependencies in the makefiles without breaking
# people's ability to build autoconf from a release tarball without
# help2man installed.  It also ensures that we will generate manpages
# from the current source code and not from an older version of the
# script that has already been installed.

## ----------------------------- ##
## Extraction from Perl scripts. ##
## ----------------------------- ##

sub eval_qq_no_interpolation ($)
{
  # The argument is expected to be a "double quoted string" including the
  # leading and trailing delimiters.  Returns the text of this string after
  # processing backslash escapes but NOT interpolation.
  # / (?<!\\) (?>\\\\)* blah /x means match blah preceded by an
  # *even* number of backslashes.  It would be nice if we could use \K
  # to exclude the backslashes from the matched text, but that was only
  # added in Perl 5.10 and we still support back to 5.006.
  return eval $_[0] =~ s/ (?<!\\) (?>\\\\)* [\$\@] /\\$&/xrg;
}

sub extract_channeldefs_usage ($)
{
  my ($channeldefs_pm) = @_;
  my $usage = "";
  my $parse_state = 0;
  local $_;

  open (my $fh, "<", $channeldefs_pm) or die "$channeldefs_pm: $!\n";
  while (<$fh>)
    {
      if ($parse_state == 0)
	{
	  $parse_state = 1 if /^sub usage\b/;
	}
      elsif ($parse_state == 1)
	{
	  if (s/^  return "//)
	    {
	      $parse_state = 2;
	      $usage .= $_;
	    }
	}
      elsif ($parse_state == 2)
	{
	  if (s/(?<!\\) ((?>\\\\)*) "; $/$1/x)
	    {
	      $usage .= $_;
	      return $usage;
	    }
	  else
	    {
	      $usage .= $_;
	    }
	}
    }

  die "$channeldefs_pm: unexpected EOF in state $parse_state\n";
}

sub extract_perl_assignment (*$$$)
{
  my ($fh, $source, $channeldefs_pm, $what) = @_;
  my $value = "";
  my $parse_state = 0;
  local $_;

  while (<$fh>)
    {
      if ($parse_state == 0)
	{
	  if (s/^\$\Q${what}\E = (?=")//o)
	    {
	      $value .= $_;
	      $parse_state = 1;
	    }
	}
      elsif ($parse_state == 1)
	{
	  if (/^"\s*\.\s*Autom4te::ChannelDefs::usage\s*(?:\(\))?\s*\.\s*"$/)
	    {
	      $value .= extract_channeldefs_usage ($channeldefs_pm);
	    }
	  elsif (/^";$/)
	    {
	      $value .= '"';
	      return eval_qq_no_interpolation ($value);
	    }
	  else
	    {
	      $value .= $_;
	    }
	}
    }

  die "$source: unexpected EOF in state $parse_state\n";
}


## ------------------------------ ##
## Extraction from shell scripts. ##
## ------------------------------ ##

sub extract_shell_assignment (*$$)
{
  my ($fh, $source, $what) = @_;
  my $value = "";
  my $parse_state = 0;
  local $_;

  while (<$fh>)
    {
      if ($parse_state == 0)
	{
	  if (/^\Q${what}\E=\[\"\\$/)
	    {
	      $parse_state = 1;
	    }
	}
      elsif ($parse_state == 1)
	{
	  my $done = s/"\]$//;
	  $value .= $_;
	  if ($done)
	    {
	      # This is not strictly correct but it works acceptably
	      # for the escapes that actually occur in the strings
	      # we're extracting.
	      return eval_qq_no_interpolation ('"'.$value.'"');
	    }
	}
    }

  die "$source: unexpected EOF in state $parse_state\n";
}


## -------------- ##
## Main program.  ##
## -------------- ##


sub extract_assignment ($$$)
{
  my ($source, $channeldefs_pm, $what) = @_;

  open (my $fh, "<", $source) or die "$source: $!\n";

  my $firstline = <$fh>;
  if ($firstline =~ /\@PERL\@/ || $firstline =~ /-\*-\s*perl\s*-\*-/i)
    {
      return extract_perl_assignment ($fh, $source, $channeldefs_pm, $what);
    }
  elsif ($firstline =~ /\bAS_INIT\b/
	 || $firstline =~ /bin\/[a-z0-9]*sh\b/
	 || $firstline =~ /-\*-\s*shell-script\s*-\*-/i)
    {
      return extract_shell_assignment ($fh, $source, $what);
    }
  else
    {
      die "$source: language not recognized\n";
    }
}

sub main ()
{
  # Most of our arguments come from environment variables, because
  # help2man doesn't allow for passing additional command line
  # arguments to the wrappers, and it's easier to write the wrappers
  # to not mess with the command line.
  my $usage = "Usage: $0 script-source (--help | --version)

Extract help and version information from a perl or shell script.
Required environment variables:

  top_srcdir       relative path from cwd to the top of the source tree
  channeldefs_pm   relative path from top_srcdir to ChannelDefs.pm
  PACKAGE_NAME     the autoconf PACKAGE_NAME substitution variable
  VERSION          the autoconf VERSION substitution variable
  RELEASE_YEAR     the autoconf RELEASE_YEAR substitution variable

The script-source argument should also be relative to top_srcdir.
";

  my $source         = shift(@ARGV)         || die $usage;
  my $what           = shift(@ARGV)         || die $usage;
  my $top_srcdir     = $ENV{top_srcdir}     || die $usage;
  my $channeldefs_pm = $ENV{channeldefs_pm} || die $usage;
  my $package_name   = $ENV{PACKAGE_NAME}   || die $usage;
  my $version        = $ENV{VERSION}        || die $usage;
  my $release_year   = $ENV{RELEASE_YEAR}   || die $usage;

  if ($what eq "-h" || $what eq "--help")
    {
      $what = "help";
    }
  elsif ($what eq "-V" || $what eq "--version")
    {
      $what = "version";
    }
  else
    {
      die $usage;
    }

  my $cmd_name    = $source =~ s{^.*/([^./]+)\.(?:as|in)$}{$1}r;
  $source         = File::Spec->catfile($top_srcdir, $source);
  $channeldefs_pm = File::Spec->catfile($top_srcdir, $channeldefs_pm);

  my $text = extract_assignment ($source, $channeldefs_pm, $what);
  $text =~ s/\$0\b/$cmd_name/g;
  $text =~ s/[@]PACKAGE_NAME@/$package_name/g;
  $text =~ s/[@]VERSION@/$version/g;
  $text =~ s/[@]RELEASE_YEAR@/$release_year/g;
  print $text;
}

main;


### Setup "GNU" style for perl-mode and cperl-mode.
## Local Variables:
## perl-indent-level: 2
## perl-continued-statement-offset: 2
## perl-continued-brace-offset: 0
## perl-brace-offset: 0
## perl-brace-imaginary-offset: 0
## perl-label-offset: -2
## cperl-indent-level: 2
## cperl-brace-offset: 0
## cperl-continued-brace-offset: 0
## cperl-label-offset: -2
## cperl-extra-newline-before-brace: t
## cperl-merge-trailing-else: nil
## cperl-continued-statement-offset: 2
## End: