contrib/ntp/sntp/ag-tpl/Mdoc.pm

   1 =begin comment
   2
   3 ## Mdoc.pm -- Perl functions for mdoc processing
   4 ##
   5 ## Author:      Oliver Kindernay (GSoC project for NTP.org)
   6 ##
   7 ##
   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
  11 ##
  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.
  15 ##
  16 ##   The GNU Lesser General Public License, version 3 or later
  17 ##      See the files "COPYING.lgplv3" and "COPYING.gplv3"
  18 ##
  19 ##   The Modified Berkeley Software Distribution License
  20 ##      See the file "COPYING.mbsd"
  21 ##
  22 ##  These files have the following sha256 sums:
  23 ##
  24 ##  8584710e9b04216a394078dc156b781d0b47e1729104d666658aecef8ee32e95  COPYING.gplv3
  25 ##  4379e7444a0e2ce2b12dd6f5a52a27a4d02d39d247901d3285c88cf0d37f477b  COPYING.lgplv3
  26 ##  13aa749a5b0a454917a944ed8fffc530b784f5ead522b1aacaf4ec8aa55a6239  COPYING.mbsd
  27 =end comment
  28 =head1 NAME
  29
  30 Mdoc - perl module to parse Mdoc macros
  31
  32 =head1 SYNOPSIS
  33
  34     use Mdoc qw(ns pp soff son stoggle mapwords);
  35
  36 See mdoc2man and mdoc2texi for code examples.
  37
  38 =head1 FUNCTIONS
  39
  40 =over 4
  41
  42 =item def_macro( NAME, CODE, [ raw => 1, greedy => 1, concat_until => '.Xx' ] )
  43
  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').
  47
  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>).
  50
  51 By default the surrouding "" from arguments to macros are removed, use C<raw>
  52 to disable this.
  53
  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.
  56
  57 If the concat_until is present, the line is concated until the .Xx macro is
  58 found. For example the following macro definition
  59
  60     def_macro('.Oo', gen_encloser(qw([ ]), concat_until => '.Oc' }
  61     def_macro('.Cm', sub { mapwords {'($_)'} @_ } }
  62
  63 and the following input
  64
  65     .Oo
  66     .Cm foo |
  67     .Cm bar |
  68     .Oc
  69
  70 results in [(foo) | (bar)]
  71
  72 =item get_macro( NAME )
  73
  74 Returns a hash reference like:
  75
  76     { run => CODE, raw => [1|0], greedy => [1|0] }
  77
  78 Where C<CODE> is the CODE reference used to define macro called C<NAME>
  79
  80 =item parse_line( INPUT, OUTPUT_CODE, PREPROCESS_CODE )
  81
  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.
  87
  88 =item call_macro( MACRO, ARGS, ... )
  89
  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.
  94
  95 =item to_string ( LIST )
  96
  97 Processes C<LIST> returned from call_macro() and returns formatted string.
  98
  99 =item mapwords BLOCK ARRAY
 100
 101 This is like perl's map only it calls BLOCK only on elements which are not
 102 punctuation or control characters.
 103
 104 =item space ( ['on'|'off] )
 105
 106 Turn spacing on or off. If called without argument it returns the current state.
 107
 108 =item gen_encloser ( START, END )
 109
 110 Helper function for generating macros that enclose their arguments.
 111     gen_encloser(qw({ }));
 112 returns
 113     sub { '{', ns, @_, ns, pp('}')}
 114
 115 =item set_Bl_callback( CODE , DEFS )
 116
 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.
 119
 120 =item set_El_callback( CODE , DEFS )
 121
 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.
 124
 125 =item set_Re_callback( CODE )
 126
 127 The C<CODE> is called after a Rs/Re block is done. With a hash reference as a
 128 parameter, describing the reference.
 129
 130 =back
 131
 132 =head1 CONSTANTS
 133
 134 =over 4
 135
 136 =item ns
 137
 138 Indicate 'no space' between to members of the list.
 139
 140 =item pp ( STRING )
 141
 142 The string is 'punctuation point'. It means that every punctuation
 143 preceeding that element is put behind it.
 144
 145 =item soff
 146
 147 Turn spacing off.
 148
 149 =item son
 150
 151 Turn spacing on.
 152
 153 =item stoggle
 154
 155 Toogle spacing.
 156
 157 =item hs
 158
 159 Print space no matter spacing mode.
 160
 161 =back
 162
 163 =head1 TODO
 164
 165 * The concat_until only works with standalone macros. This means that
 166     .Po blah Pc
 167 will hang until .Pc in encountered.
 168
 169 * Provide default macros for Bd/Ed
 170
 171 * The reference implementation is uncomplete
 172
 173 =cut
 174
 175 package Mdoc;
 176 use strict;
 177 use warnings;
 178 use List::Util qw(reduce);
 179 use Text::ParseWords qw(quotewords);
 180 use Carp;
 181 use Exporter qw(import);
 182 our @EXPORT_OK = qw(ns pp soff son stoggle hs mapwords gen_encloser nl);
 183
 184 use constant {
 185     ns      => ['nospace'],
 186     soff    => ['spaceoff'],
 187     son     => ['spaceon'],
 188     stoggle => ['spacetoggle'],
 189     hs      => ['hardspace'],
 190 };
 191
 192 sub pp {
 193     my $c = shift;
 194     return ['pp', $c ];
 195 }
 196 sub gen_encloser {
 197     my ($o, $c) = @_;
 198     return sub { ($o, ns, @_, ns, pp($c)) };
 199 }
 200
 201 sub mapwords(&@) {
 202     my ($f, @l) = @_;
 203     my @res;
 204     for my $el (@l) {
 205         local $_ = $el;
 206         push @res, $el =~ /^(?:[,\.\{\}\(\):;\[\]\|])$/ || ref $el eq 'ARRAY' ?
 207                     $el : $f->();
 208     }
 209     return @res;
 210 }
 211
 212 my %macros;
 213
 214 ###############################################################################
 215
 216 # Default macro definitions start
 217
 218 ###############################################################################
 219
 220 def_macro('Xo',  sub { @_ }, concat_until => '.Xc');
 221
 222 def_macro('.Ns', sub {ns, @_});
 223 def_macro('Ns',  sub {ns, @_});
 224
 225 {
 226     my %reference;
 227     def_macro('.Rs', sub { () } );
 228     def_macro('.%A', sub {
 229         if ($reference{authors}) {
 230             $reference{authors} .= " and @_"
 231         }
 232         else {
 233             $reference{authors} = "@_";
 234         }
 235         return ();
 236     });
 237     def_macro('.%T', sub { $reference{title} = "@_"; () } );
 238     def_macro('.%O', sub { $reference{optional} = "@_"; () } );
 239
 240     sub set_Re_callback {
 241         my ($sub) = @_;
 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
 246         });
 247         return;
 248     }
 249 }
 250
 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' });
 254
 255
 256 {
 257     my $elcb = sub { () };
 258
 259     sub set_El_callback {
 260         my ($sub) = @_;
 261         croak 'Not a CODE reference' if ref $sub ne 'CODE';
 262         $elcb = $sub;
 263         return;
 264     }
 265
 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 {
 270
 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;
 275
 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->(@_);
 282                     $elcb = $orig_elcb;
 283                     @ret
 284                 });
 285             $blcb->(@_)
 286         }, %defs);
 287         return;
 288     }
 289 }
 290
 291 def_macro('.Sm', sub {
 292     my ($arg) = @_;
 293     if (defined $arg) {
 294         space($arg);
 295     } else {
 296         space() eq 'off' ?
 297             space('on') :
 298             space('off');
 299     }
 300     ()
 301 } );
 302 def_macro('Sm', do { my $off; sub {
 303     my ($arg) = @_;
 304     if (defined $arg && $arg =~ /^(on|off)$/) {
 305         shift;
 306         if    ($arg eq 'off') { soff, @_; }
 307         elsif ($arg eq 'on')  { son, @_; }
 308     }
 309     else {
 310         stoggle, @_;
 311     }
 312 }} );
 313
 314 ###############################################################################
 315
 316 # Default macro definitions end
 317
 318 ###############################################################################
 319
 320 sub def_macro {
 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';
 324
 325     $macros{ $macro } = {
 326         run          => $sub,
 327         greedy       => delete $def{greedy} || 0,
 328         raw          => delete $def{raw}    || 0,
 329         concat_until => delete $def{concat_until},
 330     };
 331     if ($macros{ $macro }{concat_until}) {
 332         $macros{ $macros{ $macro }{concat_until} } = { run => sub { @_ } };
 333         $macros{ $macro }{greedy}                  = 1;
 334     }
 335     return;
 336 }
 337
 338 sub get_macro {
 339     my ($macro) = @_;
 340     croak "Macro <$macro> not defined" if not exists $macros{ $macro };
 341     +{ %{ $macros{ $macro } } }
 342 }
 343
 344 #TODO: document this
 345 sub parse_opts {
 346     my %args;
 347     my $last;
 348     for (@_) {
 349         if ($_ =~ /^\\?-/) {
 350             s/^\\?-//;
 351             $args{$_} = 1;
 352             $last = _unquote($_);
 353         }
 354         else {
 355             $args{$last} = _unquote($_) if $last;
 356             undef $last;
 357         }
 358     }
 359     return %args;
 360 }
 361
 362 sub _is_control {
 363     my ($el, $expected) = @_;
 364     if (defined $expected) {
 365         ref $el eq 'ARRAY' and $el->[0] eq $expected;
 366     }
 367     else {
 368         ref $el eq 'ARRAY';
 369     }
 370 }
 371
 372 {
 373     my $sep = ' ';
 374
 375     sub to_string {
 376         if (@_ > 0) {
 377             # Handle punctunation
 378             my ($in_brace, @punct) = '';
 379             my @new = map {
 380                 if (/^([\[\(])$/) {
 381                     ($in_brace = $1) =~ tr/([/)]/;
 382                     $_, ns
 383                 }
 384                 elsif (/^([\)\]])$/ && $in_brace eq $1) {
 385                     $in_brace = '';
 386                     ns, $_
 387                 }
 388                 elsif ($_ =~ /^[,\.;:\?\!\)\]]$/) {
 389                     push @punct, ns, $_;
 390                     ();
 391                 }
 392                 elsif (_is_control($_, 'pp')) {
 393                     $_->[1]
 394                 }
 395                 elsif (_is_control($_)) {
 396                     $_
 397                 }
 398                 else {
 399                     splice (@punct), $_;
 400                 }
 401             } @_;
 402             push @new, @punct;
 403
 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;
 407             my $res = '';
 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' ?
 414                                                             $space_off = 1 :
 415                                                             space('on')              }
 416                 else {
 417                     if ($no_space) {
 418                         $no_space = 0;
 419                         $res .= "$el"
 420                     }
 421                     else {
 422                         $res .= "$sep$el"
 423                     }
 424
 425                     if ($space_off)    { space('off'); $space_off = 0; }
 426                 }
 427             }
 428             $res
 429         }
 430         else {
 431             '';
 432         }
 433     }
 434
 435     sub space {
 436         my ($arg) = @_;
 437         if (defined $arg && $arg =~ /^(on|off)$/) {
 438             $sep = ' ' if $arg eq 'on';
 439             $sep = ''  if $arg eq 'off';
 440             return;
 441         }
 442         else {
 443             return $sep eq '' ? 'off' : 'on';
 444         }
 445     }
 446 }
 447
 448 sub _unquote {
 449     my @args = @_;
 450     $_ =~ s/^"([^"]+)"$/$1/g for @args;
 451     wantarray ? @args : $args[0];
 452 }
 453
 454 sub call_macro {
 455     my ($macro, @args) = @_;
 456     my @ret;
 457
 458     my @newargs;
 459     my $i = 0;
 460
 461     @args = _unquote(@args) if (!$macros{ $macro }{raw});
 462
 463     # Call any callable macros in the argument list
 464     for (@args) {
 465         if ($_ =~ /^[A-Z][a-z]+$/ && exists $macros{ $_ }) {
 466             push @ret, call_macro($_, @args[$i+1 .. $#args]);
 467             last;
 468         } else {
 469             if ($macros{ $macro }{greedy}) {
 470                 push @ret, $_;
 471             }
 472             else {
 473                 push @newargs, $_;
 474             }
 475         }
 476         $i++;
 477     }
 478
 479     if ($macros{ $macro }{concat_until}) {
 480         my ($n_macro, @n_args) = ('');
 481         while (1) {
 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);
 487                 last;
 488             }
 489             else {
 490                 $n_macro =~ s/^\.//;
 491                 push @ret, call_macro($n_macro, @n_args) if exists $macros{ $n_macro };
 492             }
 493         }
 494     }
 495
 496     if ($macros{ $macro }{greedy}) {
 497         #print "MACROG $macro (", (join ', ', @ret), ")\n";
 498         return $macros{ $macro }{run}->(@ret);
 499     }
 500     else {
 501         #print "MACRO $macro (", (join ', ', @newargs), ")".(join ', ', @ret)."\n";
 502         return $macros{ $macro }{run}->(@newargs), @ret;
 503     }
 504 }
 505
 506 {
 507     my ($in_fh, $out_sub, $preprocess_sub);
 508     sub parse_line {
 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;
 512
 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';
 517
 518         while (my $line = <$in_fh>) {
 519             chomp $line;
 520             if ($line =~ /^\.[A-z][a-z0-9]+/ || $line =~ /^\.%[A-Z]/ ||
 521                 $line =~ /^\.\\"/)
 522             {
 523                 $line =~ s/ +/ /g;
 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);
 529                 } else {
 530                     $out_sub->($line);
 531                 }
 532             }
 533             else {
 534                 $out_sub->($line);
 535             }
 536         }
 537         return;
 538     }
 539 }
 540
 541 1;
 542 __END__