# -*- mode: perl; coding: utf-8 -*-

=head1 NAME

A2E::NewsTmplfil

=cut

package A2E::NewsTmplfil;

=head1 DESCRIPTION

Generate an RSS file for a given channel(s), language(s) and timeframe, using a given output template
that uses either the RSS format or any kind of equivalent thereof, based on date read from tables in
a database whose structure is to some extent configurable.

=head1 BUGS

Report to adv@a2e.de

=head1 VERSION

our $VERSION = '0.0.2';

=head1 PREREQUISITES

=over

=item A2E::Dokfs(3)

=cut

use base 'A2E::MLDK';
use strict;
use File::Spec::Functions;
use POSIX qw(strftime);

=item Template(3)

=cut

$Template::BINMODE = ':utf8';use Template;
use A2E::Template::Provider;
use Template::Config;
# $Template::Config::Provider = 'A2E::Template::Provider';
=item A2E::SArb::Make(3)

The workhorse of make-like macro expansion in lexical source files.

=cut

use A2E::SArb::Make;
use Encode qw(_utf8_on);

=back

=head1 OPTIONS

The options of the prerequisite library A2E::Prog(3) are also available here.

=cut

sub news_tmplfil_defvars {
    my ($m,$prog,$lihs)= shift->qpuc('news_tmplfil_defvars',@_);
    return $m->dpop($prog) if $m->{ready}->{$prog};
=over

=item --kanal0

default channel from which title and description info is taken when no more specific info is available.

=cut

    $m->{konfig}->define('kanal0=s', { DEFAULT => 'a2e_sig' });

=item --news_babylon

also print links to news items that are not available in the native language

=cut

    $m->{konfig}->define('news_babylon!');

=item --lang de

print only news document references that are available in this language
This variable is inherited from a parent library but has a special meaning here.



=back

=head1 CONFIGURATION FILE

The 

	/etc/opt/a2e/news_tmplfil.konf
	~/news_tmplfil.konf
	@news_tmplfil

are read.  Moreover configuration files of the prerequisite libraries are inherited.

=cut

    $m->konfayl('news_tmplfil.konf');
    $m->qpop1($prog, 1);
}

=head1 IMPLEMENTATION

With administrator-servicable internal configuration possibilities.

=head2 Internal Constants

=cut

our $PERMIT_EVAL_PERL = 0;

=head2 Overwritable Functions

The bulk of each function is forked out into a non-overwritable variant used for mix-in applications such as mlht(1)

=head3 Function defvars and forkout news_tmplfil_defvars

=cut

sub defvars {
    my ($m,$prog,$lihs) = shift->qpuc('A2E::NewsTmplfil::defvars',@_);$lihs = $m->get_lihs($lihs);
    $m->{progver} ||= '0.0.1';
    $m->SUPER::defvars($lihs);
    $m->news_tmplfil_defvars($lihs);
    $m->qpop1($prog,1);
};


=head3 Function news_tmplfil_postkonfig

Here the work of reading makefiles into template variables is done.  Any application that inherits this library will have the template variables read in, based on configuration and commandline options, before the main program starts.

=cut

sub news_tmplfil_postkonfig {
    my ($m,$prog,$lihs) = shift->qlpuc('news_tmplfil_postkonfig',@_) or return;
    $m->{cache}->{tmplopts}->{DEBUG} = $m->{DEBUG};
    $m->{cache}->{tmplopts}->{EVAL_PERL} = 0 unless $PERMIT_EVAL_PERL;
    $m->{template} = new Template $m->{cache}->{tmplopts};
  TMPLOPTS_DEBUG: {
      last if ref $m->{template} eq 'Template';
      use Data::Dumper;
      $m->uwarn('failed with tmplopts %O', $m->{cache}->{tmplopts});
      $m->{template} = new Template;
      $m->ustop('invalid template %t', t => ref($m->{template})) unless 'Template' eq ref $m->{template};
    };
    $m->set_dok($lihs);
    my @langs = $m->set_langs;
    my $lang = $m->pvar('lang') || $m->{konfig}->lang;
    $lang = $langs[0] unless $lang and grep { $_ eq $lang } @langs;
    $m->mldk('lits');
    $m->qpop1($prog,1);
};

=head3 Function postkonfig

Wrapper around news_tmplfil_postkonfig for automatic use in A2E::Prog::new_ready constructor mechanism.

=cut

sub postkonfig {
    my ($m,$prog,$lihs) = shift->qpuc('A2E::NewsTmplfil::postkonfig',@_);$lihs = $m->get_lihs($lihs);
    $m->SUPER::postkonfig($lihs);
    $m->news_tmplfil_postkonfig($lihs);
    $m->dpop1($prog,1);
};

=head2 Top level functions

=head3 Function subkanals

recursively find all subchannels of a channel, return a list with the ancestor channel at the beginning and the descendants at the end.

