123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575 |
- #!/usr/bin/env perl
- #***************************************************************************
- # _ _ ____ _
- # Project ___| | | | _ \| |
- # / __| | | | |_) | |
- # | (__| |_| | _ <| |___
- # \___|\___/|_| \_\_____|
- #
- # Copyright (C) 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.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.
- #
- # SPDX-License-Identifier: curl
- #
- ###########################################################################
- =begin comment
- Converts a curldown file to nroff (manpage).
- =end comment
- =cut
- use strict;
- use warnings;
- my $cd2nroff = "0.1"; # to keep check
- my $dir;
- my $extension;
- my $keepfilename;
- while(@ARGV) {
- if($ARGV[0] eq "-d") {
- shift @ARGV;
- $dir = shift @ARGV;
- }
- elsif($ARGV[0] eq "-e") {
- shift @ARGV;
- $extension = shift @ARGV;
- }
- elsif($ARGV[0] eq "-k") {
- shift @ARGV;
- $keepfilename = 1;
- }
- elsif($ARGV[0] eq "-h") {
- print <<HELP
- Usage: cd2nroff [options] [file.md]
- -d <dir> Write the output to the file name from the meta-data in the
- specified directory, instead of writing to stdout
- -e <ext> If -d is used, this option can provide an added "extension", arbitrary
- text really, to append to the file name.
- -h This help text,
- -v Show version then exit
- HELP
- ;
- exit 0;
- }
- elsif($ARGV[0] eq "-v") {
- print "cd2nroff version $cd2nroff\n";
- exit 0;
- }
- else {
- last;
- }
- }
- use POSIX qw(strftime);
- my @ts;
- if (defined($ENV{SOURCE_DATE_EPOCH})) {
- @ts = gmtime($ENV{SOURCE_DATE_EPOCH});
- } else {
- @ts = localtime;
- }
- my $date = strftime "%Y-%m-%d", @ts;
- sub outseealso {
- my (@sa) = @_;
- my $comma = 0;
- my @o;
- push @o, ".SH SEE ALSO\n";
- for my $s (sort @sa) {
- push @o, sprintf "%s.BR $s", $comma ? ",\n": "";
- $comma = 1;
- }
- push @o, "\n";
- return @o;
- }
- sub outprotocols {
- my (@p) = @_;
- my $comma = 0;
- my @o;
- push @o, ".SH PROTOCOLS\n";
- if($p[0] eq "TLS") {
- push @o, "This functionality affects all TLS based protocols: HTTPS, FTPS, IMAPS, POP3S, SMTPS etc.";
- }
- else {
- my @s = sort @p;
- push @o, "This functionality affects ";
- for my $e (sort @s) {
- push @o, sprintf "%s%s",
- $comma ? (($e eq $s[-1]) ? " and " : ", "): "",
- lc($e);
- $comma = 1;
- }
- if($#s == 0) {
- if($s[0] eq "All") {
- push @o, " supported protocols";
- }
- else {
- push @o, " only";
- }
- }
- }
- push @o, "\n";
- return @o;
- }
- sub outtls {
- my (@t) = @_;
- my $comma = 0;
- my @o;
- if($t[0] eq "All") {
- push @o, "\nAll TLS backends support this option.";
- }
- else {
- push @o, "\nThis option works only with the following TLS backends:\n";
- my @s = sort @t;
- for my $e (@s) {
- push @o, sprintf "%s$e",
- $comma ? (($e eq $s[-1]) ? " and " : ", "): "";
- $comma = 1;
- }
- }
- push @o, "\n";
- return @o;
- }
- my %knownprotos = (
- 'DICT' => 1,
- 'FILE' => 1,
- 'FTP' => 1,
- 'FTPS' => 1,
- 'GOPHER' => 1,
- 'GOPHERS' => 1,
- 'HTTP' => 1,
- 'HTTPS' => 1,
- 'IMAP' => 1,
- 'IMAPS' => 1,
- 'LDAP' => 1,
- 'LDAPS' => 1,
- 'MQTT' => 1,
- 'POP3' => 1,
- 'POP3S' => 1,
- 'RTMP' => 1,
- 'RTMPS' => 1,
- 'RTSP' => 1,
- 'SCP' => 1,
- 'SFTP' => 1,
- 'SMB' => 1,
- 'SMBS' => 1,
- 'SMTP' => 1,
- 'SMTPS' => 1,
- 'TELNET' => 1,
- 'TFTP' => 1,
- 'WS' => 1,
- 'WSS' => 1,
- 'TLS' => 1,
- 'TCP' => 1,
- 'QUIC' => 1,
- 'All' => 1
- );
- my %knowntls = (
- 'BearSSL' => 1,
- 'GnuTLS' => 1,
- 'mbedTLS' => 1,
- 'OpenSSL' => 1,
- 'rustls' => 1,
- 'Schannel' => 1,
- 'Secure Transport' => 1,
- 'wolfSSL' => 1,
- 'All' => 1,
- );
- sub single {
- my @seealso;
- my @proto;
- my @tls;
- my $d;
- my ($f)=@_;
- my $copyright;
- my $errors = 0;
- my $fh;
- my $line;
- my $list;
- my $tlslist;
- my $section;
- my $source;
- my $addedin;
- my $spdx;
- my $start = 0;
- my $title;
- if(defined($f)) {
- if(!open($fh, "<:crlf", "$f")) {
- print STDERR "cd2nroff failed to open '$f' for reading: $!\n";
- return 1;
- }
- }
- else {
- $f = "STDIN";
- $fh = \*STDIN;
- binmode($fh, ":crlf");
- }
- while(<$fh>) {
- $line++;
- if(!$start) {
- if(/^---/) {
- # header starts here
- $start = 1;
- }
- next;
- }
- if(/^Title: *(.*)/i) {
- $title=$1;
- }
- elsif(/^Section: *(.*)/i) {
- $section=$1;
- }
- elsif(/^Source: *(.*)/i) {
- $source=$1;
- }
- elsif(/^See-also: +(.*)/i) {
- $list = 1; # 1 for see-also
- push @seealso, $1;
- }
- elsif(/^See-also: */i) {
- if($seealso[0]) {
- print STDERR "$f:$line:1:ERROR: bad See-Also, needs list\n";
- return 2;
- }
- $list = 1; # 1 for see-also
- }
- elsif(/^Protocol:/i) {
- $list = 2; # 2 for protocol
- }
- elsif(/^TLS-backend:/i) {
- $list = 3; # 3 for TLS backend
- }
- elsif(/^Added-in: *(.*)/i) {
- $addedin=$1;
- if(($addedin !~ /^[0-9.]+[0-9]\z/) &&
- ($addedin ne "n/a")) {
- print STDERR "$f:$line:1:ERROR: invalid version number in Added-in line: $addedin\n";
- return 2;
- }
- }
- elsif(/^ +- (.*)/i) {
- # the only lists we support are see-also and protocol
- if($list == 1) {
- push @seealso, $1;
- }
- elsif($list == 2) {
- push @proto, $1;
- }
- elsif($list == 3) {
- push @tls, $1;
- }
- else {
- print STDERR "$f:$line:1:ERROR: list item without owner?\n";
- return 2;
- }
- }
- # REUSE-IgnoreStart
- elsif(/^C: (.*)/i) {
- $copyright=$1;
- }
- elsif(/^SPDX-License-Identifier: (.*)/i) {
- $spdx=$1;
- }
- # REUSE-IgnoreEnd
- elsif(/^---/) {
- # end of the header section
- if(!$title) {
- print STDERR "$f:$line:1:ERROR: no 'Title:' in $f\n";
- return 1;
- }
- if(!$section) {
- print STDERR "$f:$line:1:ERROR: no 'Section:' in $f\n";
- return 2;
- }
- if(!$source) {
- print STDERR "$f:$line:1:ERROR: no 'Source:' in $f\n";
- return 2;
- }
- if(($source eq "libcurl") && !$addedin) {
- print STDERR "$f:$line:1:ERROR: no 'Added-in:' in $f\n";
- return 2;
- }
- if(!$seealso[0]) {
- print STDERR "$f:$line:1:ERROR: no 'See-also:' present\n";
- return 2;
- }
- if(!$copyright) {
- print STDERR "$f:$line:1:ERROR: no 'C:' field present\n";
- return 2;
- }
- if(!$spdx) {
- print STDERR "$f:$line:1:ERROR: no 'SPDX-License-Identifier:' field present\n";
- return 2;
- }
- if($section == 3) {
- if(!$proto[0]) {
- printf STDERR "$f:$line:1:ERROR: missing Protocol:\n";
- exit 2;
- }
- my $tls = 0;
- for my $p (@proto) {
- if($p eq "TLS") {
- $tls = 1;
- }
- if(!$knownprotos{$p}) {
- printf STDERR "$f:$line:1:ERROR: invalid protocol used: $p:\n";
- exit 2;
- }
- }
- # This is for TLS, require TLS-backend:
- if($tls) {
- if(!$tls[0]) {
- printf STDERR "$f:$line:1:ERROR: missing TLS-backend:\n";
- exit 2;
- }
- for my $t (@tls) {
- if(!$knowntls{$t}) {
- printf STDERR "$f:$line:1:ERROR: invalid TLS backend: $t:\n";
- exit 2;
- }
- }
- }
- }
- last;
- }
- else {
- chomp;
- print STDERR "$f:$line:1:ERROR: unrecognized header keyword: '$_'\n";
- $errors++;
- }
- }
- if(!$start) {
- print STDERR "$f:$line:1:ERROR: no header present\n";
- return 2;
- }
- my @desc;
- my $quote = 0;
- my $blankline = 0;
- my $header = 0;
- # cut off the leading path from the file name, if any
- $f =~ s/^(.*[\\\/])//;
- push @desc, ".\\\" generated by cd2nroff $cd2nroff from $f\n";
- push @desc, ".TH $title $section \"$date\" $source\n";
- while(<$fh>) {
- $line++;
- $d = $_;
- if($quote) {
- if($quote == 4) {
- # remove the indentation
- if($d =~ /^ (.*)/) {
- push @desc, "$1\n";
- next;
- }
- else {
- # end of quote
- $quote = 0;
- push @desc, ".fi\n";
- next;
- }
- }
- if(/^~~~/) {
- # end of quote
- $quote = 0;
- push @desc, ".fi\n";
- next;
- }
- # convert single backslahes to doubles
- $d =~ s/\\/\\\\/g;
- # lines starting with a period needs it escaped
- $d =~ s/^\./\\&./;
- push @desc, $d;
- next;
- }
- # remove single line HTML comments
- $d =~ s/<!--.*?-->//g;
- # **bold**
- $d =~ s/\*\*(\S.*?)\*\*/\\fB$1\\fP/g;
- # *italics*
- $d =~ s/\*(\S.*?)\*/\\fI$1\\fP/g;
- if($d =~ /[^\\][\<\>]/) {
- print STDERR "$f:$line:1:ERROR: un-escaped < or > used\n";
- $errors++;
- }
- # convert backslash-'<' or '> to just the second character
- $d =~ s/\\([<>])/$1/g;
- # mentions of curl symbols with manpages use italics by default
- $d =~ s/((lib|)curl([^ ]*\(3\)))/\\fI$1\\fP/gi;
- # backticked becomes italics
- $d =~ s/\`(.*?)\`/\\fI$1\\fP/g;
- if(/^## (.*)/) {
- my $word = $1;
- # if there are enclosing quotes, remove them first
- $word =~ s/[\"\'\`](.*)[\"\'\`]\z/$1/;
- # enclose in double quotes if there is a space present
- if($word =~ / /) {
- push @desc, ".IP \"$word\"\n";
- }
- else {
- push @desc, ".IP $word\n";
- }
- $header = 1;
- }
- elsif(/^##/) {
- # end of IP sequence
- push @desc, ".PP\n";
- $header = 1;
- }
- elsif(/^# (.*)/) {
- my $word = $1;
- # if there are enclosing quotes, remove them first
- $word =~ s/[\"\'](.*)[\"\']\z/$1/;
- if($word eq "PROTOCOLS") {
- print STDERR "$f:$line:1:WARN: PROTOCOLS section in source file\n";
- }
- elsif($word eq "AVAILABILITY") {
- print STDERR "$f:$line:1:WARN: AVAILABILITY section in source file\n";
- }
- elsif($word eq "%PROTOCOLS%") {
- # insert the generated PROTOCOLS section
- push @desc, outprotocols(@proto);
- if($proto[0] eq "TLS") {
- push @desc, outtls(@tls);
- }
- $header = 1;
- next;
- }
- elsif($word eq "%AVAILABILITY%") {
- if($addedin ne "n/a") {
- # insert the generated AVAILABILITY section
- push @desc, ".SH AVAILABILITY\n";
- push @desc, "Added in curl $addedin\n";
- }
- $header = 1;
- next;
- }
- push @desc, ".SH $word\n";
- $header = 1;
- }
- elsif(/^~~~c/) {
- # start of a code section, not indented
- $quote = 1;
- push @desc, "\n" if($blankline && !$header);
- $header = 0;
- push @desc, ".nf\n";
- }
- elsif(/^~~~/) {
- # start of a quote section; not code, not indented
- $quote = 1;
- push @desc, "\n" if($blankline && !$header);
- $header = 0;
- push @desc, ".nf\n";
- }
- elsif(/^ (.*)/) {
- # quoted, indented by 4 space
- $quote = 4;
- push @desc, "\n" if($blankline && !$header);
- $header = 0;
- push @desc, ".nf\n$1\n";
- }
- elsif(/^[ \t]*\n/) {
- # count and ignore blank lines
- $blankline++;
- }
- else {
- # don't output newlines if this is the first content after a
- # header
- push @desc, "\n" if($blankline && !$header);
- $blankline = 0;
- $header = 0;
- # quote minuses in the output
- $d =~ s/([^\\])-/$1\\-/g;
- # replace single quotes
- $d =~ s/\'/\\(aq/g;
- # handle double quotes first on the line
- $d =~ s/^(\s*)\"/$1\\&\"/;
- # lines starting with a period needs it escaped
- $d =~ s/^\./\\&./;
- if($d =~ /^(.*) /) {
- printf STDERR "$f:$line:%d:ERROR: 2 spaces detected\n",
- length($1);
- $errors++;
- }
- if($d =~ /^[ \t]*\n/) {
- # replaced away all contents
- $blankline= 1;
- }
- else {
- push @desc, $d;
- }
- }
- }
- if($fh != \*STDIN) {
- close($fh);
- }
- push @desc, outseealso(@seealso);
- if($dir) {
- if($keepfilename) {
- $title = $f;
- $title =~ s/\.[^.]*$//;
- }
- my $outfile = "$dir/$title.$section";
- if(defined($extension)) {
- $outfile .= $extension;
- }
- if(!open(O, ">", $outfile)) {
- print STDERR "Failed to open $outfile : $!\n";
- return 1;
- }
- print O @desc;
- close(O);
- }
- else {
- print @desc;
- }
- return $errors;
- }
- if(@ARGV) {
- for my $f (@ARGV) {
- my $r = single($f);
- if($r) {
- exit $r;
- }
- }
- }
- else {
- exit single();
- }
|