#!/usr/bin/perl

# my_pod2html -- convert POD to HTML, with some mangling

# Copyright 2009, 2010, 2011, 2013, 2016, 2017, 2018, 2019 Kevin Ryde

# my_pod2html is shared by several distributions.
#
# my_pod2html is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# my_pod2html is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
# more details.
#
# You should have received a copy of the GNU General Public License along
# with this file.  If not, see <http://www.gnu.org/licenses/>.

use strict;
use warnings;
use FindBin;

# uncomment this to run the ### lines
# use Smart::Comments;

my $local_links = 0;
my $local_dir = '';
if (@ARGV && $ARGV[0] =~ /--local(=(.*))?/) {
  $local_links = 1;
  $local_dir = $2;
  shift @ARGV;
}
my $local_pagename = 'manpage.html';
if (@ARGV && $ARGV[0] =~ /--local-page(=(.*))?/) {
  $local_pagename = $2;
  shift @ARGV;
}

#------------------------------------------------------------------------------
{
  package MyPod2HTML;
  use HTML::Entities ();
  use base 'Pod::Simple::HTML';

  our $VERSION = 1;

  use constant DEBUG => 0;

  my %table;
  BEGIN {
    %table =
      ('apt-file'     => 'https://packages.debian.org/apt-file',
       'apt-cache'    => 'https://packages.debian.org/apt',
       'apt-rdepends' => 'https://packages.debian.org/apt-rdepends',
       'gtk-options'  => 'http://manpages.ubuntu.com/manpages/jaunty/man7/gtk-options.7.html',
       'xsetroot'     => 'http://www.x.org/archive/X1'.'1R7.5/doc/man/man1/xsetroot.1.html',
       'leafnode'     => 'http://leafnode.sourceforge.net',
       'lynx'         => 'http://lynx.isc.org/',
       'feed2imap'    => 'http://home.gna.org/feed2imap',
       # disguise from grep
       'rss'.'2email' => 'http://rss'.'2email.infogami.com',
       'rssdrop'      => 'http://search.cpan.org/dist/rssdrop/',
       'toursst'      => 'https://packages.debian.org/etch/toursst',
       'netrc'        => 'http://linux.die.net/man/5/netrc',
       'gp'           => 'http://pari.math.u-bordeaux.fr/dochtml/gpman.html',

       # apparently http://man-db.nongnu.org/ doesn't have man pages
       'man'      => 'http://ftp.parisc-linux.org/cgi-bin/man/man2html?man+1',
       'lexgrog'  => 'http://ftp.parisc-linux.org/cgi-bin/man/man2html?lexgrog+1',
       'apropos'  => 'http://ftp.parisc-linux.org/cgi-bin/man/man2html?apropos+1',
      );
  }

  sub resolve_man_page_link {
    my ($self, $to, $frag) = @_;
    $to = "$to";  # Pod::Simple::LinkSection object
    ### $to
    if (my ($page, $section) = ($to =~ /(.*)\(\d+\)$/)) {
      ### $page
      ### $section
      if (my $url = $table{$page}) {
        ### url from table: $url
        return $url;
      }
    }
    return shift->SUPER::resolve_man_page_link (@_);
  }

  sub resolve_pod_link_by_table {
    my ($self, $to, $section) = @_;

    my $tux_link = sub {
      my ($dir, $filename) = @_;
      if (! $local_links) { return "https://user42.tuxfamily.org/$dir/$filename"; }
      if ($dir eq $local_dir) { return $filename; }
      return "../$dir/$filename";
    };

    my $url;
    if (defined $to) {
      if ($to eq 'AptPkg') {
        $url = 'https://packages.debian.org/libapt-pkg-perl';
      }
      if ($to =~ /^Glib::Ex::(SourceIds|SignalIds|FreezeNotify|TieProperties)/) {
        $url = $tux_link->("glib-ex-ob"."jectbits", "$1.html");
      }
      if ($to eq 'Gtk2::Ex::Widget'.'Cursor') {
        $url = $tux_link->('gtk2-ex-widget'.'cursor', 'Widget'.'Cursor.html');
      }
      if ($to eq 'Ti'.'e:'.':TZ') {
        $url = $tux_link->('ti'.'e-'.'tz', 'TZ.html');
      }
      if ($to eq 'Time:'.':TZ') {
        $url = $tux_link->('ti'.'e-'.'tz', 'Time-'.'TZ.html');
      }

      if ($to =~ /^(Glib|Gtk2)($|::(?!Ex::))/) {
        $to =~ s{::}{/};
        $url = "http://gtk2-perl.sourceforge.net/doc/pod/$to.html"
      }

      if (defined $url) {
        return ($url . (defined $section && $section ne '' ? "#$section" : ''));
      }
    }
    return $self->SUPER::resolve_pod_link_by_table($to, $section);
  }

  # sub do_pod_link {
  #   my($self, $link) = @_;
  #   if (DEBUG) {
  #     print "\nlink tag=",$link->tagname," type=",$link->attr('type'),"\n";
  #     print "  to=",$link->attr('to')||'[none]',"\n";
  #     print "  section=",$link->attr('section')||'[none]',"\n";
  #   }
  #
  #   my $to = $link->attr('to') || '';  # undef if internal link
  #
  #   return $self->SUPER::do_pod_link($link);
  # }

  # Pod::Simple::HTML 3.35 doesn't like L<ccurve(6x)>.
  # That page isn't at http://man.he.net
  # Doesnt seem to be a jwz.org xscreensaver home either.
  sub resolve_man_page_link {
    my ($self, $to, $frag) = @_;
    my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)\w*[)])?$/;

    return undef unless defined $page and length $page;
    $section ||= 1;

    return $self->man_url_prefix . "$section/"
      . $self->manpage_url_escape($page)
      . $self->man_url_postfix;
  }

  sub version_tag_comment {
    my $self = shift;
    my $pod_simple_html_version = Pod::Simple::HTML->VERSION;
    my $str = <<"HERE";
  generated by $FindBin::Script - DO NOT EDIT
  using subclassed Pod::Simple::HTML version $pod_simple_html_version under Perl $]
HERE
    $str = HTML::Entities::encode_entities ($str);
    return <<"HERE";
<!--
$str-->
HERE
  }
}

#------------------------------------------------------------------------------

my $pod2html = MyPod2HTML->new;
$pod2html->title_postfix(' Man Page');

# <h1> and <h2> both too big, in mozilla at least, but leave it alone in the
# interests of logical heading levels even if they don't look good.
#
# $pod2html->html_h_level(3);

# Don't rate the "top" anchor, disable it.
$pod2html->top_anchor(undef);

{
  my $str = $pod2html->html_header_after_title;
  $str =~ s{</head>}{<meta name="viewport" content="width=device-width">\n</head>} or die;
  if ($local_links) {
    $str =~ s{</head>}{<link rel="canonical" href="https://user42.tuxfamily.org/$local_dir/$local_pagename"/>\n</head>} or die;
  }
  $pod2html->html_header_after_title($str);
}

if (! @ARGV) {
  die "no filename given";
}
$pod2html->output_string(\my $str);
$pod2html->parse_file(@ARGV);

$str =~ s{<code>(M-x.*?)</code>}{<kbd>$1</kbd>}ig;

print $str;
exit 0;