docs/cmdline-opts/gen.pl - third_party/curl - Git at Google

 #!/usr/bin/env perl
 #***************************************************************************
 #                                  _   _ ____  _
 #  Project                     ___| | | |  _ \| |
 #                             / __| | | | |_) | |
 #                            | (__| |_| |  _ <| |___
 #                             \___|\___/|_| \_\_____|
 #
 # Copyright (C) 1998 - 2020, Daniel Stenberg, <daniel@haxx.se>, et al.
 #
 # This software is licensed as described in the file COPYING, which
 # you should have received as part of this distribution. The terms
 # are also available at https://curl.haxx.se/docs/copyright.html.
 #
 # You may opt to use, copy, modify, merge, publish, distribute and/or sell
 # copies of the Software, and permit persons to whom the Software is
 # furnished to do so, under the terms of the COPYING file.
 #
 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
 # KIND, either express or implied.
 #
 ###########################################################################

 =begin comment

 This script generates the manpage.

 Example: gen.pl <command> [files] > curl.1

 Dev notes:

 We open *input* files in :crlf translation (a no-op on many platforms) in
 case we have CRLF line endings in Windows but a perl that defaults to LF.
 Unfortunately it seems some perls like msysgit can't handle a global input-only
 :crlf so it has to be specified on each file open for text input.

 =end comment
 =cut

 my %optshort;
 my %optlong;
 my %helplong;
 my %arglong;
 my %redirlong;
 my %protolong;

 # get the long name version, return the man page string
 sub manpageify {
     my ($k)=@_;
     my $l;
     if($optlong{$k} ne "") {
         # both short + long
         $l = "\\fI-".$optlong{$k}.", --$k\\fP";
     }
     else {
         # only long
         $l = "\\fI--$k\\fP";
     }
     return $l;
 }

 sub printdesc {
     my @desc = @_;
     for my $d (@desc) {
         # skip lines starting with space (examples)
         if($d =~ /^[^ ]/) {
             for my $k (keys %optlong) {
                 my $l = manpageify($k);
                 $d =~ s/--$k([^a-z0-9_-])/$l$1/;
             }
         }
         print $d;
     }
 }

 sub seealso {
     my($standalone, $data)=@_;
     if($standalone) {
         return sprintf
             ".SH \"SEE ALSO\"\n$data\n";
     }
     else {
         return "See also $data. ";
     }
 }

 sub overrides {
     my ($standalone, $data)=@_;
     if($standalone) {
         return ".SH \"OVERRIDES\"\n$data\n";
     }
     else {
         return $data;
     }
 }

 sub protocols {
     my ($standalone, $data)=@_;
     if($standalone) {
         return ".SH \"PROTOCOLS\"\n$data\n";
     }
     else {
         return "($data) ";
     }
 }

 sub added {
     my ($standalone, $data)=@_;
     if($standalone) {
         return ".SH \"ADDED\"\nAdded in curl version $data\n";
     }
     else {
         return "Added in $data. ";
     }
 }

 sub single {
     my ($f, $standalone)=@_;
     open(F, "<:crlf", "$f") ||
         return 1;
     my $short;
     my $long;
     my $tags;
     my $added;
     my $protocols;
     my $arg;
     my $mutexed;
     my $requires;
     my $seealso;
     my $magic; # cmdline special option
     while(<F>) {
         if(/^Short: *(.)/i) {
             $short=$1;
         }
         elsif(/^Long: *(.*)/i) {
             $long=$1;
         }
         elsif(/^Added: *(.*)/i) {
             $added=$1;
         }
         elsif(/^Tags: *(.*)/i) {
             $tags=$1;
         }
         elsif(/^Arg: *(.*)/i) {
             $arg=$1;
         }
         elsif(/^Magic: *(.*)/i) {
             $magic=$1;
         }
         elsif(/^Mutexed: *(.*)/i) {
             $mutexed=$1;
         }
         elsif(/^Protocols: *(.*)/i) {
             $protocols=$1;
         }
         elsif(/^See-also: *(.*)/i) {
             $seealso=$1;
         }
         elsif(/^Requires: *(.*)/i) {
             $requires=$1;
         }
         elsif(/^Help: *(.*)/i) {
             ;
         }
         elsif(/^---/) {
             if(!$long) {
                 print STDERR "WARN: no 'Long:' in $f\n";
             }
             last;
         }
         else {
             chomp;
             print STDERR "WARN: unrecognized line in $f, ignoring:\n:'$_';"
         }
     }
     my @desc;
     while(<F>) {
         push @desc, $_;
     }
     close(F);
     my $opt;
     if(defined($short) && $long) {
         $opt = "-$short, --$long";
     }
     elsif($short && !$long) {
         $opt = "-$short";
     }
     elsif($long && !$short) {
         $opt = "--$long";
     }

     if($arg) {
         $opt .= " $arg";
     }

     if($standalone) {
         print ".TH curl 1 \"30 Nov 2016\" \"curl 7.52.0\" \"curl manual\"\n";
         print ".SH OPTION\n";
         print "curl $opt\n";
     }
     else {
         print ".IP \"$opt\"\n";
     }
     if($protocols) {
         print protocols($standalone, $protocols);
     }

     if($standalone) {
         print ".SH DESCRIPTION\n";
     }

     printdesc(@desc);
     undef @desc;

     my @foot;
     if($seealso) {
         my @m=split(/ /, $seealso);
         my $mstr;
         for my $k (@m) {
             if(!$helplong{$k}) {
                 print STDERR "WARN: $f see-alsos a non-existing option: $k\n";
             }
             my $l = manpageify($k);
             $mstr .= sprintf "%s$l", $mstr?" and ":"";
         }
         push @foot, seealso($standalone, $mstr);
     }
     if($requires) {
         my $l = manpageify($long);
         push @foot, "$l requires that the underlying libcurl".
             " was built to support $requires. ";
     }
     if($mutexed) {
         my @m=split(/ /, $mutexed);
         my $mstr;
         for my $k (@m) {
             if(!$helplong{$k}) {
                 print STDERR "WARN: $f mutexes a non-existing option: $k\n";
             }
             my $l = manpageify($k);
             $mstr .= sprintf "%s$l", $mstr?" and ":"";
         }
         push @foot, overrides($standalone, "This option overrides $mstr. ");
     }
     if($added) {
         push @foot, added($standalone, $added);
     }
     if($foot[0]) {
         print "\n";
         my $f = join("", @foot);
         $f =~ s/ +\z//; # remove trailing space
         print "$f\n";
     }
     return 0;
 }

 sub getshortlong {
     my ($f)=@_;
     open(F, "<:crlf", "$f");
     my $short;
     my $long;
     my $help;
     my $arg;
     my $protocols;
     while(<F>) {
         if(/^Short: (.)/i) {
             $short=$1;
         }
         elsif(/^Long: (.*)/i) {
             $long=$1;
         }
         elsif(/^Help: (.*)/i) {
             $help=$1;
         }
         elsif(/^Arg: (.*)/i) {
             $arg=$1;
         }
         elsif(/^Protocols: (.*)/i) {
             $protocols=$1;
         }
         elsif(/^---/) {
             last;
         }
     }
     close(F);
     if($short) {
         $optshort{$short}=$long;
     }
     if($long) {
         $optlong{$long}=$short;
         $helplong{$long}=$help;
         $arglong{$long}=$arg;
         $protolong{$long}=$protocols;
     }
 }

 sub indexoptions {
     my (@files) = @_;
     foreach my $f (@files) {
         getshortlong($f);
     }
 }

 sub header {
     my ($f)=@_;
     open(F, "<:crlf", "$f");
     my @d;
     while(<F>) {
         push @d, $_;
     }
     close(F);
     printdesc(@d);
 }

 sub listhelp {
     foreach my $f (sort keys %helplong) {
         my $long = $f;
         my $short = $optlong{$long};
         my $opt;

         if(defined($short) && $long) {
             $opt = "-$short, --$long";
         }
         elsif($long && !$short) {
             $opt = "    --$long";
         }

         my $arg = $arglong{$long};
         if($arg) {
             $opt .= " $arg";
         }
         my $desc = $helplong{$f};
         $desc =~ s/\"/\\\"/g; # escape double quotes

         my $line = sprintf "  {\"%s\",\n   \"%s\"},\n", $opt, $desc;

         if(length($opt) + length($desc) > 78) {
             print STDERR "WARN: the --$long line is too long\n";
         }
         print $line;
     }
 }

 sub mainpage {
     my (@files) = @_;
     # show the page header
     header("page-header");

     # output docs for all options
     foreach my $f (sort @files) {
         if(single($f, 0)) {
             print STDERR "Can't read $f?\n";
         }
     }

     header("page-footer");
 }

 sub showonly {
     my ($f) = @_;
     if(single($f, 1)) {
         print STDERR "$f: failed\n";
     }
 }

 sub showprotocols {
     my %prots;
     foreach my $f (keys %optlong) {
         my @p = split(/ /, $protolong{$f});
         for my $p (@p) {
             $prots{$p}++;
         }
     }
     for(sort keys %prots) {
         printf "$_ (%d options)\n", $prots{$_};
     }
 }

 sub getargs {
     my ($f, @s) = @_;
     if($f eq "mainpage") {
         mainpage(@s);
         return;
     }
     elsif($f eq "listhelp") {
         listhelp();
         return;
     }
     elsif($f eq "single") {
         showonly($s[0]);
         return;
     }
     elsif($f eq "protos") {
         showprotocols();
         return;
     }

     print "Usage: gen.pl <mainpage/listhelp/single FILE/protos> [files]\n";
 }

 #------------------------------------------------------------------------

 my $cmd = shift @ARGV;
 my @files = @ARGV; # the rest are the files

 # learn all existing options
 indexoptions(@files);

 getargs($cmd, @files);
	#!/usr/bin/env perl
	#***************************************************************************
	# _ _ ____ _
	# Project ___\| \| \| \| _ \\| \|
	# / __\| \| \| \| \|_) \| \|
	# \| (__\| \|_\| \| _ <\| \|___
	# \___\|\___/\|_\| \_\_____\|
	#
	# Copyright (C) 1998 - 2020, Daniel Stenberg, <daniel@haxx.se>, et al.
	#
	# This software is licensed as described in the file COPYING, which
	# you should have received as part of this distribution. The terms
	# are also available at https://curl.haxx.se/docs/copyright.html.
	#
	# You may opt to use, copy, modify, merge, publish, distribute and/or sell
	# copies of the Software, and permit persons to whom the Software is
	# furnished to do so, under the terms of the COPYING file.
	#
	# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
	# KIND, either express or implied.
	#
	###########################################################################

	=begin comment

	This script generates the manpage.

	Example: gen.pl <command> [files] > curl.1

	Dev notes:

	We open input files in :crlf translation (a no-op on many platforms) in
	case we have CRLF line endings in Windows but a perl that defaults to LF.
	Unfortunately it seems some perls like msysgit can't handle a global input-only
	:crlf so it has to be specified on each file open for text input.

	=end comment
	=cut

	my %optshort;
	my %optlong;
	my %helplong;
	my %arglong;
	my %redirlong;
	my %protolong;

	# get the long name version, return the man page string
	sub manpageify {
	my ($k)=@_;
	my $l;
	if($optlong{$k} ne "") {
	# both short + long
	$l = "\\fI-".$optlong{$k}.", --$k\\fP";
	}
	else {
	# only long
	$l = "\\fI--$k\\fP";
	}
	return $l;
	}

	sub printdesc {
	my @desc = @_;
	for my $d (@desc) {
	# skip lines starting with space (examples)
	if($d =~ /^[^ ]/) {
	for my $k (keys %optlong) {
	my $l = manpageify($k);
	$d =~ s/--$k([^a-z0-9_-])/$l$1/;
	}
	}
	print $d;
	}
	}

	sub seealso {
	my($standalone, $data)=@_;
	if($standalone) {
	return sprintf
	".SH \"SEE ALSO\"\n$data\n";
	}
	else {
	return "See also $data. ";
	}
	}

	sub overrides {
	my ($standalone, $data)=@_;
	if($standalone) {
	return ".SH \"OVERRIDES\"\n$data\n";
	}
	else {
	return $data;
	}
	}

	sub protocols {
	my ($standalone, $data)=@_;
	if($standalone) {
	return ".SH \"PROTOCOLS\"\n$data\n";
	}
	else {
	return "($data) ";
	}
	}

	sub added {
	my ($standalone, $data)=@_;
	if($standalone) {
	return ".SH \"ADDED\"\nAdded in curl version $data\n";
	}
	else {
	return "Added in $data. ";
	}
	}

	sub single {
	my ($f, $standalone)=@_;
	open(F, "<:crlf", "$f") \|\|
	return 1;
	my $short;
	my $long;
	my $tags;
	my $added;
	my $protocols;
	my $arg;
	my $mutexed;
	my $requires;
	my $seealso;
	my $magic; # cmdline special option
	while(<F>) {
	if(/^Short: *(.)/i) {
	$short=$1;
	}
	elsif(/^Long: (.)/i) {
	$long=$1;
	}
	elsif(/^Added: (.)/i) {
	$added=$1;
	}
	elsif(/^Tags: (.)/i) {
	$tags=$1;
	}
	elsif(/^Arg: (.)/i) {
	$arg=$1;
	}
	elsif(/^Magic: (.)/i) {
	$magic=$1;
	}
	elsif(/^Mutexed: (.)/i) {
	$mutexed=$1;
	}
	elsif(/^Protocols: (.)/i) {
	$protocols=$1;
	}
	elsif(/^See-also: (.)/i) {
	$seealso=$1;
	}
	elsif(/^Requires: (.)/i) {
	$requires=$1;
	}
	elsif(/^Help: (.)/i) {
	;
	}
	elsif(/^---/) {
	if(!$long) {
	print STDERR "WARN: no 'Long:' in $f\n";
	}
	last;
	}
	else {
	chomp;
	print STDERR "WARN: unrecognized line in $f, ignoring:\n:'$_';"
	}
	}
	my @desc;
	while(<F>) {
	push @desc, $_;
	}
	close(F);
	my $opt;
	if(defined($short) && $long) {
	$opt = "-$short, --$long";
	}
	elsif($short && !$long) {
	$opt = "-$short";
	}
	elsif($long && !$short) {
	$opt = "--$long";
	}

	if($arg) {
	$opt .= " $arg";
	}

	if($standalone) {
	print ".TH curl 1 \"30 Nov 2016\" \"curl 7.52.0\" \"curl manual\"\n";
	print ".SH OPTION\n";
	print "curl $opt\n";
	}
	else {
	print ".IP \"$opt\"\n";
	}
	if($protocols) {
	print protocols($standalone, $protocols);
	}

	if($standalone) {
	print ".SH DESCRIPTION\n";
	}

	printdesc(@desc);
	undef @desc;

	my @foot;
	if($seealso) {
	my @m=split(/ /, $seealso);
	my $mstr;
	for my $k (@m) {
	if(!$helplong{$k}) {
	print STDERR "WARN: $f see-alsos a non-existing option: $k\n";
	}
	my $l = manpageify($k);
	$mstr .= sprintf "%s$l", $mstr?" and ":"";
	}
	push @foot, seealso($standalone, $mstr);
	}
	if($requires) {
	my $l = manpageify($long);
	push @foot, "$l requires that the underlying libcurl".
	" was built to support $requires. ";
	}
	if($mutexed) {
	my @m=split(/ /, $mutexed);
	my $mstr;
	for my $k (@m) {
	if(!$helplong{$k}) {
	print STDERR "WARN: $f mutexes a non-existing option: $k\n";
	}
	my $l = manpageify($k);
	$mstr .= sprintf "%s$l", $mstr?" and ":"";
	}
	push @foot, overrides($standalone, "This option overrides $mstr. ");
	}
	if($added) {
	push @foot, added($standalone, $added);
	}
	if($foot[0]) {
	print "\n";
	my $f = join("", @foot);
	$f =~ s/ +\z//; # remove trailing space
	print "$f\n";
	}
	return 0;
	}

	sub getshortlong {
	my ($f)=@_;
	open(F, "<:crlf", "$f");
	my $short;
	my $long;
	my $help;
	my $arg;
	my $protocols;
	while(<F>) {
	if(/^Short: (.)/i) {
	$short=$1;
	}
	elsif(/^Long: (.*)/i) {
	$long=$1;
	}
	elsif(/^Help: (.*)/i) {
	$help=$1;
	}
	elsif(/^Arg: (.*)/i) {
	$arg=$1;
	}
	elsif(/^Protocols: (.*)/i) {
	$protocols=$1;
	}
	elsif(/^---/) {
	last;
	}
	}
	close(F);
	if($short) {
	$optshort{$short}=$long;
	}
	if($long) {
	$optlong{$long}=$short;
	$helplong{$long}=$help;
	$arglong{$long}=$arg;
	$protolong{$long}=$protocols;
	}
	}

	sub indexoptions {
	my (@files) = @_;
	foreach my $f (@files) {
	getshortlong($f);
	}
	}

	sub header {
	my ($f)=@_;
	open(F, "<:crlf", "$f");
	my @d;
	while(<F>) {
	push @d, $_;
	}
	close(F);
	printdesc(@d);
	}

	sub listhelp {
	foreach my $f (sort keys %helplong) {
	my $long = $f;
	my $short = $optlong{$long};
	my $opt;

	if(defined($short) && $long) {
	$opt = "-$short, --$long";
	}
	elsif($long && !$short) {
	$opt = " --$long";
	}

	my $arg = $arglong{$long};
	if($arg) {
	$opt .= " $arg";
	}
	my $desc = $helplong{$f};
	$desc =~ s/\"/\\\"/g; # escape double quotes

	my $line = sprintf " {\"%s\",\n \"%s\"},\n", $opt, $desc;

	if(length($opt) + length($desc) > 78) {
	print STDERR "WARN: the --$long line is too long\n";
	}
	print $line;
	}
	}

	sub mainpage {
	my (@files) = @_;
	# show the page header
	header("page-header");

	# output docs for all options
	foreach my $f (sort @files) {
	if(single($f, 0)) {
	print STDERR "Can't read $f?\n";
	}
	}

	header("page-footer");
	}

	sub showonly {
	my ($f) = @_;
	if(single($f, 1)) {
	print STDERR "$f: failed\n";
	}
	}

	sub showprotocols {
	my %prots;
	foreach my $f (keys %optlong) {
	my @p = split(/ /, $protolong{$f});
	for my $p (@p) {
	$prots{$p}++;
	}
	}
	for(sort keys %prots) {
	printf "$_ (%d options)\n", $prots{$_};
	}
	}

	sub getargs {
	my ($f, @s) = @_;
	if($f eq "mainpage") {
	mainpage(@s);
	return;
	}
	elsif($f eq "listhelp") {
	listhelp();
	return;
	}
	elsif($f eq "single") {
	showonly($s[0]);
	return;
	}
	elsif($f eq "protos") {
	showprotocols();
	return;
	}

	print "Usage: gen.pl <mainpage/listhelp/single FILE/protos> [files]\n";
	}

	#------------------------------------------------------------------------

	my $cmd = shift @ARGV;
	my @files = @ARGV; # the rest are the files

	# learn all existing options
	indexoptions(@files);

	getargs($cmd, @files);