#!/usr/bin/perl -w
use strict;
use File::Spec;
use Getopt::Std;
use Text::Balanced qw(extract_delimited extract_multiple);

my @results;
my %MANZ;
my %PATH= map {$_=>1} split(':', $ENV{PATH});
my %opt;
getopts('ahwC:M:S:', \%opt);
if( scalar @ARGV == 2 ){
  $opt{S} = [split(':', shift)];
}
if( $ARGV[0] eq '-' ){
  push(@results, $ARGV[0]);
  $ENV{MANPATH} = "0 but true";
}
else{
  $opt{M} = [split(':', $ENV{MANPATH})] if $ENV{MANPATH};
}
die("usage: man2pod [section] page\n") unless scalar @ARGV == 1;

open(CONF, '</etc/man.config') || warn("No system man configuration\n"
+);
while(<CONF>){
 $MANZ{$1} = $2 if /^\s*\.([^\s]+)\s+(.*)/;
 $opt{S} ||= [split(':', $1)] if /^\s*MANSECT\s+([^\s]*)/; 

 next unless ! $ENV{MANPATH} && /^\s*MANPATH(_MAP)?\s+([^\s]+)\s*(.*)/
+;
 if( $1 ){
   push(@{$opt{M}}, $3) if $PATH{$2} && ! grep {/^$3$/} @{$opt{M}};
 }
 else{
   push(@{$opt{M}}, $2);
 }
}
$opt{S} ||= [1,8,2,3,4,5,6,7,9,tcl=>n=>l=>p=>o=>];

if( File::Spec->file_name_is_absolute($ARGV[0]) ){
  push @results, shift;
}
else{
  my @manz = keys %MANZ;
 DIR: foreach my $dir ( @{$opt{M}} ){
    my $page;
  SEC: foreach my $sec (@{$opt{S}} ){
      #XXX File::Spec
      $page = "$dir/man$sec/$ARGV[0].$sec";
      if( -e $page ){
        push(@results, $page);
        last DIR unless $opt{a};
      }
      else{
        foreach my $manz ( @manz ){
          my $page .= "$page.$manz";
          next unless -e $page;
          #XXX next unless the decompressor exists
          push(@results, $page);
          last DIR unless $opt{a};
          next SEC;
        }
      }
    }
  }
}

foreach my $page ( @results ){
  if( $opt{w} ){
    print $page, "\n"; }
  else{
    &manify($page);
    #XXX something to reset/restart pager, probably just EOF
  }
}

sub manify{
  if( my @Z = grep { $_[0] =~ /\.$_$/ } keys %MANZ ){
    open(PAGE, "$MANZ{$Z[0]} $_[0]|")  || warn("$!: $Z[0] $_[0]\n") &&
+ return;
  }
  else{
    open(PAGE, "<$_[0]") || warn("$!: $_[0]\n") && return;
  }

  while(<PAGE>){
    next if /^\.IX/;

    if( 1 .. /^\.TH/ ){
      s/^(?!^\.TH)/#/ || ($_ .= "\n=pod\n\n");
    }

    #Sections
    s/^\.SH/\n=head1/ && s/$/\n/ && tr/"//d;
    s/^\.SS/\n=head2/ && s/$/\n/ && tr/"//d;

    #Inline styles
    s/\\f([BI])(.*?)\\f[PR]/$1<$2>/g;
    #Whole line styles
    s/^\.([BI])\s+(.*)/$1<$2>/ && s/(?<!\\)"//g;
    1 if s/^\.([BI])\s*$/$1</s ... s/$/>/;
    #Freaking alternating styles, loathe roff
    s/^\.SB/\.RB/; #we don't have small, maybe >text<?
    s/^\.SM/\.RR/; #cheat ;-)
    if( /^\.([BIR])([BIR])\s+(.+)/ ){
      #So the closing > is on the same line
      chomp();
      my($i, $alpha, $beta, $str) = (0, $1, $2, $3);
      #Split on spaces for alternating, but not spaces within double q
+uotes
      my @elem = map {
        /"/ ? tr/"//d && $_ : grep {$_ ne ''} split(/(?<!\\)\s+/) }
        extract_multiple($str, [ sub{ extract_delimited($_[0], '"') } 
+],undef);
      #Apply alternating styles
      $_ = join('', map { $i++ %2 ? RIB($beta, $_) :
                            RIB($alpha, $_) } @elem). "\n";
    }

    #Paragraphs
    s/^\.[LP]?P\b/\n\n/;
    #Lists, the .PD stuff is questionable :-/
    s/^\.PD\s*\d+\s*$/\n=over\n/;
    s/^\.PD\s*$/\n=back\n/;
    #XXX these are somewhat wrong, and IP needs to handle optional 2nd
+ arg
    1 if s/^\.TP\s*\d*\s*$/\n=item /s ... s/$/\n/;
    s/^\.I[pP]/\n=item /;

    #Characters
    s/\.br\b//;
    s/\\([-\s`'"])/$1/g;
    s/"\\\(bu/o/g;

    print;
  }
  print "\n=cut\n";
}

sub RIB{
  return $_[1] if $_[0] eq 'R';
  return "$_[0]<$_[1]>";
}
[download]