#!/usr/bin/perl

our $VERSION = '0.0.1';
use strict;
use warnings FATAL => qw(all);
use utf8;
use open qw/:std :utf8/;
require Data::Dumper;
require Encode;
use     Fcntl ':mode';
require File::Basename;
require File::Copy;
require File::Path;
require File::Spec;
require Getopt::Long;
require Image::Magick;
require Pod::Usage;
#require XML::Generator;
require HTML::HTML5::Builder;
use List::MoreUtils qw(uniq);
require CGI;

our $debug;

sub run($@) {
	print STDERR "run: @_\n";
	my $pid = open my $OUT, "-|";
	die "ERROR: run(): cannot fork: $!"
		if not defined $pid;
	if (not $pid) {
		# Exécution dans le fils
		exec @_
			or die "ERROR: run(): cannot exec: @_: $!";
	 }
	# Exécution dans le parent
	return $OUT;
 }
sub tee ($@) {
	my $file = shift;
	print STDERR "tee: @_\n"
		if $debug;
	open(my $handle, '>', $file)
		or die "open(>, $file)";
	binmode($handle, ":utf8");
	print $handle @_;
	close($handle)
		or die "close $file";
	return @_;
 }

sub build_image ($$$) {
	my ($env, $indexes, $item) = @_;
	my $src_img = $item->{src_img};
	my $dst_quality_name    = "$item->{src_name}.quality-$env->{quality}$item->{src_ext}";
	my $dst_quality_path    = File::Spec->catfile($item->{dst_dir}, $dst_quality_name);
	my $dst_quality_mtime   = -f $dst_quality_path ? (CORE::stat(_))[9] : undef;
	my $dst_thumbnail_name  = "$item->{src_name}.thumbnail-$env->{thumbnail}$item->{src_ext}";
	my $dst_thumbnail_path  = File::Spec->catfile($item->{dst_dir}, $dst_thumbnail_name);
	my $dst_thumbnail_mtime = -f $dst_thumbnail_path ? (CORE::stat(_))[9] : undef;
	my $build_thumbnail = (not defined $dst_thumbnail_mtime or $dst_thumbnail_mtime <= $item->{src_mtime});
	my $build_quality   = (not defined $dst_quality_mtime   or $dst_quality_mtime   <= $item->{src_mtime});
	my $read = ((not $env->{fast}) or $build_thumbnail or $build_quality);
	my $comment;
	if ($read) {
		$_ = $src_img->Read($item->{src_path});
		warn "$_" if "$_";
		$comment = $src_img->Get('format', '%c');
		$comment = Encode::decode('utf8', $comment)
			if $comment;
		print STDERR "INFO: build_image(): comment: $comment\n"
			if $comment;
	 }
	if ($build_thumbnail) {
		print STDERR ("INFO: build_image(): ", $dst_thumbnail_path, "\n");
		my $dst_thumbnail_img = $src_img->Clone();
		$dst_thumbnail_img->Thumbnail(geometry => $env->{thumbnail});
		$dst_thumbnail_img->Set(comment => $comment)
			if $comment;
		$dst_thumbnail_img->Write($dst_thumbnail_path);
	 }
	if ($build_quality) {
		print STDERR ("INFO: build_image(): ", $dst_quality_path, "\n");
		my $dst_quality_img = $src_img;#->Clone();
		$dst_quality_img->Set(comment => $comment)
			if $comment;
		$dst_quality_img->Set(quality => $env->{quality});
		$dst_quality_img->Write($dst_quality_path);
	 }
	return
	 sub {
		my ($pdirs, $ndirs) = @_;
		return
		 { comment => $comment
		 , quality_url   => File::Spec->catfile(map {CGI::escape($_)} (@$ndirs, $dst_quality_name))
		 , thumbnail_url => File::Spec->catfile(map {CGI::escape($_)} (@$ndirs, $dst_thumbnail_name))
		 };
	 };
 }
sub build_video_poster ($$) {
	my ($item, $dst) = @_;
	my $dst_mtime = -f $dst ? (CORE::stat(_))[9] : undef;
	my $build = (not defined $dst_mtime or $dst_mtime <= $item->{src_mtime});
	if ($build) {
		run('ffmpeg'
		 , '-i', $item->{src_path}
		 , '-an'
		 , '-aspect', '16:9'
		 , '-f', 'mjpeg'
		 , '-r', '1'
		 , '-ss', '00:00:00'
		 , '-frames:v', '1'
		 , '-y'
		 , $dst
		 );
	 }
 }
