Fetching contributors…
Cannot retrieve contributors at this time
executable file 618 lines (530 sloc) 16.6 KB
#!/usr/bin/env perl
# Copyright (c) 2014-2015 Christian Jaeger,
# This is free software, offered under either the same terms as perl 5
# or the terms of the Artistic License version 2 or the terms of the
# MIT License (Expat version). See the file that came
# bundled with this file.
use strict; use warnings; use warnings FATAL => 'uninitialized';
# Method::Signatures versions 20120523 and 20141021 are working badly
# for this file, because (1) each package needs its own import, (2)
# error locations are completely off. Thus, still use the trusty
# Function::Parameters.
use Function::Parameters qw(:strict);
use Sub::Call::Tail;
# find modules from functional-perl working directory (not installed)
use Cwd 'abs_path';
our ($mydir, $myname); BEGIN {
my $location= (-l $0) ? abs_path ($0) : $0;
$location=~ /(.*?)([^\/]+?)_?\z/s or die "?";
($mydir, $myname)=($1,$2);
use lib "$mydir/../lib";
# and the htmlgen/ directory
use lib $mydir;
our $css_path= "htmlgen.css";
sub usage {
print "$myname config inbase outbase
config is the path to a Perl file ending in a hash with config
values, see functional-perl/website/ for an example.
inbase needs to be a git working directory.
Assumes that there is a file '$css_path', which is included in the
<head/> and copied to outbase.
--repl open a repl instead of running the main action
--trap trap uncached exception in a repl (implied by --repl)
exit 1;
use Getopt::Long;
our $verbose=0;
our ($opt_repl,$opt_trap);
GetOptions("verbose"=> \$verbose,
"help"=> sub{usage},
"repl"=> \$opt_repl,
"trap"=> \$opt_trap,
) or exit 1;
usage unless @ARGV==3 or ($opt_repl and @ARGV>=1);
our ($configpath, $inbase, $outbase)= @ARGV;
our $user_config= require $configpath;
use Chj::Backtrace;
use Chj::Trapl;#
use Hash::Util 'lock_hash';
use Chj::xperlfunc qw(basename dirname);
use Chj::xIOUtil qw(xgetfile_utf8 xcopyfile);
use FP::HashSet ":all";
use PXML::XHTML ":all";
use PXML::Serialize 'puthtmlfile';
use FP::Array ":all";
use File::Spec;
use FP::Array_sort;
use FP::Ops qw(string_cmp number_cmp the_method cut_method);
use Chj::TEST ":all";
use FP::List qw(is_pair list);
use PXML::Util ":all";
use FP::Hash ":all";
use PXML::Tags qw(with_toc);
use FP::Predicates qw(complement);
use FP::Git::Repository;
use Htmlgen::PathTranslate;
use Htmlgen::PathUtil qw(path_add path_diff path0);
use Htmlgen::Cost;
use Htmlgen::default_config qw($default_config);
use Htmlgen::FileUtil qw(existingpath_or create_parent_dirs);
use Htmlgen::MarkdownPlus qw(markdownplus_parse);
use FP::Lazy;
use Htmlgen::Mediawiki qw(mediawiki_prepare mediawiki_replace
use PXML::Preserialize qw(pxmlpre);
our $config = hashset_union ($user_config, $default_config);
lock_hash %$config;
our $pathtranslate= Htmlgen::PathTranslate->new__
(subhash $config, "is_indexpath0", "downcaps");
our $gitrepository= FP::Git::Repository->new_(chdir=> $inbase);
fun path0_to_inpath ($path0) {
fun path0_to_outpath ($path0) {
# nope, also used for .pl file copying,
use Htmlgen::Toc;
use Htmlgen::Linking;
# XX make configurable
our $pxml_mappers=
["Htmlgen::Linking::Anchors", "Htmlgen::Toc",
"Htmlgen::Linking::code", "Htmlgen::Linking::a_href"];
fun pxml_name_to_mapper (@PXMLMapper_args) {
map {
my $m= $_->new_(@PXMLMapper_args);
map {
($_, sub { $m->map_element(@_)})
} @{$m->match_element_names}
} @$pxml_mappers
fun process_body ($v,
# fake instance for tests only:
(path0=> "NOPATH",
maybe_have_path0=> sub{die"NOIMPL"},
perhaps_filename_to_path0=> sub{die"NOIMPL"},
pathtranslate=> $pathtranslate),
) {
# HACK: can't mediawiki_expand the whole document in string format
# before the markdown parsing, since it would expand examples in
# code sections as well. So instead leave the [[ ]] in (unharmed
# by markdown) and expand it here on individual text segments,
# then map it (and here comes the hacky part, you will forget to
# update here when prepending another mapping phase or so, right?)
# the same way the rest of the document is treated.
my $map_text_mediawiki= fun ($v,$uplist) {
if (is_pair $uplist # tests may not have it!
and $uplist->first->name eq "code") {
# don't expand it in code segments
mediawiki_replace($v, $mediawikitoken, $mediawikitable)
} else {
my $body= mediawiki_rexpand
($v, $mediawikitoken, $mediawikitable);
array_map (
fun ($e) {
($e, $pxml_name_to_mapper, undef);
pxml_map_elements_exhaustively ($v,
TEST { HTML( process_body
H1 "world")]))
->string }
'<html>Hello<div class="toc_box"><dir class="toc"><h3 class="toc_title">Contents</h3><li><dir class="toc"><a href="#world">1. world</a></dir></li></dir></div><a name="world"><h1>1. world</h1></a></html>';
TEST { HTML( process_body
(["Hello", WITH_TOC ["some", H2 "world"]]))
->string }
'<html>Hello<div class="toc_box"><dir class="toc"><h3 class="toc_title">Contents</h3><li><dir class="toc"><a href="#world">1. world</a></dir></li></dir></div>some<a name="world"><h2>1. world</h2></a></html>';
TEST { HTML( process_body ([P("Hello"),
[" ",
P ("blabla"),
A({name=>"a"}," ",DIV H1 ("for one")),
]]))->string }
'<html><p>Hello</p><div class="toc_box"><dir class="toc"><h3 class="toc_title">Contents</h3><li><dir class="toc"><a href="#for_one">1. for one</a></dir></li></dir></div> <p>blabla</p><a name="a"> <div><a name="for_one"><h1>1. for one</h1></a></div></a></html>';
TEST { HTML( process_body ([P("Hello"),
[" ",
P ("blabla"),
H1 ("for one"),
H2 ("more one"),
P ("blah"),
H1 ("sub two"),
DIV ("bla")),
]]))->string }
'<div class="toc_box"><dir class="toc"><h3 class="toc_title">Contents</h3><li><dir class="toc"><a href="#for_one">1. for one</a><li><dir class="toc"><a href="#more_one">1.1. more one</a></dir></li></dir></li><li><dir class="toc"><a href="#sub_two">2. sub two</a></dir></li></dir></div>'.
' <p>blabla</p><a name="for_one"><h1>1. for one</h1></a><a name="more_one"><h2>1.1. more one</h2></a><table><tr><td><p>blah</p><a name="sub_two"><h1>2. sub two</h1></a><div>bla</div></td></tr></table></html>';
package PFLANZE::Filesinfo;
use FP::Hash "hash_perhaps_ref";
use FP::Struct [qw(files
method filename_to_path0 ($filename) {
// die "no mapping for filename '$filename'"
method filename_to_maybe_path0 ($filename) {
# still very unclear about the exact name styling. Prefer perhaps,
# and "then" also move the qualificator to the front? (but leave
# the one for hash_ where it is since hash_ is the type prefix?) :
method perhaps_filename_to_path0 ($filename) {
hash_perhaps_ref ($$self{filename_to_path0}, $filename)
method all_path0_exists ($path0) {
defined $$self{all_path0_exists}{$path0}
defined $$self{all_path0_exists}{$path0."/"}
method path0_is_directory ($path0) {
$path0=~ s|/+$||s;
defined $$self{all_path0_exists}{$path0."/"}
method path0_exists ($path0) {
defined $$self{path0_exists}{$path0}
method all_path0_used_inc ($path0) {
fun get_filesinfo () {
my $all_files= $gitrepository->ls_files->array;
my $files= array_filter (cut_method($pathtranslate,"is_md"),
my $filename_to_path0=
+{map {
basename ($_)=> path0($_)
} @$files};
my $all_path0_exists=
map {
# and their directories, ok? Any directory that has files
# from git will be ok as link target, ok?
map {
my $path0_exists=
+{map {
} @$files};
my $all_path0_used= {};
# Navigation:
use FP::PureArray;
use FP::Equals qw(equals);
fun nav_bar ($items_in_level, $item_selected, $viewed_at_item) {
UL({class=> "menu"},
fun ($is_last, $item) {
my $filetitle= $pathtranslate->path0_to_title($item->path0);
my $is_viewed= equals($item, $viewed_at_item);
my $is_open= equals($item, $item_selected);
LI({class=> ($is_last ? "menu_last" : "menu")},
($is_viewed ?
SPAN({class=> "menu_selected"},
: A ({class=> ($is_open ? "menu_open" : "menu"),
" ")
# For access from main:: by the code in the configuration file:
use Htmlgen::Nav qw(_nav entry);
sub nav {
_nav (list(@_), \&nav_bar)
# group $files, to process them in an order that satisfies dependency
# on $costranges
fun groupkey ($path) {
my $p0= path0 $path;
if ($p0=~ m|^bugs/|) {
} elsif ($p0 =~ m|^docs/bugs.*\.md$|) {
} else {
package PFLANZE::Genfilestate;
use FP::Struct [qw(filesinfo
# ugly to keep that costranges state here ? well call it Genfilestate then?
method set_costrange ($path0,$maybe_costrange) {
$$self{costranges}{$path0}= $maybe_costrange;
method costrange ($path0) {
fun get_genfilestate ($filesinfo) {
my $groupedfiles= array_to_hash_group_by $filesinfo->files, \&groupkey;
my $nonbugfiles= purearray( @{$$groupedfiles{normal}},
@{$$groupedfiles{buglist}||[]} );
my $costranges={};
# path0 -> costrange-string; filled when processing non-buglist groups
($filesinfo, # just so as to bundle it up, too, ugly?
our $HEAD= pxmlpre 3, fun ($title, $csspath, $user_additions) {
TITLE ($title),
LINK ({rel=> "stylesheet",
href=> $csspath,
type=> "text/css"}),
fun genfile ($path,$groupname,$genfilestate) {
my $path0= path0 $path;
my $outpath= path0_to_outpath($path0);
mkdir dirname( $outpath);
my $filetitle= $pathtranslate->path0_to_title($path0);
my $str= xgetfile_utf8 "$inbase/$path";
if ($$config{warn_hint}) {
$str=~ s/^\(?Check the.*?website.*?---\s+//s
or $path=~/COPYING|bugs|licenses\//
or warn "'$path' is missing hint";
if (my $hdl= $config->{path0_handlers}->{$path0}) {
$str= $hdl->($path,$path0,$str);
my $maybe_costrange= do {
# extract Cost indicators:
my $namere= qr/\w+/;
my $nameplusre= qr/\(?$namere\)?/;
my $possibly_nameplus_to_name= fun ($maybe_nameplus) {
if (defined $maybe_nameplus) {
my ($name)= $maybe_nameplus=~ qr/($namere)/
or die "bug";
} else {
local our $costs=[];
while ($str=~ m{\b[Cc]ost
# name: parentheses for "library cost"
# base costs
# amount
}gx) {
my ($nameplus,$basecosts,$val)=($1,$2,$3);
my $name= &$possibly_nameplus_to_name($nameplus);
my @basecosts= map { &$possibly_nameplus_to_name($_) }
split /\s*\+\s*/, $basecosts;
push @$costs, new PFLANZE::Cost ($name,
(not $nameplus
or not($nameplus=~ /^\(/)),
@$costs ? PFLANZE::Totalcost->new($costs)->range : undef
if (defined $maybe_costrange) {
$genfilestate->set_costrange($path0, $maybe_costrange);
my $mediawikitoken= rand; # not fork safe!
my ($h1,$body,$mediawikitable)=
markdownplus_parse ($str, lazy{ $pathtranslate->path0_to_title
($path0) },
my $maybe_buglist= $groupname eq "buglist" && do {
my $bugs=
fun ($path) {
my $path0= path0 $path;
my $title= $pathtranslate->path0_to_title($path0);
on sub{$_[0][0]}, \&string_cmp # XX not a good cmp.
({class=> "costlist"},
THEAD (TH ("Type"), TH ("Title"),TH ("Cost range (USD)")),
map {
my ($title,$p0,$costrange)= @$_;
my $relurl= File::Spec->abs2rel
basename ($path0));
TR (TD ($pathtranslate->path0_to_bugtype($p0)),
TD (A({href=>$relurl},$title)),
TD ({align=>"center"},$costrange))
} @$bugs
my $filesinfo= $genfilestate->filesinfo;
my $pxml_name_to_mapper=
pxml_name_to_mapper (path0=> $path0,
fun ($path0) {
if ($filesinfo->all_path0_exists ($path0)) {
} else {
fun ($filename) {
hash_maybe_ref ($config, "map_code_body"),
my $nav= $$config{nav};
my $nav_index= $nav->index;
# ^ this could be cached across all documents (but measurements
# haves shown it to be insignificant)
my $nav_upitems= $nav_index->path0_to_upitems($path0);
my $nav_self= $nav_upitems->first;
my $html=
scalar path_diff ($path0, $css_path),
scalar $config->{head}->($path0)),
(1 ?
# make the top nav level contain all unknown pages
# (and don't include pages declared in the nav that
# don't exist)
(fun($p0) {$nav_index->path0_to_item($p0)}),
($nav_self, $nav_upitems)
# strictly follow the navigation declaration
$nav->nav_bar_levels ($nav_self, $nav_upitems)
process_body ($body, $pxml_name_to_mapper,
$mediawikitoken, $mediawikitable),
($maybe_costrange ? P("\x{21d2} Cost range: \$",
$maybe_costrange) : ()),
$gitrepository->author_date ($path)),
puthtmlfile($outpath, $html);
fun genfiles ($filesinfo) {
my $genfilestate= get_genfilestate ($filesinfo);
for my $groupname (qw(bugs normal buglist)) {
for (@{$genfilestate->groupedfiles->{$groupname}}) {
genfile $_,$groupname,$genfilestate
# copy referenced files:
fun copyfiles ($filesinfo) {
for my $path0 (hashset_keys
(hash_ref_or ($config, "copy_paths", [])))) {
next if $filesinfo->path0_exists($path0); # md path
next if $filesinfo->path0_is_directory($path0);
create_parent_dirs ($path0, \&path0_to_outpath);
xcopyfile (path0_to_inpath($path0), path0_to_outpath($path0));
if (my ($separate)= hash_perhaps_ref($config, "copy_paths_separate")) {
for my $root (keys %$separate) {
for my $path0 (@{$$separate{$root}}) {
xcopyfile "$root/$path0", path0_to_outpath $path0
# copy htmlgen CSS file
xcopyfile (existingpath_or (path0_to_inpath($css_path),
fun main () {
mkdir $outbase;
my $filesinfo= get_filesinfo;
genfiles ($filesinfo);
copyfiles ($filesinfo);
perhaps_run_tests __PACKAGE__
or do {
if ($opt_trap) {
require Chj::WithRepl; &Chj::WithRepl::push_withrepl (0);
$opt_repl ? do {
require Chj::repl;
require Chj::WithRepl; &Chj::WithRepl::push_withrepl (0);
} : main;