Function kanal_doks uses this to build a search expression that collects newsitems.
The channel-subchannel relation is expressed in the database table C<kanal> with C<supkanal> being the ancestor of C<kanal>, much the same way in which a dokprop.predok is an ancestor of a dok.

=cut

sub subkanals {
    my ($m,$prog,$kanal) = shift->ppuc('subkanals',@_);
    my @subkanals = ();
    push @subkanals, $kanal;
    my @reks = $m->get_records('kanal', { supkanal => $kanal }, 'kanal');
    foreach my $rek (@reks) { my ($kanal) = @$rek;next unless $kanal;push @subkanals, $m->subkanals($kanal); }
    $m->dpop($prog,@subkanals);
};

=head3 Function kanal_doks

list of hashrefs regarding documents of one channel.

=cut

sub kanal_doks {
    my ($m,$prog,$kanal) = shift->ppuc('kanal_doks',@_);
    my $lang = $m->pvar('lang');
    my $news_start = $m->{konfig}->news_starts->{$kanal} || $m->{konfig}->news_start;
    my $news_stop = $m->{konfig}->news_stops->{$kanal} || $m->{konfig}->news_stop;
    my $news_limit = $m->{konfig}->news_limits->{$kanal} || $m->{konfig}->news_limit;
    my $news_level = $m->{konfig}->news_levels->{$kanal} || $m->{konfig}->news_level;
    $m->dgot(news_start => $news_start, news_stop => $news_stop, news_limit => $news_limit, news_level => $news_level);
    my %keys = ();
    my @subkanals = $m->subkanals($kanal);
    die 'no subkanals found' unless @subkanals;
    $keys{gravrank} = [ '>=', $news_level ];
    $keys{kanal} = [ 'in', @subkanals ];
    $m->{tmplvars}->{smprior_min} ||= $m->{konfig}->smprior_min || do { $m->uwarn('smprior_min not set');0.5; };
    $keys{smprior} = [ '>=', $m->tmplvars_getstr('smprior_min') ];
    my $start = $news_start;
    my $dat2num = sub { my $dat = shift;my ($a, $m, $d) = $dat =~ m(\A(\d{4})\-(\d{2})\-(\d{2})\Z);return unless $d;my $num = $a . $m . $d;return $num };
    my $hodie = $m->pvar('hodie');
    my $hodienum = &$dat2num($hodie);
    $m->pstop('no hodienum found for hodie %h', h => $hodie) unless $hodienum;
    $start = $hodie if !$news_start or &$dat2num($news_start) < $hodienum;
    my $stop = $news_stop;
    $keys{dokdatum} = $stop ? [ '<=..<', $start, $stop ] : [ '>=', $start ];
    $m->dgot(start => $start, stop => $stop, m_hodie => $hodie, hodienum => $hodienum); 
    my @ont_reks = $m->get_records([ 'kanaldok', 'dokprop' ], \%keys, [ 'dok', 'dokdatum', 'gravrank' ], order => 'dokdatum asc', limit => $news_limit);
    $start = $news_start;
    $stop = $hodie if !$news_stop or &$dat2num($news_stop) > $hodienum;
    $keys{dokdatum} = $start ? [ '<=..<', $start, $stop ] : [ '<', $stop ];
    my @int_reks = $m->get_records([ 'kanaldok', 'dokprop' ], \%keys, [ 'dok', 'dokdatum', 'gravrank' ], order => 'dokdatum desc', limit => $news_limit);
    my @doks = ();
    my $i = 0;
    # my $mm = strftime '%m', @{$m->{progtime}};
    # my $YY = strftime '%Y', @{$m->{progtime}};
    push @ont_reks, undef if @ont_reks and @int_reks;
    foreach my $rek (@ont_reks, @int_reks) {
	last if $news_limit and $i >= $news_limit;
	$m->dpuc('rek'.$i, $rek);
	do { push @doks, {};$m->dpop;next } unless $rek; 
	my $reklang = $lang;
	my @flds = @$rek;
	my $dok = shift @flds;
	do { $m->dpop;next } unless $dok;
	my $dat = shift @flds;
	do { $m->dpop;next } unless $dat;
	my $gra = shift @flds || 3;
	my $rektabs = {};
	$rektabs->{tit} = {};
	$rektabs->{des} = {};
	my %mlid2tag = ( title => 'tit', descr => 'des' );
	foreach my $mlid (qw(title descr)) {
	    my @reks = $m->get_records('langtxts', { dok => $dok, mlid => $mlid }, 'lang', 'mltxt');
	    my $tag = $mlid2tag{$mlid};
	    foreach my $rek (@reks) { 
		my ($ll, $txt) = @$rek;
		$rektabs->{$tag}->{$ll} = $txt;
	    };
	};
	my %mltxt = ();
	$mltxt{$_} = $rektabs->{$_}->{$lang} for qw(tit des);
	$m->dgot(mltxt => \%mltxt, rektabs => $rektabs);
	$m->vecho('no title found for document %d language %l', d => $dok, l => $lang) unless $mltxt{tit};
	$m->vecho('no descr found for document %d language %l', d => $dok, l => $lang) unless $mltxt{des};
	do { $m->dpop;next } unless $mltxt{tit} or $m->{konfig}->news_babylon;
	my @langs = $m->plst('langs');
	$reklang = $langs[0];
      BABYLON: foreach my $tag (qw(tit des)) {
	  next if $mltxt{$tag};
	  $mltxt{$tag} = $rektabs->{$tag}->{$reklang};
	  next if $mltxt{$tag};
	  while (($reklang, $mltxt{$tag}) = each %{$rektabs->{$tag}}) { last if $mltxt{$tag} };
      };
	do { $m->dpop;$m->uwarn('no title whatsoever found for document %d, skip', d => $dok);next } unless $mltxt{tit};
	my ($url, $relurl) = $m->dokurls($dok);
	do { $m->dpop;next } unless $relurl;
	my $doktags = { id => $dok, dat => $dat, tit => $mltxt{tit}, des => $mltxt{des}, url => $url, relurl => $relurl };
	$doktags->{lang} = $reklang unless $reklang eq $lang;
	push @doks, $doktags;
	$m->dpop('rek'.$i, $doktags);
	$i++;
    };
    $m->dpop($prog,@doks);
};