sub build_video ($$$) {
	my ($env, $indexes, $item) = @_;
	my $dst_poster_name = "$item->{src_name}.poster.jpg";
	my $dst_video_name  = "$item->{src_name}$item->{src_ext}";
	my $dst_poster_path = File::Spec->catfile($env->{outdir}, $item->{src_dir}, $dst_poster_name);
	my $dst_video_path  = File::Spec->catfile($env->{outdir}, $item->{src_path});
	#build_video_poster($item, $dst_poster_path);
	my $dst_video_mtime = -f $dst_video_path ? (CORE::stat(_))[9] : undef;
	my $build_video = (not defined $dst_video_mtime or $dst_video_mtime <= $item->{src_mtime});
	if ($build_video) {
		File::Copy::copy($item->{src_path}, $dst_video_path)
			or die "ERROR: copy(): $item->{src_path} -> $dst_video_path: $!";
	 }
	return
	 sub {
		my ($pdirs, $ndirs) = @_;
		return
		 { poster_url => File::Spec->catfile(map {CGI::escape($_)} (@$ndirs, $dst_poster_name))
		 , video_url  => ($env->{video_url_prefix}
			             ? $env->{video_url_prefix} . File::Spec->catfile(map {CGI::escape($_)} (@$pdirs, @$ndirs, $dst_video_name))
			             : File::Spec->catfile(map {CGI::escape($_)} (@$ndirs, $dst_video_name)))
		 };
	 };
 }
sub build_content ($) {
	my ($env) = @_;
	my $src_img = Image::Magick->new;
	my $indexes = {};
	my $item =
	 { src_img => $src_img
	 };
	foreach my $src_path (@{$env->{src}}) {
		print STDERR ("INFO: build_content(): ", $src_path, "\n");
		my ($src_name, $src_dir, $src_ext) = File::Basename::fileparse($src_path, qr/\.[^.]*/);
		@{$item->{src_img}} = ();
		$item->{src_path}   = $src_path;
		$item->{src_name}   = $src_name;
		$item->{src_dir}    = $src_dir;
		$item->{src_ext}    = $src_ext;
		$item->{src_mtime}  = (CORE::stat($src_path))[9];
		$item->{dst_dir}    = File::Spec->catdir($env->{outdir}, $src_dir);
		File::Path::mkpath($item->{dst_dir});
		my %mime_types =
		 ( '.mp4'  => 'video/mp4'
		 , '.webm' => 'video/webm'
		 );
		my $mime_type =
		 exists $mime_types{lc $src_ext}
		 ? $mime_types{lc $src_ext}
		 : "image/";
		my $sub;
		if ($mime_type =~ m{^video/}) {
			$sub = build_video($env, $indexes, $item);
		 }
		else {
			$sub = build_image($env, $indexes, $item);
		 }
		my @pdirs = grep { $_ ne '' } File::Spec->splitdir($src_dir);
		my @ndirs = ('.');
		while (@pdirs) {
			my $key = File::Spec->catdir(@pdirs);
			$indexes->{$key} =
			 { depth => scalar @pdirs
			 , dst => []
			 , dir_ids => {}
			 , dir_id => ''
			 , toc => []
			 } unless exists $indexes->{$key};
			my $idx = $indexes->{$key};
			my $dir_id = join('|', map {my $s; ($s = $_) =~ s/[^a-zA-Z0-9_-]/_/g; CGI::escape($s)} (@ndirs[0 .. @ndirs - 2]));
			#print Data::Dumper::Dumper(\%dir_ids);
			#print Data::Dumper::Dumper({dir_id => $dir_id});
			if ($dir_id ne $idx->{dir_id}) {
				while (exists $idx->{dir_ids}{$dir_id}) {
					$idx->{dir_ids}{$dir_id}++;
					$dir_id = $dir_id.'-'.$idx->{dir_ids}{$dir_id};
				 }
				$idx->{dir_ids}{$dir_id}++;
				$idx->{dir_id} = $dir_id;
			 }
			#print Data::Dumper::Dumper({dir_id => $dir_id, dir_id=> $idx->{dir_id}});
			push @{$idx->{dst}},
			 { mime_type => $mime_type
			 , dir_id => $dir_id
			 , id => join('|', map {CGI::escape($_)} (@ndirs[0 .. @ndirs - 2], $src_name.$src_ext))
			 , dir => [@ndirs[0 .. @ndirs - 2]]
			 , %{$sub->(\@pdirs, \@ndirs)}
			 };
			for (my $i = 0; $i < @ndirs - 1; $i++) {
				my @path = @ndirs[0 .. $i];
				my $dir = File::Spec->catdir(@path);
				push @{$idx->{toc}},
				 { dir => $dir
				 , url => File::Spec->catdir(map {CGI::escape($_)} @path)
				 } unless not length $dir
				 or grep { $_->{dir} eq $dir } @{$idx->{toc}};
			 }
			unshift @ndirs, (pop @pdirs);
		 }
		undef $sub;
	 };
	return $indexes;
 }
