# Copyrights 2003-2018 by [Mark Overmeer <markov@cpan.org>].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of distribution HTML-FromMail. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package HTML::FromMail;
use vars '$VERSION';
$VERSION = '0.12';
use base 'Mail::Reporter';
use strict;
use warnings;
use File::Spec::Functions;
use File::Basename qw/basename dirname/;
my %default_producers = # classes will be compiled automatically when used
( 'Mail::Message' => 'HTML::FromMail::Message'
, 'Mail::Message::Head' => 'HTML::FromMail::Head'
, 'Mail::Message::Field' => 'HTML::FromMail::Field'
);
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args) or return;
# Defining the formatter to be used
my $form = $args->{formatter} || {};
if(!ref $form)
{ eval "require $form";
die "ERROR: Formatter $form can not be used:\n$@" if $@;
$form = $form->new;
}
elsif(ref $form eq 'HASH')
{ require HTML::FromMail::Format::OODoc;
$form = HTML::FromMail::Format::OODoc->new(%$form);
}
die "ERROR: Formatter $form could not be instantiated\n"
unless defined $form;
$self->{HF_formatter} = $form;
# Defining the producers
my %prod = %default_producers; # copy
my $prod = $args->{producers} || {};
@prod{ keys %$prod } = values %$prod;
while( my($class, $impl) = each %prod)
{ $self->producer($class, $impl);
}
# Collect the settings
my $settings = $args->{settings} || {};
while( my ($topic, $defaults) = each %$settings)
{ $self->settings($topic, $defaults);
}
$self->{HF_templates} = $args->{templates} || '.';
$self;
}
sub formatter() { shift->{HF_formatter} }
sub producer($;$)
{ my ($self, $thing) = (shift, shift);
my $class = ref $thing || $thing;
return ($self->{HF_producer}{$class} = shift) if @_;
if(my $prod = $self->{HF_producer}{$class})
{ eval "require $prod";
return $prod->new unless $@;
$self->log(ERROR => "Cannot use $prod for $class:\n$@");
return undef;
}
# Look for producer in the inheritance structure
no strict 'refs';
foreach ( @{"$class\::ISA"} )
{ my $prod = $self->producer($_);
return $prod if defined $prod;
}
undef;
}
sub templates(;$)
{ my $self = shift;
return $self->{HF_templates} unless @_;
my $topic = ref $_[0] ? shift->topic : shift;
my $templates= $self->{HF_templates};
my $filename = catfile($templates, $topic);
return $filename if -f $filename;
my $dirname = catdir($templates, $topic);
return $dirname if -d $dirname;
$self->log(ERROR =>
"Cannot find template file or directory '$topic' in '$templates'.\n");
undef;
}
sub settings($;@)
{ my $self = shift;
my $topic = ref $_[0] ? shift->topic : shift;
return $self->{HF_settings}{$topic} unless @_;
$self->{HF_settings}{$topic} = @_ == 1 ? shift : { @_ };
}
sub export($@)
{ my ($self, $object, %args) = @_;
my $producer = $self->producer($object);
$self->log(ERROR => "No producer for ",ref($object), " objects."), return
unless defined $producer;
my $output = $args{output};
$self->log(ERROR => "No output directory or file specified."), return
unless defined $output;
# this cannot be right when $output isa filename?
# $self->log(ERROR => "Cannot create output directory $output: $!"), return
# unless -d $output || mkdir $output;
my $topic = $producer->topic;
my @files;
if(my $input = $args{use})
{ # some template files are explicitly named
my $templates = $self->templates;
foreach my $in (ref $input ? @$input : $input)
{ my $fn = file_name_is_absolute($in) ? $in
: catfile($templates, $in);
$self->log(WARNING => "No template file $fn"), next
unless -f $fn;
push @files, $fn;
}
}
else
{ my $templates = $self->templates($topic);
$self->log(WARNING => "No templates for $topic objects."), return
unless defined $templates;
@files = $self->expandFiles($templates);
$self->log(WARNING => "No templates found in $templates directory.")
unless @files;
}
my $formatter = $self->formatter(settings => $self->{HF_settings});
my @outfiles;
foreach my $infile (@files)
{ my $basename = basename $infile;
my $outfile = catfile($output, $basename);
push @outfiles, $outfile;
$formatter->export
( %args
, object => $object, input => $infile
, producer => $producer, formatter => $formatter
, output => $outfile, outdir => $output
, main => $self
);
}
$outfiles[0];
}
sub expandFiles($)
{ my ($self, $thing) = @_;
return @$thing if ref $thing eq 'ARRAY';
return $thing if -f $thing;
$self->log(WARNING => "Cannot find $thing"), return ()
unless -d $thing;
$self->log(ERROR => "Cannot read from directory $thing: $!"), return ()
unless opendir DIR, $thing;
my @files;
while(my $item = readdir DIR)
{ next if $item eq '.' || $item eq '..';
my $full = catfile $thing, $item;
if(-f $full)
{ push @files, $full;
next;
}
$full = catdir $thing, $item;
if(-d $full)
{ push @files, $self->expandFiles($full);
next;
}
$self->log(WARNING =>
"Skipping $full, which is neither file or directory.");
}
closedir DIR;
@files;
}
1;