=head3 Function news_tmplfil

Process all templates supplied through the infaylz option and the [commandline] arguments.

=cut

sub kanal_titdesurlrss {
    my ($m,$prog,$kanal) = shift->ppuc('kanal_titdesurlrss',@_);
    my ($nom, $tit, $des, $url, $relurl, $rss, $dok) = ();
  TIT: {
      $nom = $m->{konfig}->news_titles->{$kanal} || sprintf($m->{konfig}->news_title_varfnom, $kanal);
      die sprintf 'no variable found for title of channel %k', k => $kanal unless $nom;
      $tit = $m->tmplvars_getstr($nom);
      last if $tit;
      $m->uwarn('empty title variable %n', n => $nom);
      $nom = $m->{konfig}->news_title_varnom0;
      $m->ustop('no variable found for title, not even a generic one') unless $nom;
      $tit = $m->tmplvars_getstr($nom);
      last if $tit;
      $m->ustop('empty title variable %n', n => $nom);
    };
  DES: {
      $nom = $m->{konfig}->news_descrs->{$kanal} || sprintf $m->{konfig}->news_descr_varfnom, $kanal;
      $m->ustop('no variable found for description of news channel %k', k => $kanal) unless $nom;
      $des = $m->tmplvars_getstr($nom);
      last if $des;
      $m->vecho('empty descr variable %n, falling back to title', n => $nom);
      $des = $tit;
    };
  URL: {
      $dok = $m->{konfig}->news_doks->{$kanal} || $kanal;
      ($url, $relurl) = $m->dokurls($dok);
      last if $url;
      $m->uwarn('no url found for channel %k, skipping', k => $kanal);
    };
  RSS: {
      $rss = sprintf $m->{konfig}->rss_fnom, $kanal, $m->pvar('lang');
      my $dir = $m->dok2relurl($kanal);
      last unless $dir;
      $rss = catfile $dir, $rss;
    };
    my $data = { tit => $tit, des => $des, url => $url, relurl => $relurl, rss => $rss };
    $m->dpop1($prog,$data);
}

sub news_tmplfil {
    my ($m,$prog,@faylz) = shift->ppuc('news_tmplfil',@_);
    my $lihs = $m->get_lihs;
    $m->{konfig}->infaylz($_) for @faylz;
    my @getkanals = split m([\W]), $m->{konfig}->getkanals;
    $m->set_dok;
    $m->init_navdoks;
    @getkanals = ($m->pvar('dok'), $m->pvar('topdok')) unless @getkanals;
    $m->defarb($lihs, '@', 'kanals', []);
    $lihs->putstr(lang => $m->pvar('lang'));
    $lihs->putstr(url => $m->pvar('url'));
    my $kanal0 = $m->{konfig}->kanal0;
    my @doks = ();
  KANAL: foreach my $kanalnom (@getkanals) {
      $m->dpuc('kanal', $kanalnom);
      my $kanalhac = $m->kanal_titdesurlrss($kanalnom);
      next KANAL unless $kanalhac->{url}; 
    DOKS: {
	@doks = $m->kanal_doks($kanalnom);
	last if @doks;
	$m->vecho('no doks found for channel %k, skipping', k => $kanalnom);$m->dpop;next KANAL;
      };
      $kanalhac->{doks} = [ @doks ];
      $m->lstpucl(kanals => $kanalhac);
      $m->dpop('kanal', $kanalhac);
  };
    $m->tmplfil1($_) for @{$m->{konfig}->infaylz};
    $m->dpop1($prog,1);
};

=head1 TODO

mostly done, see dok:rss090314

=cut

1;

# Local Variables:
# coding: utf-8
# srcfile: /adv/perl/A2E/NewsTmplfil.pm
# mode: perl
# End: