3 ## Mdoc.pm -- Perl functions for mdoc processing
5 ## Author: Oliver Kindernay (GSoC project for NTP.org)
8 ## This file is part of AutoOpts, a companion to AutoGen.
9 ## AutoOpts is free software.
10 ## AutoOpts is Copyright (C) 1992-2015 by Bruce Korb - all rights reserved
12 ## AutoOpts is available under any one of two licenses. The license
13 ## in use must be one of these two and the choice is under the control
14 ## of the user of the license.
16 ## The GNU Lesser General Public License, version 3 or later
17 ## See the files "COPYING.lgplv3" and "COPYING.gplv3"
19 ## The Modified Berkeley Software Distribution License
20 ## See the file "COPYING.mbsd"
22 ## These files have the following sha256 sums:
24 ## 8584710e9b04216a394078dc156b781d0b47e1729104d666658aecef8ee32e95 COPYING.gplv3
25 ## 4379e7444a0e2ce2b12dd6f5a52a27a4d02d39d247901d3285c88cf0d37f477b COPYING.lgplv3
26 ## 13aa749a5b0a454917a944ed8fffc530b784f5ead522b1aacaf4ec8aa55a6239 COPYING.mbsd
30 Mdoc - perl module to parse Mdoc macros
34 use Mdoc qw(ns pp soff son stoggle mapwords);
36 See mdoc2man and mdoc2texi for code examples.
42 =item def_macro( NAME, CODE, [ raw => 1, greedy => 1, concat_until => '.Xx' ] )
44 Define new macro. The CODE reference will be called by call_macro(). You can
45 have two distinct definitions for and inline macro and for a standalone macro
46 (i. e. 'Pa' and '.Pa').
48 The CODE reference is passed a list of arguments and is expected to return list
49 of strings and control characters (see C<CONSTANTS>).
51 By default the surrouding "" from arguments to macros are removed, use C<raw>
54 Normaly CODE reference is passed all arguments up to next nested macro. Set
55 C<greedy> to to pass everything up to the end of the line.
57 If the concat_until is present, the line is concated until the .Xx macro is
58 found. For example the following macro definition
60 def_macro('.Oo', gen_encloser(qw([ ]), concat_until => '.Oc' }
61 def_macro('.Cm', sub { mapwords {'($_)'} @_ } }
63 and the following input
70 results in [(foo) | (bar)]
72 =item get_macro( NAME )
74 Returns a hash reference like:
76 { run => CODE, raw => [1|0], greedy => [1|0] }
78 Where C<CODE> is the CODE reference used to define macro called C<NAME>
80 =item parse_line( INPUT, OUTPUT_CODE, PREPROCESS_CODE )
82 Parse a line from the C<INPUT> filehandle. If a macro was detected it returns a
83 list (MACRO_NAME, @MACRO_ARGS), otherwise it calls the C<OUTPUT_CODE>, giving
84 caller a chance to modify line before printing it. If C<PREPROCESS_CODE> is
85 defined it calls it prior to passing argument to a macro, giving caller a
86 chance to alter them. if EOF was reached undef is returned.
88 =item call_macro( MACRO, ARGS, ... )
90 Call macro C<MACRO> with C<ARGS>. The CODE reference for macro C<MACRO> is
91 called and for all the nested macros. Every called macro returns a list which
92 is appended to return value and returned when all nested macros are processed.
93 Use to_string() to produce a printable string from the list.
95 =item to_string ( LIST )
97 Processes C<LIST> returned from call_macro() and returns formatted string.
99 =item mapwords BLOCK ARRAY
101 This is like perl's map only it calls BLOCK only on elements which are not
102 punctuation or control characters.
104 =item space ( ['on'|'off] )
106 Turn spacing on or off. If called without argument it returns the current state.
108 =item gen_encloser ( START, END )
110 Helper function for generating macros that enclose their arguments.
111 gen_encloser(qw({ }));
113 sub { '{', ns, @_, ns, pp('}')}
115 =item set_Bl_callback( CODE , DEFS )
117 This module implements the Bl/El macros for you. Using set_Bl_callback you can
118 provide a macro definition that should be executed on a .Bl call.
120 =item set_El_callback( CODE , DEFS )
122 This module implements the Bl/El macros for you. Using set_El_callback you can
123 provide a macro definition that should be executed on a .El call.
125 =item set_Re_callback( CODE )
127 The C<CODE> is called after a Rs/Re block is done. With a hash reference as a
128 parameter, describing the reference.
138 Indicate 'no space' between to members of the list.
142 The string is 'punctuation point'. It means that every punctuation
143 preceeding that element is put behind it.
159 Print space no matter spacing mode.
165 * The concat_until only works with standalone macros. This means that
167 will hang until .Pc in encountered.
169 * Provide default macros for Bd/Ed
171 * The reference implementation is uncomplete
178 use List::Util qw(reduce);
179 use Text::ParseWords qw(quotewords);
181 use Exporter qw(import);
182 our @EXPORT_OK = qw(ns pp soff son stoggle hs mapwords gen_encloser nl);
186 soff => ['spaceoff'],
188 stoggle => ['spacetoggle'],
198 return sub { ($o, ns, @_, ns, pp($c)) };
206 push @res, $el =~ /^(?:[,\.\{\}\(\):;\[\]\|])$/ || ref $el eq 'ARRAY' ?
214 ###############################################################################
216 # Default macro definitions start
218 ###############################################################################
220 def_macro('Xo', sub { @_ }, concat_until => '.Xc');
222 def_macro('.Ns', sub {ns, @_});
223 def_macro('Ns', sub {ns, @_});
227 def_macro('.Rs', sub { () } );
228 def_macro('.%A', sub {
229 if ($reference{authors}) {
230 $reference{authors} .= " and @_"
233 $reference{authors} = "@_";
237 def_macro('.%T', sub { $reference{title} = "@_"; () } );
238 def_macro('.%O', sub { $reference{optional} = "@_"; () } );
240 sub set_Re_callback {
242 croak 'Not a CODE reference' if not ref $sub eq 'CODE';
243 def_macro('.Re', sub {
244 my @ret = $sub->(\%reference);
245 %reference = (); @ret
251 def_macro('.Bl', sub { die '.Bl - no list callback set' });
252 def_macro('.It', sub { die ".It called outside of list context - maybe near line $." });
253 def_macro('.El', sub { die '.El requires .Bl first' });
257 my $elcb = sub { () };
259 sub set_El_callback {
261 croak 'Not a CODE reference' if ref $sub ne 'CODE';
266 sub set_Bl_callback {
267 my ($blcb, %defs) = @_;
268 croak 'Not a CODE reference' if ref $blcb ne 'CODE';
269 def_macro('.Bl', sub {
271 my $orig_it = get_macro('.It');
272 my $orig_el = get_macro('.El');
273 my $orig_bl = get_macro('.Bl');
274 my $orig_elcb = $elcb;
276 # Restore previous .It and .El on each .El
277 def_macro('.El', sub {
278 def_macro('.El', delete $orig_el->{run}, %$orig_el);
279 def_macro('.It', delete $orig_it->{run}, %$orig_it);
280 def_macro('.Bl', delete $orig_bl->{run}, %$orig_bl);
281 my @ret = $elcb->(@_);
291 def_macro('.Sm', sub {
302 def_macro('Sm', do { my $off; sub {
304 if (defined $arg && $arg =~ /^(on|off)$/) {
306 if ($arg eq 'off') { soff, @_; }
307 elsif ($arg eq 'on') { son, @_; }
314 ###############################################################################
316 # Default macro definitions end
318 ###############################################################################
321 croak 'Odd number of elements for hash argument <'.(scalar @_).'>' if @_%2;
322 my ($macro, $sub, %def) = @_;
323 croak 'Not a CODE reference' if ref $sub ne 'CODE';
325 $macros{ $macro } = {
327 greedy => delete $def{greedy} || 0,
328 raw => delete $def{raw} || 0,
329 concat_until => delete $def{concat_until},
331 if ($macros{ $macro }{concat_until}) {
332 $macros{ $macros{ $macro }{concat_until} } = { run => sub { @_ } };
333 $macros{ $macro }{greedy} = 1;
340 croak "Macro <$macro> not defined" if not exists $macros{ $macro };
341 +{ %{ $macros{ $macro } } }
352 $last = _unquote($_);
355 $args{$last} = _unquote($_) if $last;
363 my ($el, $expected) = @_;
364 if (defined $expected) {
365 ref $el eq 'ARRAY' and $el->[0] eq $expected;
377 # Handle punctunation
378 my ($in_brace, @punct) = '';
381 ($in_brace = $1) =~ tr/([/)]/;
384 elsif (/^([\)\]])$/ && $in_brace eq $1) {
388 elsif ($_ =~ /^[,\.;:\?\!\)\]]$/) {
392 elsif (_is_control($_, 'pp')) {
395 elsif (_is_control($_)) {
404 # Produce string out of an array dealing with the special control characters
405 # space('off') must but one character delayed
406 my ($no_space, $space_off) = 1;
408 while (defined(my $el = shift @new)) {
409 if (_is_control($el, 'hardspace')) { $no_space = 1; $res .= ' ' }
410 elsif (_is_control($el, 'nospace')) { $no_space = 1; }
411 elsif (_is_control($el, 'spaceoff')) { $space_off = 1; }
412 elsif (_is_control($el, 'spaceon')) { space('on'); }
413 elsif (_is_control($el, 'spacetoggle')) { space() eq 'on' ?
425 if ($space_off) { space('off'); $space_off = 0; }
437 if (defined $arg && $arg =~ /^(on|off)$/) {
438 $sep = ' ' if $arg eq 'on';
439 $sep = '' if $arg eq 'off';
443 return $sep eq '' ? 'off' : 'on';
450 $_ =~ s/^"([^"]+)"$/$1/g for @args;
451 wantarray ? @args : $args[0];
455 my ($macro, @args) = @_;
461 @args = _unquote(@args) if (!$macros{ $macro }{raw});
463 # Call any callable macros in the argument list
465 if ($_ =~ /^[A-Z][a-z]+$/ && exists $macros{ $_ }) {
466 push @ret, call_macro($_, @args[$i+1 .. $#args]);
469 if ($macros{ $macro }{greedy}) {
479 if ($macros{ $macro }{concat_until}) {
480 my ($n_macro, @n_args) = ('');
482 die "EOF was reached and no $macros{ $macro }{concat_until} found"
483 if not defined $n_macro;
484 ($n_macro, @n_args) = parse_line(undef, sub { push @ret, shift });
485 if ($n_macro eq $macros{ $macro }{concat_until}) {
486 push @ret, call_macro($n_macro, @n_args);
491 push @ret, call_macro($n_macro, @n_args) if exists $macros{ $n_macro };
496 if ($macros{ $macro }{greedy}) {
497 #print "MACROG $macro (", (join ', ', @ret), ")\n";
498 return $macros{ $macro }{run}->(@ret);
501 #print "MACRO $macro (", (join ', ', @newargs), ")".(join ', ', @ret)."\n";
502 return $macros{ $macro }{run}->(@newargs), @ret;
507 my ($in_fh, $out_sub, $preprocess_sub);
509 $in_fh = $_[0] if defined $_[0] || !defined $in_fh;
510 $out_sub = $_[1] if defined $_[1] || !defined $out_sub;
511 $preprocess_sub = $_[2] if defined $_[2] || !defined $preprocess_sub;
513 croak 'out_sub not a CODE reference'
514 if not ref $out_sub eq 'CODE';
515 croak 'preprocess_sub not a CODE reference'
516 if defined $preprocess_sub && not ref $preprocess_sub eq 'CODE';
518 while (my $line = <$in_fh>) {
520 if ($line =~ /^\.[A-z][a-z0-9]+/ || $line =~ /^\.%[A-Z]/ ||
524 my ($macro, @args) = quotewords(' ', 1, $line);
525 @args = grep { defined $_ } @args;
526 $preprocess_sub->(@args) if defined $preprocess_sub;
527 if ($macro && exists $macros{ $macro }) {
528 return ($macro, @args);