view release on metacpan or  search on metacpan

lib/App/Web/VPKBuilder.pm  view on Meta::CPAN

package App::Web::VPKBuilder;

use 5.014000;
use strict;
use warnings;
use parent qw/Plack::Component/;
use re '/s';
our $VERSION = '0.001';

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 <cfg/*>) {
		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' or return [500, ['Content-Type' => 'text/plain;charset=utf-8'], ['Error opening pkg.zip']]; ## no critic (RequireBriefOpen)
	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} } @$tree) {
			my $option = HTML::Element->new('option', value => $pkg->{pkg}, $pkg->{default} ? (selected => 'selected') : ());