File Coverage

blib/lib/App/Web/VPKBuilder.pm

Criterion	Covered	Total	%
statement	57	133	42.8
branch	0	22	0.0
condition	0	4	0.0
subroutine	19	30	63.3
pod	2	6	33.3
total	78	195	40.0

package App::Web::VPKBuilder;

use 5.014000;
use strict;
use warnings;
use parent qw/Plack::Component/;
our $VERSION = '0.000_002';

use File::Find qw/find/;
use File::Path qw/remove_tree/;
use File::Spec::Functions qw/abs2rel catfile rel2abs/;
use File::Temp qw/tempdir/;
use IO::Compress::Zip qw/zip ZIP_CM_LZMA/;
use sigtrap qw/die normal-signals/;

use Data::Diver qw/DiveRef/;
use File::Slurp qw/write_file/;
use HTML::Element;
use HTML::TreeBuilder;
use Hash::Merge qw/merge/;
use List::MoreUtils qw/uniq/;
use Plack::Request;
use Sort::ByExample qw/sbe/;
use YAML qw/LoadFile/;

sub new {
	my $self = shift->SUPER::new(@_);
	$self->{cfg} = {};
	for (sort ) {
		my $cfg = LoadFile $_;
		$self->{cfg} = merge $self->{cfg}, $cfg
	}
	$self->{cfg}{vpk_extension} //= 'vpk';
	$self->{cfg}{sort} = sbe $self->{cfg}{sort_order}, { fallback => sub { shift cmp shift } };
	$self
}

sub addpkg {
	my ($pkg, $dir) = @_;
	return unless $pkg =~ /^[a-zA-Z0-9_-]+$/aa;
	my @dirs = ($dir);
	find {
		postprocess => sub { pop @dirs },
		wanted => sub {
			my $dest = catfile @dirs, $_;
			mkdir $dest if -d;
			push @dirs, $_ if -d;
			link $_, $dest if -f;
	}}, catfile 'pkg', $pkg;
}

sub makepkg {
	my ($self, @pkgs) = @_;
	mkdir $self->{cfg}{dir};
	my $dir = rel2abs tempdir 'workXXXX', DIR => $self->{cfg}{dir};
	my $dest = catfile $dir, 'pkg';
	mkdir $dest;
	@pkgs = grep { exists $self->{cfg}{pkgs}{$_} } @pkgs;
	push @pkgs, split ',', ($self->{cfg}{pkgs}{$_}{deps} // '') for @pkgs;
	@pkgs = uniq @pkgs;
	addpkg $_, $dest for @pkgs;
	write_file catfile ($dir, 'readme.txt'), $self->{cfg}{readme};
	my @zip_files = catfile $dir, 'readme.txt';
	if ($self->{cfg}{vpk}) {
		system $self->{cfg}{vpk} => $dest;
		push @zip_files, catfile $dir, "pkg.$self->{cfg}{vpk_extension}"
	} else {
		find sub { push @zip_files, $File::Find::name if -f }, $dest;
	}
	zip \@zip_files, catfile($dir, 'pkg.zip'), FilterName => sub { $_ = abs2rel $_, $dir }, -Level => 1;
	open my $fh, '<', catfile $dir, 'pkg.zip';
	remove_tree $dir;
	[200, ['Content-Type' => 'application/zip', 'Content-Disposition' => 'attachment; filename=pkg.zip'], $fh]
}

sub makelist {
	my ($self, $elem, $tree, $lvl, $key) = @_;
	my $name = HTML::Element->new('span', class => 'name');
	$name->push_content($key);
	$elem->push_content($name) if defined $key;
	if (ref $tree eq 'ARRAY') {
		my $sel = HTML::Element->new('select', name => 'pkg');
		my $opt = HTML::Element->new('option', value => '');
		$opt->push_content('None');
		$sel->push_content($opt);
		for my $pkg (sort { $a->{name} cmp $b->{name} } values $tree) {
			my $opt = HTML::Element->new('option', value => $pkg->{pkg}, $pkg->{default} ? (selected => 'selected') : ());
			$opt->push_content($pkg->{name});
			$sel->push_content($opt);
		}
		$elem->push_content($sel);
	} else {
		my $ul = HTML::Element->new('ul');
		for my $key ($self->{cfg}{sort}->(keys $tree)) {
			my $li = HTML::Element->new('li', class => "level$lvl");
			$self->makelist($li, $tree->{$key}, $lvl + 1, $key);
			$ul->push_content($li);
		}
		$elem->push_content($ul);
	}
}

sub makeindex {
	my ($self) = @_;
	my ($pkgs, $tree) = ($self->{cfg}{pkgs}, {});
	for (keys $pkgs) {
		my $ref = DiveRef ($tree, split ',', $pkgs->{$_}{path});
		$$ref = [] unless ref $$ref eq 'ARRAY';
		push $$ref, {pkg => $_, name => $pkgs->{$_}{name}, default => $pkgs->{$_}{default}};
	}
	my $html = HTML::TreeBuilder->new_from_file('index.html');
	$self->makelist(scalar $html->look_down(id => 'list'), $tree, 1);
	my $ret = $html->as_HTML('', ' ');
	utf8::encode($ret);
	[200, ['Content-Type' => 'text/html;charset=utf-8'], [$ret]]
}

sub call{
	my ($self, $env) = @_;
	my $req = Plack::Request->new($env);
	return $self->makepkg($req->param('pkg')) if $req->path eq '/makepkg';
	$self->makeindex;
}

1;
__END__