sub build_toc ($$$) {
	my ($env, $gen, $idx) = @_;
	return
	 ( (scalar @{$idx->{toc}} or $idx->{depth} > 1)
	 ? ( $gen->ul
			 ( -id => "toc"
			 , map
				 {
					$gen->li
					 ( $gen->a
						 ( -href => $_->{url}.'/'.'index.html'
						 , $_->{dir}
						 )
					 )
				 }
				 ( ($idx->{depth} > 1 ? {dir=>'..', url=>'..'} : ())
				 , @{$idx->{toc}} )
			 )
		 , $gen->hr()
		 )
	 : ()
	 );
 }
sub build_index ($$) {
	my ($env, $indexes) = @_;
	print STDERR Data::Dumper::Dumper($indexes)
		if $debug;
	my $gen =
		#XML::Generator->new
		# ( conformance => 'strict'
		# , dtd         => ['html', 'PUBLIC', '-//W3C//DTD XHTML 1.0 Transitional//EN', 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']
		# , empty       => 'self'
		# , encoding    => 'UTF-8'
		# , escape      => 'always'
		# , namespace   => ['http://www.w3.org/1999/xhtml']
		# , pretty      => "\t"
		# )
		HTML::HTML5::Builder->new
	 ;
	while (my ($dir, $idx) = each %$indexes) {
		my $dst_index = File::Spec->catfile($env->{outdir}, $dir, 'index.html');
		print STDERR ("INFO: build_index(): ", $dst_index, "\n");
		my $title = $env->{title} ? $env->{title} : $dir;
		my $dirname = "";
		tee
		 ( $dst_index
		 , $gen->html
			 ( $gen->head
				 ( $gen->title($title)
				 , $gen->link
					 ( -rel => "stylesheet"
					 , -type => "text/css"
					 , -href => ("../" x ($idx->{depth} - 1)) . "webimg.css"
					 )
				 , $gen->link
					 ( -rel => "shortcut icon"
					 , -type => "image/x-icon"
					 , -href => ("../" x $idx->{depth}) . "webimg.ico"
					 )
				 , $gen->meta
					 ( "-http-equiv" => "Content-Type"
					 , -content => "text/html; charset=utf-8"
					 )
				 )
			 , $gen->body
				 ( build_toc($env, $gen, $idx)
				 , $gen->ul
					 ( -id => "content"
					 , map
						 {
							my $dir_id = $_->{dir_id};
							my @content = ();
							if ($_->{mime_type} =~ m{^video/}) {
								my ($width, $height) = ($env->{thumbnail} =~ m/^([0-9]*)x([0-9]*)/);
								unshift @content, $gen->video
								 ( '-controls' => undef
								 #, -poster => $_->{poster_url}
								 , ($height ? (-height => $height) : ())
								 , ($width  ? (-width  => $width ) : ())
								 #, -preload => "none"
								 , $gen->source
									 ( -src  => $_->{video_url}
									 , -type => $_->{mime_type}
									 )
								 , $gen->p
									 ( -class => "warning"
									 , "Your browser does not support HTML5 video."
									 )
								 )
							 }
							else {
								unshift @content, $gen->a
								 ( -href => $_->{quality_url}
								 , $gen->img
									 ( -src => $_->{thumbnail_url}
									 , ($_->{comment} ?
										 ( -alt   => $_->{comment}
										 , -title => $_->{comment}
										 ) : ())
									 )
								 )
							 }
							my @item = $gen->li
							 ( -class => $_->{mime_type}
							 , -id => $_->{id}
							 , @content
							 );
							if ($dirname ne File::Spec->catdir(@{$_->{dir}})) {
								$dirname = File::Spec->catdir(@{$_->{dir}});
								my @dirs = ();
								unshift @item, $gen->li
								 ( -class => "dir"
								 , -id => $dir_id
								 , $gen->span
									 ( map {
											push @dirs, $_;
											( $gen->a
											 ( -href => File::Spec->catfile(map {CGI::escape($_)} @dirs, 'index.html')
											 , $_
											 )
											, $gen->a
											 ( -href => '#'.$dir_id
											 , '/'
											 )
											)
										 } (scalar @{$_->{dir}} ? @{$_->{dir}} : ('.'))
									 )
								 );
							 }
							@item
						 }
						 @{$idx->{dst}}
					 )
				 )
			 )
		 );
	 }
 }
