package DTA::Controller::Book;
use Moose;
use namespace::autoclean;

BEGIN {extends 'Catalyst::Controller'; }

use utf8;
use DTA::CAB::Client::HTTP;
use DTA::CAB::Format::TEI;
use DTA::TEI::Text::Transform;
use DTA::XMLsh;
use Unicruft 'utf8_to_utf8_de';

use Data::Page;
use File::Basename qw(basename);
use File::Temp qw(tempfile);
use XML::LibXML;

=head1 NAME

DTA::Controller::Web::Book - Catalyst Controller

=head1 DESCRIPTION

Catalyst Controller.

=head1 METHODS

=head2 auto

=cut

sub auto :Private {
    my ( $self, $c ) = @_;
    $c->stash->{fullwidth} = 1;
    return 1;
}

=head2 validbook

=cut

sub validbook : Private {
    my ( $self, $c, $id_or_dirname, $all ) = @_;
    
    $c->detach( '/default' ) unless $id_or_dirname; 

    my $book = $c->model('DTADB::Book')->search({
        -or => [
            'me.id_book::text' => { '=' => $id_or_dirname },
            'me.dirname' => { '=' => $id_or_dirname }
        ],
      },{
        prefetch => qw/ source /,
    })->first();

    $c->detach( '/default' ) if ( !$book or !$book->source or !$book->source->source );

    if ( $c->action ne 'api/tei_header' && $book->ready == 3 ) {
        $c->detach( 'denied_license' );
    }

    my @schlemihls = qw(17261 17262 17263 17264 17265); # Schlehmil-Baende
    if ( $c->action ne 'api/tei_header' && (List::MoreUtils::any { $book->id_book eq $_ } @schlemihls) ) {
        $c->detach( 'denied_license' );
    }

    my @rechnungsbuecher = qw(30534 30535 30536 30537);
    if ( $c->action ne 'api/tei_header' && (List::MoreUtils::any { $book->id_book eq $_ } @rechnungsbuecher) ) {
        $c->detach( 'denied_license' );
    }

    my @reuss = qw( 30942 30943 ); # reuss-ebersdorf_erdmuthe-briefedition
    if ( $c->action ne 'api/tei_header' && (List::MoreUtils::any { $book->id_book eq $_ } @reuss) ) {
        $c->detach( 'denied_license' );
    }

    my @gwb = qw( 30969 );
    if ( $c->action ne 'api/tei_header' && (List::MoreUtils::any { $book->id_book eq $_ } @gwb) ) {
        $c->detach( 'denied_license' );
    }

    my @dwds = qw( 317808 317816 317817 317834 317854 317858 317884 317886 317891 317895 317909 317910 317987 317996 317997 318007 318008 318010 318011 );
    if ( $c->action ne 'api/tei_header' && (List::MoreUtils::any { $book->id_book eq $_ } @dwds) ) {
        $c->detach( 'denied_license' );
    }

    my @sanders = qw( 32327 32389 32388 32387 32390 32356 32372 32339 );
    if ( $c->action ne 'api/tei_header' && (List::MoreUtils::any { $book->id_book eq $_ } @sanders) ) {
        $c->detach( 'denied_license' );
    }

    $c->stash->{book} = $book;
    $c->stash->{dirname} = $book->dirname;
    $c->stash->{booksource} = $book->source->source;
    return $book;
}

=head2 show

=cut

sub show : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );

    $c->forward( '/book/coins' );
    $c->forward( '/book/common/toc_html' );

    $c->stash(
        template => 'web/book/show.tt',
    );
}

=head2 images

=cut

sub images :Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );

    my $p = $c->req->params->{p} || 1;
    my $ppv = 50;

    my $pager = Data::Page->new;
    $pager->total_entries( scalar @{[$book->pages]} );
    $pager->entries_per_page( $ppv );
    $pager->current_page( $p );

    $c->stash(
        book     => $book,
        pager    => $pager,
        template => 'web/book/images.tt',
    );
}

=head2 view

=cut

