lib/App/Web/VPKBuilder.pm

   1 package App::Web::VPKBuilder;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use parent qw/Plack::Component/;
   7 our $VERSION = '0.000_002';
   8
   9 use File::Find qw/find/;
  10 use File::Path qw/remove_tree/;
  11 use File::Spec::Functions qw/abs2rel catfile rel2abs/;
  12 use File::Temp qw/tempdir/;
  13 use IO::Compress::Zip qw/zip ZIP_CM_LZMA/;
  14 use sigtrap qw/die normal-signals/;
  15
  16 use Data::Diver qw/DiveRef/;
  17 use File::Slurp qw/write_file/;
  18 use HTML::Element;
  19 use HTML::TreeBuilder;
  20 use Hash::Merge qw/merge/;
  21 use List::MoreUtils qw/uniq/;
  22 use Plack::Request;
  23 use Sort::ByExample qw/sbe/;
  24 use YAML qw/LoadFile/;
  25
  26 sub new {
  27         my $self = shift->SUPER::new(@_);
  28         $self->{cfg} = {};
  29         for (sort <cfg/*>) {
  30                 my $cfg = LoadFile $_;
  31                 $self->{cfg} = merge $self->{cfg}, $cfg
  32         }
  33         $self->{cfg}{vpk_extension} //= 'vpk';
  34         $self->{cfg}{sort} = sbe $self->{cfg}{sort_order}, { fallback => sub { shift cmp shift } };
  35         $self
  36 }
  37
  38 sub addpkg {
  39         my ($pkg, $dir) = @_;
  40         return unless $pkg =~ /^[a-zA-Z0-9_-]+$/aa;
  41         my @dirs = ($dir);
  42         find {
  43                 postprocess => sub { pop @dirs },
  44                 wanted => sub {
  45                         my $dest = catfile @dirs, $_;
  46                         mkdir $dest if -d;
  47                         push @dirs, $_ if -d;
  48                         link $_, $dest if -f;
  49         }}, catfile 'pkg', $pkg;
  50 }
  51
  52 sub makepkg {
  53         my ($self, @pkgs) = @_;
  54         mkdir $self->{cfg}{dir};
  55         my $dir = rel2abs tempdir 'workXXXX', DIR => $self->{cfg}{dir};
  56         my $dest = catfile $dir, 'pkg';
  57         mkdir $dest;
  58         @pkgs = grep { exists $self->{cfg}{pkgs}{$_} } @pkgs;
  59         push @pkgs, split ',', ($self->{cfg}{pkgs}{$_}{deps} // '') for @pkgs;
  60         @pkgs = uniq @pkgs;
  61         addpkg $_, $dest for @pkgs;
  62         write_file catfile ($dir, 'readme.txt'), $self->{cfg}{readme};
  63         my @zip_files = catfile $dir, 'readme.txt';
  64         if ($self->{cfg}{vpk}) {
  65                 system $self->{cfg}{vpk} => $dest;
  66                 push @zip_files, catfile $dir, "pkg.$self->{cfg}{vpk_extension}"
  67         } else {
  68                 find sub { push @zip_files, $File::Find::name if -f }, $dest;
  69         }
  70         zip \@zip_files, catfile($dir, 'pkg.zip'), FilterName => sub { $_ = abs2rel $_, $dir }, -Level => 1;
  71         open my $fh, '<', catfile $dir, 'pkg.zip';
  72         remove_tree $dir;
  73         [200, ['Content-Type' => 'application/zip', 'Content-Disposition' => 'attachment; filename=pkg.zip'], $fh]
  74 }
  75
  76 sub makelist {
  77         my ($self, $elem, $tree, $lvl, $key) = @_;
  78         my $name = HTML::Element->new('span', class => 'name');
  79         $name->push_content($key);
  80         $elem->push_content($name) if defined $key;
  81         if (ref $tree eq 'ARRAY') {
  82                 my $sel = HTML::Element->new('select', name => 'pkg');
  83                 my $opt = HTML::Element->new('option', value => '');
  84                 $opt->push_content('None');
  85                 $sel->push_content($opt);
  86                 for my $pkg (sort { $a->{name} cmp $b->{name} } values $tree) {
  87                         my $opt = HTML::Element->new('option', value => $pkg->{pkg}, $pkg->{default} ? (selected => 'selected') : ());
  88                         $opt->push_content($pkg->{name});
  89                         $sel->push_content($opt);
  90                 }
  91                 $elem->push_content($sel);
  92         } else {
  93                 my $ul = HTML::Element->new('ul');
  94                 for my $key ($self->{cfg}{sort}->(keys $tree)) {
  95                         my $li = HTML::Element->new('li', class => "level$lvl");
  96                         $self->makelist($li, $tree->{$key}, $lvl + 1, $key);
  97                         $ul->push_content($li);
  98                 }
  99                 $elem->push_content($ul);
 100         }
 101 }
 102
 103 sub makeindex {
 104         my ($self) = @_;
 105         my ($pkgs, $tree) = ($self->{cfg}{pkgs}, {});
 106         for (keys $pkgs) {
 107                 my $ref = DiveRef ($tree, split ',', $pkgs->{$_}{path});
 108                 $$ref = [] unless ref $$ref eq 'ARRAY';
 109                 push $$ref, {pkg => $_, name => $pkgs->{$_}{name}, default => $pkgs->{$_}{default}};
 110         }
 111         my $html = HTML::TreeBuilder->new_from_file('index.html');
 112         $self->makelist(scalar $html->look_down(id => 'list'), $tree, 1);
 113         my $ret = $html->as_HTML('', ' ');
 114         utf8::encode($ret);
 115         [200, ['Content-Type' => 'text/html;charset=utf-8'], [$ret]]
 116 }
 117
 118 sub call{
 119         my ($self, $env) = @_;
 120         my $req = Plack::Request->new($env);
 121         return $self->makepkg($req->param('pkg')) if $req->path eq '/makepkg';
 122         $self->makeindex;
 123 }
 124
 125 1;
 126 __END__
 127
 128 =encoding utf-8
 129
 130 =head1 NAME
 131
 132 App::Web::VPKBuilder - Mix & match Source engine game mods
 133
 134 =head1 SYNOPSIS
 135
 136   use Plack::Builder;
 137   use App::Web::VPKBuilder;
 138   builder {
 139     enable ...;
 140     enable ...;
 141     App::Web::VPKBuilder->new->to_app
 142   }
 143
 144 =head1 DESCRIPTION
 145
 146 App::Web::VPKBuilder is a simple web service for building Source engine game VPK packages. It presents a list of mods sorted into (sub)categories. The user can choose a mod from each category and will get a VPK containing all of the selected packages.
 147
 148 =head1 CONFIGURATION
 149
 150 APP::Web::VPKBuilder is configured via YAML files in the F<cfg> directory. The recommended layout is to have an F<options.yml> file with the global options, and one file for each source mod (original mod that may be split into more mods).
 151
 152 =head2 Global options
 153
 154 =over
 155
 156 =item readme
 157
 158 A string representing the contents of the readme.txt file included with the package.
 159
 160 =item sort_order
 161
 162 An array of strings representing the sort order of (sub)categories. (sub)categories appear in this order. (sub)categories that are not listed appear in alphabetical order after those listed.
 163
 164 =item dir
 165
 166 A string representing the directory in which the packages are built. Must be on the same filesystem as the package directory (F<pkg/>). Is created if it does not exist (but its parents must exist).
 167
 168 =item vpk
 169
 170 A string representing the program that makes a package out of a folder. Must behave like the vpk program included with Source engine games: that is, when called like C<vpk path/to/folder> it should create a file F<path/to/folder.ext>, where C<ext> is given by the next option. If not provided, the folder is included as-is.
 171
 172 =item vpk_extension
 173
 174 The extension of a package. Only useful with the C<vpk> option. Defaults to C<vpk>
 175
 176 =back
 177
 178 Example:
 179
 180   ---
 181   readme: "Place the .vpk file in your custom directory (<steam root>/SteamApps/common/Team Fortress 2/tf/custom/)"
 182   sort_order: [Scout, Soldier, Pyro, Demoman, Heavy, Engineer, Medic, Sniper, Spy, Sounds, Model]
 183   dir: work
 184   vpk: ./vpk
 185   vpk_extension: vpk
 186
 187 =head2 Mods
 188
 189 Each source mod is composed of one or more directories (mods) in the F<pkg/> directory and a config file. Each config file should contain a hash named C<pkgs>. For each directory the hash should contain an entry with the directory name as key. Mod directory names may only contain the characters C<a-zA-Z0-9_->.
 190
 191 Mod options:
 192
 193 =over
 194
 195 =item name
 196
 197 A string representing the (human readable) name of the mod.
 198
 199 =item path
 200
 201 A comma-delimited string of the form C<category,subcategory,subcategory,...,item>. There can be any number of subcategories, but the default stylesheet is made for two-element paths (C<category,item>).
 202
 203 If multiple mods have the same path, the user will be allowed to choose at most one of them.
 204
 205 =item default
 206
 207 A boolean which, if true, marks this mod as the default mod for its path.
 208
 209 =item deps
 210
 211 A comma-delimited string representing a list of mods that must be included in the final package if this mod is included. The pkgs hash need not contain an entry for the dependencies.
 212
 213 For example, if two mods share a large part of their contents, then the shared part could be split into a third mod, and both of the original mods should depend on it. This third mod should not be included in the hash, as it shouldn't need to be manually selected by the user.
 214
 215 =back
 216
 217 Example:
 218
 219   ---
 220   pkgs:
 221     mymod-basher:
 222       name: MyMod
 223       path: "Scout,Boston Basher"
 224       default: true
 225       deps: mymod-base
 226     mymod-sandman:
 227       name: MyMod
 228       path: "Scout,Sandman"
 229       default: true
 230       deps: mymod-base
 231
 232
 233 =head1 TODO
 234
 235 For 0.001:
 236 * Tests
 237 * More/Clearer documentation
 238 * Nicer user interface
 239
 240 =head1 AUTHOR
 241
 242 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 243
 244 =head1 COPYRIGHT AND LICENSE
 245
 246 Copyright (C) 2014 by Marius Gavrilescu
 247
 248 This library is free software; you can redistribute it and/or modify
 249 it under the same terms as Perl itself, either Perl version 5.18.2 or,
 250 at your option, any later version of Perl 5 you may have available.
 251
 252
 253 =cut