sub build_css ($) {
	my ($env) = @_;
	my @dst_dirs = uniq (map { my ($x) = File::Spec->splitdir($_); $x } @{$env->{src}});
	foreach my $dst_dir (@dst_dirs) {
		File::Path::mkpath(File::Spec->catdir($env->{outdir}, $dst_dir));
		my $src = File::Spec->catfile(File::Basename::dirname(__FILE__), 'webimg.css');
		my $dst = File::Spec->catfile($env->{outdir}, $dst_dir, 'webimg.css');
		print STDERR ("INFO: build_css(): ", $dst, "\n");
		File::Copy::copy($src, $dst)
			or die "ERROR: copy(): $src -> $dst: $!";
	 }
 }
sub build_ico ($) {
	my ($env) = @_;
	my $src = File::Spec->catfile(File::Basename::dirname(__FILE__), 'webimg.ico');
	my $dst = File::Spec->catfile($env->{outdir}, 'webimg.ico');
	print STDERR ("INFO: build_ico(): ", $dst, "\n");
	File::Copy::copy($src, $dst)
		or die "ERROR: copy(): $src -> $dst: $!";
 }
sub build ($) {
	my ($env) = @_;
	print STDERR Data::Dumper::Dumper($env)
		if $debug;
	File::Path::mkpath($env->{outdir});
	my ($idx) = build_content($env);
	build_css($env);
	build_ico($env);
	build_index($env, $idx);
 }
sub main {
	Getopt::Long::Configure
	 ( 'auto_version'
	 , 'pass_through'
	 , 'permute'
	 );
	my $fast      = 0;
	my $outdir    = File::Spec->catdir(File::Spec->tmpdir(), 'tool', 'webimg');
	my $quality   = 50;
	my $thumbnail = "x300";
	my $title     = undef;
	my $video_url_prefix = undef;
	Getopt::Long::GetOptions
	 ( 'debug' => \$debug
	 , 'fast' => \$fast
	 , 'outdir=s' => \$outdir
	 , 'quality=i' => \$quality
	 , 'title|T=s' => \$title
	 , 'thumbnail|t=s' => \$thumbnail
	 , help => sub { Pod::Usage::pod2usage
		 ( -exitstatus => 0
		 , -sections   => ['NAME', 'SYNOPSIS', 'OPTIONS']
		 , -verbose    => 99 ); }
	 , man  => sub { Pod::Usage::pod2usage(-verbose => 2); }
	 , version => sub { Pod::Usage::pod2usage
		 ( -exitstatus => 0
		 , -sections   => ['VERSION', 'LICENSE']
		 , -verbose    => 99 ); }
	 , 'video-url-prefix=s' => \$video_url_prefix
	 );
	build
	 ({src => [map { Encode::decode('utf-8', $_) } @ARGV]
	 , fast => $fast
	 , outdir => Encode::decode('utf-8', $outdir)
	 , quality => $quality
	 , title => Encode::decode('utf-8', $title)
	 , thumbnail => $thumbnail
	 , video_url_prefix => $video_url_prefix
	 });
 }
main;
1;
__END__

=encoding utf8

=head1 NAME

tool/webimg/build - build a webimg

=head1 SYNOPSIS

tool/webimg/build [OPTIONS] [--] <picture> ...

=head1 OPTIONS

=over 8

=item B<-d>, B<--debug>

=item B<-h>, B<--help>

=item B<-t> [<int>][x<int>], B<--thumbnail>=[<int>][x<int>]

=item B<-T> <string>, B<--title>=<string>

=item B<-o> <dirname>, B<--outdir>=<dirname>

=item B<-q> <int>, B<--quality>=<int>

=item B<-v>, B<--version>

=head1 VERSION

2012-10-11

=back

=head1 LICENSE

GNU/GPL/v3+ http://www.gnu.org/licenses/gpl.html

Gauche d’auteur (}) 2012  Julien Moutinho <julm+tool+webimg&autogeree.net>

=back

=cut