sub view : Local {
    my ( $self, $c, $id_or_dirname, $opt_page, $view ) = @_;

    if ( $opt_page ) {
        $c->res->redirect( $c->uri_for("/book/view/$id_or_dirname", { p => $opt_page, ($view ? (v => $view) : ()) }) );
    }

    my $book = $c->forward( 'validbook', [$id_or_dirname, $opt_page] );
    my $dirname = $book->dirname;

    my $page = $opt_page || $c->req->params->{p} || do {
        $c->detach('/book/show', [$id_or_dirname]);
    };
    $c->stash->{page} = $page;

    my $xmlfile = sprintf '%s/%s.xml/pages/%s.xml_%04d.xml', $c->config->{xmlrep}, $dirname, $dirname, $page;
    $c->stash->{xmlfile} = $xmlfile;

    open( my $fh, '<', $xmlfile ) or die $!;
    my $xml;
    {
        local $/;
        $xml = <$fh>;
    }
    close $fh;
    $c->stash->{pagexml} = $xml;

    $c->forward('page_xsl');
    $c->forward('page_xml');
    $c->forward('page_plain');
    $c->forward('page_num');
    $c->forward('/book/common/page_number', [$book]);

    my $formulae = $c->model('DTADB::Formula')->search(
        {
            book => $book->get_column('id_book'),
            page => $page,
        },
        {
            order_by => 'no',
        }
    );

    my $def_view = $c->req->params->{v} || $c->session->{view};
    my $fontsize = $c->session->{fontsize};

    $c->stash(
        def_view => $def_view || 'text',
        fontsize => $fontsize || 16,
    );

    $c->stash(
        template => 'web/book/view.tt',
        book     => $book,
        page     => $page,
        pages    => [
            map { /([0-9]+)\.xml$/; $1 }
            glob sprintf( '%s/%s.xml/pages/*.xml', $c->config->{xmlrep}, $dirname )
        ],
        formulae => [ $formulae->all ],
        pagenotes => [ $c->model('DTADB::Pagenote')->search({ book => $book->id_book, page => $page })->all],
    );
}

=head2 page_xsl

=cut

