73 lines
2.2 KiB
Perl
73 lines
2.2 KiB
Perl
package ManUtils 0.2;
|
|
|
|
use v5.36;
|
|
use IPC::Open3;
|
|
use IO::Poll qw/POLLOUT POLLIN/;
|
|
use Symbol 'gensym';
|
|
use XSLoader;
|
|
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
|
|
XSLoader::load('ManUtils');
|
|
|
|
sub fmt($input) {
|
|
my @cmd = 'groff';
|
|
push @cmd, '-t' if $input =~ /^\.TS/m;
|
|
push @cmd, '-e' if $input =~ /^\.EQ/m;
|
|
# $MANWIDTH works by using the following groff options: -rLL=100n -rLT=100n
|
|
push @cmd, qw/-mandoc -Tutf8 -DUTF-8 -P-c -rLL=80n -rLT=80n -/;
|
|
|
|
$input =
|
|
# Disable hyphenation, since that screws up man page references. :-(
|
|
".hy 0\n.de hy\n..\n"
|
|
# Emulate man-db's --nj option
|
|
.".na\n.de ad\n..\n"
|
|
# Unbreak some quotes, there's plenty of man pages that ("incorrectly") use these for code samples.
|
|
.".char ` \\`\n"
|
|
.".char ' \\[aq]\n"
|
|
.$input;
|
|
utf8::encode($input);
|
|
|
|
my $pid = open3(my $in, my $out, my $err = gensym, @cmd);
|
|
|
|
# "POLLOUT" does NOT guarantee that a write will not block, we must set
|
|
# O_NONBLOCK to tell the kernel that we can handle short writes.
|
|
fcntl($in, F_SETFL, fcntl($in, F_GETFL, 0) | O_NONBLOCK);
|
|
|
|
my $inoff = 0;
|
|
my $output = '';
|
|
my $poll = IO::Poll->new;
|
|
$poll->mask($in => POLLOUT);
|
|
$poll->mask($out => POLLIN);
|
|
$poll->mask($err => POLLIN);
|
|
while (1) {
|
|
$poll->poll;
|
|
|
|
if ($poll->events($in)) {
|
|
my $r = syswrite $in, $input, 16*1024, $inoff;
|
|
die "Write error: $!\n" if $r <= 0;
|
|
$inoff += $r;
|
|
if ($inoff == length $input) {
|
|
$poll->remove($in);
|
|
close $in;
|
|
}
|
|
}
|
|
|
|
if ($poll->events($out)) {
|
|
my $r = sysread $out, $output, 16*1024, length $output;
|
|
die "Read error: $!\n" if $r < 0;
|
|
if ($r == 0) {
|
|
utf8::decode($output);
|
|
waitpid $pid, 0;
|
|
die "Groff exited with $?\n" if $?;
|
|
return $output =~ s/\s+$//r;
|
|
}
|
|
}
|
|
|
|
if ($poll->events($err)) {
|
|
my $r = sysread $err, my $buf, 16*1024;
|
|
$poll->remove($err) if $r == 0;
|
|
#warn "GROFF: $buf\n" if $r > 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
1;
|