#!/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 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';

	# MetaCPAN shows Markdown files with relative images as gray
	# placeholders, so they point to the files in the repository.
	use constant IMAGE_URL_BASE => 'https://raw.githubusercontent.com/davenonymous/perl-imager-sixel/master';

	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 = absoluteImageUrls($text) if $self->{inHtmlBlock};
		return $self->SUPER::handle_text($text);
	}

	# An image path relative to the top directory, such as
	# /images/NAME.png, becomes the URL of its raw file on GitHub.
	sub absoluteImageUrls($html) {
		$html =~ s{(<img\b[^>]*?\bsrc=")/}{$1 . IMAGE_URL_BASE . '/'}ge;
		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 path that starts with C</>, such as
C<< <img src="/images/colors.png"> >>, is relative to the top directory
of the distribution. It becomes the URL of the file in the C<master>
branch on GitHub, for example
C<https://raw.githubusercontent.com/davenonymous/perl-imager-sixel/master/images/colors.png>,
because MetaCPAN shows relative images in Markdown files as gray
placeholders. MetaCPAN resolves the original path in the pod itself.

=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