sub page_xsl : Private {
    my ( $self, $c ) = @_;

    my $rawxml = $c->stash->{pagexml};

    $rawxml =~ s{(</c>)\s+(<(?:hi|note)\b)}{$1$2}g;
    $rawxml =~ s{(</c></hi>)\s+(<note\b)}{$1$2}g;
    $rawxml =~ s/\s+<c /<c /g;
    $rawxml =~ s/(rendition=")\s*/$1/g;
    $rawxml =~ s/(?:\r?\n)*(<(?:supplied|corr|sic|orig|gap|seg)[^>]*>)(?:\r?\n)*/$1/g;
    $rawxml =~ s/(?:\r?\n)*(<\/(?:supplied|corr|sic|orig|gap|note)>)(?:\r?\n)*/$1/g;
    $rawxml =~ s{(</c></hi>)(?:\r?\n)*(<hi rendition="#(?:c|et|right)"><c )}{$1$2}g;
    $rawxml =~ s{(</hi>)(?:\r?\n)(<hi)\b}{$1$2}g;

    # figure handling
    $rawxml =~ s{(<lb/>)\s+(<figure)\b}{$1$2}g;
    $rawxml =~ s{(</figure>)\s+(<lb/>)}{$1$2}g;
    $rawxml =~ s{(<(?:div|pb|seg)\b[^>]*>)\s*(<figure)\b}{$1<lb/>$2}g;
    $rawxml =~ s{(<figure/>)\s*(<(?:figure|fw|l|head)\b)}{$1<lb/>$2}g;
    $rawxml =~ s{(<figure/>)\s*(</?(?:p|div))\b}{$1<lb/>$2}g;

    # centering formulae
    $rawxml =~ s{
        (<lb/>\s?)
        (
            (?:
                <formula\s*/>|<formula\b[^>]*>[^<]+</formula>
            )
            (?:
                [.;,\s]| u\. s\. w\.,?
            )?
        )
        (</(?:p|div|lg|seg|head)>)?
        (<lb/>)
    }{$1<hi rendition="#c">$2</hi>$3}gx;

    # remove page number
    $rawxml =~ s{<fw type="page number" place="top">.*?</fw>}{}s;

    my ( $tempfh, $tempname ) = tempfile();
    print $tempfh $rawxml;
    close $tempfh;

    $c->stash->{additional_register_function} = [
        {
            uri => 'urn:dta',
            name => 'dirname',
            subref => sub { return $c->stash->{book}->dirname },
        },
        {
            uri => 'urn:dta',
            name => 'source',
            subref => sub { return $c->stash->{book}->source->source },
        },
        {
            uri => 'urn:dta',
            name => 'metapher-ana',
            subref => sub {
                my @anas = split /\s+/ => $_[0];
                @anas = map { s/^#//; $_ } @anas;
                my $epo_file = sprintf('/home/wiegand/dta-xml/dtae/epoetics/%s.txt.xml', $_[1]);
                return unless -e $epo_file;
                my $source = XML::LibXML->load_xml( location => $epo_file );
                my $xpc = XML::LibXML::XPathContext->new;
                $xpc->registerNs( 'tei', 'http://www.tei-c.org/ns/1.0' );

                my @ret;
                foreach my $ana ( @anas ) {
                    my $val = $xpc->findvalue( '//*[@xml:id="' . $ana . '"]', $source );
                    $val =~ s/(?:^\s+|\s+$)//g;
                    push @ret, $val;
                }
                return join "; " => @ret;
            },
        }
    ];

    $c->stash->{xml}      = $tempname;
    $c->stash->{template} = 'dta-web.xsl';
    $c->forward('DTA::View::XSLT');
    unlink $tempname;
    my $html = $c->res->body;

    # clean footnote lookup
    %DTA::View::XSLT::fn_seen = ();

    # some fixes
    $html = fixhtml($html);

    my $norm_html = $html;
    utf8::decode($html);
    $c->stash->{xsl} = $html;

    utf8::decode($norm_html);
    $norm_html = utf8_to_utf8_de( $norm_html );

    $c->stash->{xsl_norm} = $norm_html;
    $c->res->body(undef);
}

=head2 page_plain

=cut

sub page_plain : Private {
    my ( $self, $c ) = @_;

    my $t2t = DTA::TEI::Text::Transform->new;
    my $plain = $t2t->process({ filename => $c->stash->{xmlfile} });
    $c->stash( plain => $plain );
}

=head2 page_xml

=cut

sub page_xml : Private {
    my ( $self, $c ) = @_;

    my $rawxml = $c->stash->{pagexml};

    # wipe <c>'s
    $rawxml =~ s{(</c>)\s+(<hi )}{$1$2}g;
    $rawxml =~ s{\s+<c }{<c }g;
    $rawxml =~ s{<c(?: [^>]*>|>)(.*?)</c>}{$1}gs;
    $rawxml =~ s/(?:\r?\n)*(<supplied[^>]*>)(?:\r?\n)*/$1/g;
    $rawxml =~ s/(?:\r?\n)*(<\/supplied>)(?:\r?\n)*/$1/g;
    $rawxml =~ s{(</hi>)(?:\r?\n)(<hi)\b}{$1$2}g;

    # remove page number
    $rawxml =~ s{<fw type="page number" place="top">.*?</fw>}{}s;

    $rawxml =~ s{ xmlns="http://www.tei-c.org/ns/1.0"}{};

    # tidy up xml
    my ( $tempfh, $tempname ) = tempfile();
    print $tempfh $rawxml;
    close $tempfh;
    $rawxml = join '' => `xmllint --format --encode utf8 "$tempname"`;
    unlink $tempname;

    $rawxml =~ s{\Q<?xml version="1.0" encoding="utf8"?>\E(?:\r?\n)*}{};
    $rawxml =~ s{\s*<lb/>([^\n])}{<lb/>\n$1}g;
    $rawxml =~ s{<lb/>(?:\r?\n)(<[^>]*>)}{<lb/>$1}g;
    $rawxml =~ s{(<lb/>)(<fw)\b}{$1\n$2}g;
    $rawxml =~ s{\s+<hi}{ <hi}g;
    $rawxml =~ s{</hi>\s+}{</hi> }g;
    $rawxml =~ s{\s+<lb/>}{<lb/>}g;

    my $origxml = $rawxml;
    utf8::decode($origxml);
    $c->stash->{origxml} = $origxml;

    utf8::decode($rawxml);
    $rawxml =~ s{([^\x{01}-\x{ff}])}{sprintf "&#x%04X;", ord($1)}eg;

    $rawxml = DTA::XMLsh::highlight_xml( $rawxml );
    utf8::decode($rawxml);

    $c->stash->{xml} = $rawxml;
}

=head2 page_num

=cut

sub page_num :Private {
    my ( $self, $c ) = @_;
    my $rawxml = $c->stash->{pagexml};

    my ( $num ) = $rawxml =~ m{<pb\b[^>]*n=["'](.*?)["']};
    $c->stash->{page_num} = $num;
}

=head2 cab

=cut

sub cab : Local {
    my ( $self, $c, $id_or_dirname, $page ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );

    my $dirname = $book->dirname;

    our $cab_url     = 'http://data.dwds.de:9099/query';
    our $cab_timeout = 10;

    my $cab_client = DTA::CAB::Client::HTTP->new(
        serverURL   => $cab_url,
        timeout     => $cab_timeout,
        mode        => 'xpost',
        format      => 'tei',
        testConnect =>  0,
    ) or die("$0: could not create CAB client");

    my ($xmlbuf);
    my $infile = sprintf '%s/%s.xml/pages/%s.xml_%04d.xml', $c->config->{xmlrep}, $dirname, $dirname, $page;
    {
        local $/ = undef;
        open( my $in, '<', $infile ) or die("$0: open failed for '$infile': $!");
        $xmlbuf = <$in>;
        close $in or die $!;
    }

    $xmlbuf =~ s{</c>(?:\r?\n)<c }{</c><c }g;

    my $rsp = $cab_client->analyzeDataRef('caberr', \$xmlbuf, { clean => 1} );
    if ( !$rsp ) {
        $c->res->body( format_cab_error(sprintf "CAB client choked on '%s': %s", $infile, $!) );
        return;
    }
    if ( !$rsp->is_success ) {
        $c->res->body( format_cab_error(sprintf "CAB server choked on '%s': %s", $infile, $rsp->as_string) );
        return;
    }

    my $cabxml = $rsp->content;

    utf8::decode($cabxml);
    my $caberr = $c->model('Caberr::Caberr')->search(
        {
            dtaid => $id_or_dirname,
            page  => [ $page, undef ],
        },
        {
            cache => 1,
        },
    );
    my %caberr_tickets;
    while ( my $row = $caberr->next ) {
        next if exists $caberr_tickets{ $row->wold };
        $caberr_tickets{ $row->wold } = $row->errid;
        my $wold = $row->wold;
        my $wnew = $row->wnew;
        my $id   = $row->word;
        $cabxml =~ s{/>\Q$wold\E</w>}{ ticket="$id" wnew="$wnew"/>$wold</w>}g;
    }
    utf8::decode($cabxml);

    my ( $tempfh, $tempname ) = tempfile();
    binmode( $tempfh, ":utf8" );
    print $tempfh $cabxml;
    close $tempfh;

    $c->stash->{xml}      = $tempname;
    $c->stash->{template} = 'dta-cab.xsl';
    $c->stash->{pos}      = $c->req->params->{pos} || 0;
    $c->forward('DTA::View::XSLT');
    unlink $tempname;
    my $html = $c->res->body;

    # some fixes
    $html = fixhtml( $html );

    utf8::decode( $html );
    $c->res->content_type( 'text/html' );
    $c->res->body( $html || ' ' );
}

sub format_cab_error {
    my $str = shift;
    $str = '<pre>' . $str . '</pre>';
}

=head2 coins

@deprecated

=cut

sub coins :Private {
    my ( $self, $c ) = @_;

    my $b = $c->stash->{book};

    my $coins = Metadata::COinS->new;
    $coins->set( 'btitle'  => $b->title )
          ->set( 'title'   => $b->title )
          ->set( 'date'    => $b->dta_pub_date )
          ->set( 'edition' => ($b->dta_auflage || '1. Auflage') );

    if ( $b->dta_pub_location ) {
        $coins->set( 'place' => $b->dta_pub_location );
    }

    if ( $b->dta_pub_verlag ) {
        $coins->set( 'pub' => $b->dta_pub_verlag );
    }

    if ( $b->umfang ) {
        $coins->set( 'tpages' => $b->umfang );
    }

    if ( $b->dta_reihe_titel ) {
        $coins->set( 'series' => $b->dta_reihe_titel );
    }

    if ( $c->stash->{page} ) {
        $coins->set( 'pages' => $c->stash->{page} )
              ->set( 'genre' => 'bookitem' )
              ->set( 'chapter' => 'test' );
    }
    else {
        $coins->set( 'genre' => 'book' );
    }

    my @authors;
    foreach my $i ( 1..3 ) {
        my $field_sur = "autor$i"."_lastname";
        my $field_pre = "autor$i"."_prename";
        last unless $b->$field_sur;
        $coins->set( 'au' => join(' ', $b->$field_pre, $b->$field_sur) );
    }
    $c->stash->{coins} = $coins;
}


=head2 header

=cut

sub header :Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    my $header = $book->extra_header;
    utf8::encode( $header );
    $c->res->content_type( 'text/plain; charset=utf8' );
    $c->res->body( $header );
}

=head2 download_txt

=cut

sub download_txt : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );

    my $out = DTA::TEI::Text::Transform->new( input_filename => $c->config->{xmlrep} . '/' . $book->dirname . '.xml' . '/pages' )->process_dir;

    my $filename = sprintf '%s.txt', $book->dirname;
    $c->res->body( $out );
    $c->res->content_type( 'text/plain; charset=utf-8' );
    $c->res->headers->header( "Content-Disposition" => "attachment; filename=$filename" );
}

=head2 download_text

=cut

sub download_text : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    $c->detach( 'download_txt', [$id_or_dirname] );
}

