#!/usr/bin/env perl
# Converts the documentation of Imager::File::SIXEL into Markdown:
# README.md and the pages in docs/.
#
# Pod::Markdown with five changes: links between the pages of this
# distribution point to their Markdown files, images in html blocks
# point to their raw files in the master branch on GitHub, the indentation that all lines of
# a verbatim block share is removed, each verbatim block is fenced with
# the language set by the last '=for highlighter' paragraph, and tables
# in 'text' blocks become Markdown tables.
#
# Copyright (C) 2026 davenonymous.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
use v5.24;
use warnings;
use feature qw(signatures);
no warnings qw(experimental::signatures);

use Getopt::Long qw(GetOptions);
use Pod::Usage qw(pod2usage);

# Every page: its module name, its pod file and its Markdown file, all
# paths relative to the top directory of the distribution.
my @pages = (
	['Imager::File::SIXEL',           'lib/Imager/File/SIXEL.pm',           'README.md'],
	['Imager::File::SIXEL::Examples', 'lib/Imager/File/SIXEL/Examples.pod', 'docs/Examples.md'],
	['Imager::File::SIXEL::Format',   'lib/Imager/File/SIXEL/Format.pod',   'docs/Format.md'],
);

package My::Pod::Markdown {
	use parent 'Pod::Markdown';
	use feature qw(signatures);
	no warnings qw(experimental::signatures);

	use File::Basename qw(dirname);
	use File::Spec;

	use constant DEFAULT_LANGUAGE => 'perl';

	# The pod points to the images at the tag of the release, which does
	# not exist before the release; the Markdown files on GitHub show the
	# images of the master branch instead.
	use constant IMAGE_URL_BASE => 'https://raw.githubusercontent.com/davenonymous/perl-imager-sixel';

	die "Pod::Markdown has no _indent_verbatim(); this script needs an update\n"
		unless Pod::Markdown->can('_indent_verbatim');

	# $markdownFile is the file being written; %$markdownFiles maps the
	# module names of the local pages to their Markdown files.
	sub new($class, $markdownFile, $markdownFiles) {
		my $self = $class->SUPER::new(output_encoding => 'UTF-8');
		$self->accept_targets('highlighter');
		$self->{highlighterLanguage} = DEFAULT_LANGUAGE;
		$self->{markdownDirectory} = dirname($markdownFile);
		$self->{markdownFiles} = $markdownFiles;
		return $self;
	}

	# Links to a local page point to its Markdown file, relative to the
	# file being written, with a fragment as GitHub creates it.
	sub format_perldoc_url($self, $name, $section) {
		my $target = defined $name ? $self->{markdownFiles}{$name} : undef;
		return $self->SUPER::format_perldoc_url($name, $section) unless defined $target;

		my $url = File::Spec::Unix->abs2rel($target, $self->{markdownDirectory});
		$url .= '#' . $self->format_fragment_markdown($section) if defined $section && length $section;
		return $url;
	}

	# '=for highlighter language=NAME' (or just NAME) sets the language
	# of the following verbatim blocks, as on MetaCPAN. Its text is
	# collected here instead of being written to the output.
	sub start_for($self, $attr) {
		$self->{inHtmlBlock} = 1 if $attr->{target} eq 'html';
		return $self->SUPER::start_for($attr) unless $attr->{target} eq 'highlighter';
		$self->{highlighterText} = '';
		return;
	}

	sub end_for($self, @args) {
		delete $self->{inHtmlBlock};
		return $self->SUPER::end_for(@args) unless defined $self->{highlighterText};
		my $setting = delete $self->{highlighterText};
		my ($language) = $setting =~ /\A\s*(?:language=)?([\w+#-]+)\s*\z/
			or die "invalid '=for highlighter' setting '$setting'\n";
		$self->{highlighterLanguage} = $language;
		return;
	}

	sub start_Data($self, @args) {
		return if defined $self->{highlighterText};
		return $self->SUPER::start_Data(@args);
	}

	sub end_Data($self, @args) {
		return if defined $self->{highlighterText};
		return $self->SUPER::end_Data(@args);
	}

	sub handle_text($self, $text) {
		if (defined $self->{highlighterText}) {
			$self->{highlighterText} .= $text;
			return;
		}
		$text = masterImageUrls($text) if $self->{inHtmlBlock};
		return $self->SUPER::handle_text($text);
	}

	# An image URL at a tag, such as IMAGE_URL_BASE/v1.000/images/NAME.png,
	# becomes the URL of the same file in the master branch.
	sub masterImageUrls($html) {
		$html =~ s{(<img\b[^>]*?\bsrc="\Q@{[IMAGE_URL_BASE]}\E/)[^"/]+/}{$1master/}g;
		return $html;
	}

	# A fenced block without the indentation its lines share. In a text
	# block, every table (see markdownTable) becomes a Markdown table.
	sub _indent_verbatim($self, $paragraph) {
		my @lines = split /\n/, $paragraph;
		my ($indent) = sort { $a <=> $b } map { /\A( *)/; length $1 } grep {/\S/} @lines;
		$indent //= 0;
		my $code = join "\n", map { length > $indent ? substr($_, $indent) : '' } @lines;
		return "```$self->{highlighterLanguage}\n$code\n```" unless $self->{highlighterLanguage} eq 'text';

		my @parts = map { isTable($_) ? markdownTable($_) : "```text\n$_\n```" } split /\n\s*\n/, $code;
		return join "\n\n", @parts;
	}

	# A table is a header line followed by a line of dash runs, one run
	# per column, separated by spaces.
	sub isTable($text) {
		my @lines = split /\n/, $text;
		return @lines >= 3 && $lines[1] =~ /\A-+(?: +-+)*\z/;
	}

	# Each cell is the text above or below its column's dash run; text
	# outside the runs is an error. Columns whose cells are all numbers
	# are right-aligned. Identifiers and single punctuation characters in
	# the first column become code.
	sub markdownTable($text) {
		my ($header, $dashes, @rows) = split /\n/, $text;
		my @spans;
		while ($dashes =~ /(-+)/g) {
			push @spans, [$-[1], $+[1] - $-[1]];
		}
		my @table = map { tableCells($_, \@spans) } $header, @rows;
		my @numeric = map {
			my $column = $_;
			!grep { $_->[$column] !~ /\A[0-9.]+\z/ } @table[1 .. $#table];
		} 0 .. $#spans;
		foreach my $row (@table[1 .. $#table]) {
			$row->[0] = join ', ', map {"`$_`"} split /, /, $row->[0]
				if $row->[0] =~ /\A(?:[a-z_]+(?:, [a-z_]+)*|[[:punct:]])\z/;
		}

		foreach my $row (@table) {
			s/\|/\\|/g foreach $row->@*;
		}
		my @widths = map {
			my $column = $_;
			my ($widest) = sort { $b <=> $a } 3, map { length $_->[$column] } @table;
			$widest;
		} 0 .. $#spans;

		my @markdown = (
			tableRow($table[0], \@widths, \@numeric),
			tableRow([map { $numeric[$_] ? '-' x ($widths[$_] - 1) . ':' : '-' x $widths[$_] } 0 .. $#spans], \@widths, []),
			map { tableRow($_, \@widths, \@numeric) } @table[1 .. $#table],
		);
		return join "\n", @markdown;
	}

	sub tableCells($line, $spans) {
		my $outside = $line;
		my @cells;
		foreach my $span ($spans->@*) {
			my ($start, $length) = $span->@*;
			my $cell = length $line > $start ? substr($line, $start, $length) : '';
			substr($outside, $start, $length) = ' ' x $length if length $outside > $start;
			$cell =~ s/\A\s+|\s+\z//g;
			push @cells, $cell;
		}
		die "table text outside the columns: '$line'\n" if $outside =~ /\S/;
		return \@cells;
	}

	# One table row with every cell padded to its column's width, so that
	# the columns line up in the Markdown source too. Cells of
	# right-aligned columns, header included, are padded on the left.
	sub tableRow($cells, $widths, $rightAligned) {
		my @padded = map {
			my $padding = ' ' x ($widths->[$_] - length $cells->[$_]);
			$rightAligned->[$_] ? $padding . $cells->[$_] : $cells->[$_] . $padding;
		} 0 .. $#$cells;
		return '| ' . join(' | ', @padded) . ' |';
	}
}

package main;

my %options;
GetOptions(\%options, 'check', 'help')
	or pod2usage(2);
pod2usage(1) if $options{help};
pod2usage('no arguments expected') if @ARGV;

my %markdownFiles = map { $_->[0] => $_->[2] } @pages;
my $outdated = 0;
foreach my $page (@pages) {
	my (undef, $podFile, $markdownFile) = $page->@*;
	$outdated += storeMarkdown(convert($podFile, $markdownFile, \%markdownFiles), $markdownFile, $options{check});
}
exit($options{check} && $outdated ? 1 : 0);

sub convert($podFile, $markdownFile, $markdownFiles) {
	my $markdown = '';
	my $parser = My::Pod::Markdown->new($markdownFile, $markdownFiles);
	$parser->output_string(\$markdown);
	$parser->parse_file($podFile);
	die "$podFile: no pod found\n" unless length $markdown;
	return $markdown;
}

# Writes the Markdown unless the file already holds it. Returns 1 when
# the file was (or, with --check, would be) changed.
sub storeMarkdown($markdown, $file, $checkOnly) {
	my $current = '';
	if (open(my $in, '<:raw', $file)) {
		local $/;
		$current = <$in>;
		close($in);
	}
	return 0 if $current eq $markdown;

	if ($checkOnly) {
		say "out of date: $file";
		return 1;
	}
	open(my $out, '>:raw', $file) or die "cannot write $file: $!\n";
	print {$out} $markdown;
	close($out) or die "cannot write $file: $!\n";
	say "wrote $file";
	return 1;
}

__END__

=head1 NAME

pod2markdown - convert the Imager::File::SIXEL documentation into Markdown

=head1 SYNOPSIS

  perl tools/pod2markdown [--check]

=head1 DESCRIPTION

Converts the pod of every documentation page of the distribution into
Markdown, run from the top directory of the distribution:

  lib/Imager/File/SIXEL.pm            -> README.md
  lib/Imager/File/SIXEL/Examples.pod  -> docs/Examples.md
  lib/Imager/File/SIXEL/Format.pod    -> docs/Format.md

Files whose content would not change are left alone. The conversion is
done by L<Pod::Markdown>, with five changes:

=over

=item *

A link to one of these pages, such as
C<< LE<lt>Imager::File::SIXEL::Examples/Handle errorsE<gt> >>, points to
its Markdown file, relative to the file that contains the link, for
example C<docs/Examples.md#handle-errors>. Other links point to MetaCPAN
as usual.

=item *

In an C<html> block, an image URL of a raw file on GitHub at a tag,
such as
C<https://raw.githubusercontent.com/davenonymous/perl-imager-sixel/v1.000/images/colors.png>,
becomes the URL of the same file in the C<master> branch, for example
C<https://raw.githubusercontent.com/davenonymous/perl-imager-sixel/master/images/colors.png>.
The pod points to the tag of the release, because MetaCPAN shows images
with relative paths as gray placeholders, but that tag does not exist
on GitHub before the release. F<tools/make-images> keeps the tag in the
pod up to date.

=item *

The indentation that all lines of a verbatim block share is removed, so
the code starts at the left edge of the Markdown code block.

=item *

Each verbatim block is fenced with a language name for syntax
highlighting. A paragraph

  =for highlighter language=sh

sets the language of all following verbatim blocks of the page, until
the next such paragraph; C<=for highlighter sh> works too. This is the
marker MetaCPAN uses for its own highlighting. Blocks before the first
marker are C<perl>.

=item *

In a C<text> block, every table becomes a Markdown table. A table is a
group of lines without blank lines between them: a header line, a line
of dash runs separated by spaces, one run per column, and the rows. The
text of each cell must lie within the width of its column's dash run;
otherwise the script stops with an error. Columns that hold only
numbers are right-aligned, and identifiers such as option names and
single punctuation characters in the first column are formatted as
code. Every cell is padded to the width of its column, so the columns
also line up in the Markdown source. Other groups of lines in the block stay a C<text> code block.

  Option            Default
  ----------------  -------
  page              0
  allow_incomplete  false

=back

=head1 OPTIONS

=over

=item --check

Write nothing; list the Markdown files that are out of date and exit
with status 1 if there are any.

=back

=cut
