| #!/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 (man page). |
| |
| =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, "All TLS based protocols: HTTPS, FTPS, IMAPS, POP3S, SMTPS etc."; |
| } |
| else { |
| my @s = sort @p; |
| for my $e (sort @s) { |
| push @o, sprintf "%s$e", |
| $comma ? (($e eq $s[-1]) ? " and " : ", "): ""; |
| $comma = 1; |
| } |
| } |
| 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, |
| '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 $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(/^ +- (.*)/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 "ERROR: no 'Title:' in $f\n"; |
| return 1; |
| } |
| if(!$section) { |
| print STDERR "ERROR: no 'Section:' 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 "WARN: unrecognized line in $f, ignoring:\n:'$_';" |
| } |
| } |
| |
| 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:WARN: un-escaped < or > used\n"; |
| } |
| # convert backslash-'<' or '> to just the second character |
| $d =~ s/\\([<>])/$1/g; |
| |
| # mentions of curl symbols with man pages 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(/^# (.*)/) { |
| 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 "EXAMPLE") { |
| # insert the generated PROTOCOLS section before EXAMPLE |
| push @desc, outprotocols(@proto); |
| |
| if($proto[0] eq "TLS") { |
| push @desc, outtls(@tls); |
| } |
| } |
| 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(); |
| } |