=head2 download_normxml

=cut

sub download_normxml : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_normxml', [$book] );
}

=head2 download_lemmaxml

=cut

sub download_lemmaxml : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_lemmaxml', [$book] );
}

=head2 download_unicruftxml

=cut

sub download_unicruftxml : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_unicruftxml', [$book] );
}

=head2 download_lingxml

=cut

sub download_lingxml :Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_lingxml', [$book] );
}

=head2 download_xml

=cut

sub download_xml : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_xml', [$book] );
}

=head2 download_tcf

=cut

sub download_tcf : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_tcf', [$book] );
}

=head2 download_fulltcf

=cut

sub download_fulltcf : Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    $c->detach( '/book/common/download_fulltcf', [$book] );
}

=head2 download_html

=cut

sub download_html :Local {
    my ( $self, $c, $id_or_dirname ) = @_;
    my $book = $c->forward( 'validbook', [$id_or_dirname] );
    my $dirname = $book->dirname;

    open( my $cssfile, '<', $c->path_to('root/static/dta.css')."" ) or die $!;
    my $css;
    {
        local $/;
        $css = <$cssfile>;
    }
    close $cssfile;

    my $out = <<"EOT";
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="de" lang="de">
<head>
  <title>DTA</title>
  <meta http-equiv="content-type" content="text/html; charset=UTF-8" />
  <style type="text/css">
    #xsltext { position:relative; font-size:14pt; margin-left:200px; font-family:Georgia,serif; max-width:50em }
    #xsltext hr { color:#666; background:#666; width:15em }
    .page    { margin:20px }
    .pagenum { color:#aaa; font-size:.9em }
  $css

#xsltext h1 { font-size:1.8em }
#xsltext h2 { font-size:1.6em }
#xsltext h3 { font-size:1.4em }
#xsltext h4 { font-size:1.3em }
#xsltext h5 { font-size:1.2em }
#xsltext h6 { font-size:1.1em }

.fw-top, .fw-bottom-sig { opacity:.5 }

p.dta-p { text-indent:2em }
.dta-sp p { text-indent:0 !important }
.dta-p-in-sp-really { padding-top:10px }
.speaker    { font-weight:bold }
.speaker *  { }
.stage      { font-style:italic }
.fr         { font-size:1.1em }
.dta-salute { text-indent:10em }
.dta-closer { text-align:right; margin-right:10em }
.dta-lg     { margin-bottom:10px; margin-top:0 !important; margin-left:2em }
.footnotesep, .footnotesep-long { margin-top:15px }
p           { margin-bottom:10px; margin-top:0 !important }
.dta-figure { opacity:.5 }

.dta-marginal       { position:absolute; width:140px; text-indent:0; background:#fff; padding:0 4px; border:1px solid #D1C5A4; font-size:smaller; z-index:10000 }
.dta-marginal-left  { left:-150px; text-align:right }
.dta-marginal-right { right:-150px; text-align:left }
  </style>
</head>
<body>
<div id="xsltext">
EOT

    $c->stash->{additional_register_function} = [
        {
            uri => 'urn:dta',
            name => 'dirname',
            subref => sub { return $c->stash->{book}->dirname },
        },
        {
            uri => 'urn:dta',
            name => 'source',
            subref => sub { return $c->stash->{book}->source->source },
        },
        {
            uri => 'urn:dta',
            name => 'metapher-ana',
            subref => sub {
                my @anas = split /\s+/ => $_[0];
                @anas = map { s/^#//; $_ } @anas;
                my $epo_file = sprintf('/home/wiegand/dta-xml/dtae/epoetics/%s.txt.xml', $_[1]);
                return unless -e $epo_file;
                my $source = XML::LibXML->load_xml( location => $epo_file );
                my $xpc = XML::LibXML::XPathContext->new;
                $xpc->registerNs( 'tei', 'http://www.tei-c.org/ns/1.0' );

                my @ret;
                foreach my $ana ( @anas ) {
                    my $val = $xpc->findvalue( '//*[@xml:id="' . $ana . '"]', $source );
                    $val =~ s/(?:^\s+|\s+$)//g;
                    push @ret, $val;
                }
                return join "; " => @ret;
            },
        }
    ];

    my @pages;
    foreach my $xmlfile ( glob sprintf '%s/%s.xml/pages/%s.xml_*.xml', $c->config->{xmlrep}, $dirname, $dirname ) {
        open( my $fh, '<:utf8', $xmlfile ) or die $!;
        my $rawxml;
        {
            local $/;
            $rawxml = <$fh>;
        }
        close $fh;

        $rawxml =~ s{(</c>)\s+(<hi )}{$1$2}g;
        $rawxml =~ s{\s+<c }{<c }g;
        $rawxml =~ s{</?c\b[^>]*>}{}g;
        $rawxml =~ s/(?:\r?\n)*(<(?:supplied|corr|sic|orig)[^>]*>)(?:\r?\n)*/$1/g;
        $rawxml =~ s/(?:\r?\n)*(<\/(?:supplied|corr|sic|orig)>)(?:\r?\n)*/$1/g;
        $rawxml =~ s{(?:\r?\n)\s+(</(?:fw|head|l)>)}{$1}g;
        $rawxml =~ s{\s+(?:\r?\n)(<lb/>)}{$1}g;
        $rawxml =~ s{([^>])(?:\r?\n)}{$1}g;
        $rawxml =~ s{\s+(</(?:docAuthor|docDate|item|l|p|pubPlace|titlePart)>)}{$1}g;
        $rawxml =~ s{\s+(<lb/>)}{$1}g;

        $rawxml =~ s/(rendition=")\s*/$1/g;
        $rawxml =~ s/(?:\r?\n)*(<(?:supplied|corr|sic|orig|gap|seg)[^>]*>)(?:\r?\n)*/$1/g;
        $rawxml =~ s/(?:\r?\n)*(<\/(?:supplied|corr|sic|orig|gap|note)>)(?:\r?\n)*/$1/g;
        $rawxml =~ s{(</c></hi>)(?:\r?\n)*(<hi rendition="#(?:c|et|right)"><c )}{$1$2}g;
        $rawxml =~ s{(</hi>)(?:\r?\n)(<hi)\b}{$1$2}g;

        # figure handling
        $rawxml =~ s{(<lb/>)\s+(<figure)\b}{$1$2}g;
        $rawxml =~ s{(</figure>)\s+(<lb/>)}{$1$2}g;
        $rawxml =~ s{(<(?:div|pb|seg)\b[^>]*>)\s*(<figure)\b}{$1<lb/>$2}g;
        $rawxml =~ s{(<figure/>)\s*(<(?:figure|fw|l|head)\b)}{$1<lb/>$2}g;
        $rawxml =~ s{(<figure/>)\s*(</?(?:p|div))\b}{$1<lb/>$2}g;

        # centering formulae
        $rawxml =~ s{
            (<lb/>\s?)
            (
                (?:
                    <formula\s*/>|<formula\b[^>]*>[^<]+</formula>
                )
                (?:
                    [.;,\s]| u\. s\. w\.,?
                )?
            )
            (</(?:p|div|lg|seg|head)>)?
            (<lb/>)
        }{$1<hi rendition="#c">$2</hi>$3}gx;

        # remove page number
        $rawxml =~ s{<fw type="page number" place="top">.*?</fw>}{}s;

        utf8::decode($rawxml);

        my ( $tempfh, $tempname ) = tempfile();
        binmode( $tempfh, ":utf8" );
        print $tempfh $rawxml;
        close $tempfh;

        $c->stash->{xml}      = $tempname;
        $c->stash->{template} = 'dtaq.xsl';
        $c->forward('DTA::View::XSLT');
        unlink $tempname;
        my $html = $c->res->body;
        utf8::decode($html);

        # clean footnote lookup
        %DTA::View::XSLT::fn_seen = ();

        # some fixes
        $html = fixhtml($html);
        push @pages, $html;
    }

    $c->forward( '/book/common/page_number', [$id_or_dirname] );
    my $i = 1;
    foreach my $page ( @pages ) {
        if ( $c->stash->{page_numbers}{ sprintf "%04d", $i } ) {
            $out .= sprintf '<div class="page"><div class="pagenum">|<a href="http://www.deutschestextarchiv.de/%s/%s">%04d : %s</a>|</div>%s</div>', $book->dirname, $i, $i, $c->stash->{page_numbers}{ sprintf "%04d", $i }, $page;
        }
        else {
            $out .= sprintf '<div class="page"><div class="pagenum">|<a href="http://www.deutschestextarchiv.de/%s/%s">%04d</a>|</div>%s</div>', $book->dirname, $i, $i, $page;
        }
        $i++;
    }

    $out .= '</div></body></html>';
    utf8::decode($out);
    $c->res->content_type( 'text/html; charset=utf-8' );
    $c->res->body($out);
    my $filename = sprintf '%s.html', $book->dirname;
    $c->res->headers->header( "Content-Disposition" => "attachment; filename=$filename" );
}

my @mapclass = (
    [qr/\Q+id,+xid,+msafe,+moota,-mootxy\E/ => '', 'identity + TAGH'],                          ##-- ID_SAFE: ?exlex,  +id, +msafe, +moota, +mootsafe
    [qr/\Q-id,+xid,+msafe,+moota,-mootxy\E/ => 'background:#dddddd; color:#00f', 'transliteration + TAGH'], ##-- XID_SAFE: ?exlex, +xid, +msafe, +moota, +mootsafe
    ##
    [qr/\+exlex.*\Q-msafe,+moota,-mootxy\E/ => 'background:#99ff99', 'exlex + TAGH'], ##-- EXLEX_SAFE: +exlex, -msafe, +moota, -mootxy: non-trivial change: safe-ish: exlex
    [qr/\-exlex.*\Q-msafe,+moota,-mootxy\E/ => 'background:#99ffff', 'dmoot + TAGH'], ##-- DMOOT_SAFE: -exlex, -msafe, +moota, -mootxy: non-trivial change: safe-ish: dmootx
    ##
    [qr/\+exlex.*\-moota/ => 'background:#ff6633', 'exlex - TAGH'], ##-- EXLEX_NOMOOT: +exlex, -moota: unknown moot word
    [qr/\-exlex.*\-moota/ => 'background:#ff33ff', 'dmoot - TAGH'], ##-- DMOOT_NOMOOT: -exlex, -moota: unknown moot word
    ##
    [qr/\Q+mootxy\E/ => 'background:#ff0000; color:#ffffff;', 'suspicious POS tag'], ##-- MOOT_XY: -mootsafe: dodgy moot tag
    ##
    [qr/\-id/ => 'background:#ffff99;', 'non-identity, other'], ##-- NOT_XID: -id, other
    [qr/\-xid/ => 'background:#ffcc99;', 'non-transliteration, other'],  ##-- NOT_ID : -xid, other (e.g. andern->andern, Jedem->jedem)
);

sub insert_tag {
    my ( $match, $tag, $pos, $mapclass, $context, $ticket ) = @_;
    my $ins = $match =~ /(<[cl]b\s*\/>)/ ? $1.$tag : $tag;

    my $style = '';
    foreach (@mapclass) {
        if ( $mapclass =~ m/$_->[0]/ ) {
            $style = $_->[1] if ($_->[1]);
            last;
        }
    }

    $ins = sprintf '<cab tag="%s" mapclass="%s" wold="%s" wnew="%s" context="%s" ticket="%s" style="%s">%s</cab>',
        escape_xml( $pos ),
        escape_xml( $mapclass ),
        escape_xml( $match ),
        escape_xml( $ins ),
        escape_xml( $context ),
        $ticket || '',
        $style,
        $ins;
    return $ins;
}

sub escape_xml {
    my $str = shift;
    for ( $str ) {
        s/<lb\s*\/>/\n/g;
        s/&/&amp;/g;
        s/</&lt;/g;
        s/>/&gt;/g;
        s/"/&quot;/g;
        s/'/&apos;/g;
        s/\A\s*|\s*\z//g;
    }
    return $str;
}

sub fixhtml {
    my $str = shift || '';
#    utf8::decode($str);

    for ( $str ) {
        s{(<(?:div|p)[^>]*>)\s+}{$1}g;
        s{(<br(?: ?/)?>)\s+}{$1}g;
        s{</(div|p|h[1-6])>\s*(?:<br(?: ?/)?>)?\s*<((?:div|p|h[1-6])[^>]*)>}{</$1><$2>}g;
        s{(<br(?: ?/)?>)+}{<br />}g;
        s{(</(?:div|p|table|ul)>)<br(?: ?/)?>}{$1}g;
        s{(span\s+class="fn-sign">[^<]*</span>)\s*<br(?: ?/)?>\s*}{$1 }g;
        s{(<span[^>]*>)(<br(?:\s*/)?>)}{$2$1}g;
        s{(<span class="(?:g\s*|\s*g|\s*g\s*)">)(.*?)(</span>)(<[^>]+>)?([^<])}{ $1 . fix_emphasis( $2, $3, $4, $5 )  }egs;

        # move footnote sign into the first <p> of the fn
        s{(<div class="footnote">)(<span class="fn-sign">[^<]*</span>\s*)(<p class="dta-p">)}{$1$3$2}g;
    }

#    utf8::encode($str);
    return $str;
}

sub fix_emphasis {
    my ( $em, $closing_span, $next_tag, $next_char ) = @_;
    no warnings 'uninitialized';
    my $ret = $em . $closing_span . $next_tag . $next_char;
    if ( $em =~ /(.*)(.)(?:<[^>]+>)?$/s && $3 ) {
        my ( $em_start, $em_last, $em_close ) = ( $1, $2, $3 );
        if ( $next_char =~ /[.,;:?!]/ ) {
            $ret = $em_start . $em_close . $closing_span . $em_last . $next_tag . $next_char;
        }
    }
    return $ret;
}

sub denied_license :Local {
    my ( $self, $c ) = @_;
    $c->stash( template => 'common/denied_license.tt' );
    $c->res->status( 402 );
}

__PACKAGE__->meta->make_immutable;

1;
__END__

=head1 AUTHOR

Frank Wiegand

=head1 LICENSE

This library is free software. You can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
