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_001';
   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         push @pkgs, split ',', ($self->{cfg}{pkgs}{$_}{deps} // '') for @pkgs;
  59         @pkgs = uniq @pkgs;
  60         addpkg $_, $dest for @pkgs;
  61         write_file catfile ($dir, 'readme.txt'), $self->{cfg}{readme};
  62         my @zip_files = catfile $dir, 'readme.txt';
  63         if ($self->{cfg}{vpk}) {
  64                 system $self->{cfg}{vpk} => $dest;
  65                 push @zip_files, catfile $dir, "pkg.$self->{cfg}{vpk_extension}"
  66         } else {
  67                 find sub { push @zip_files, $File::Find::name if -f }, 'pkg';
  68         }
  69         zip \@zip_files, catfile($dir, 'pkg.zip'), FilterName => sub { $_ = abs2rel $_, $dir }, -Level => 1;
  70         open my $fh, '<', catfile $dir, 'pkg.zip';
  71         remove_tree $dir;
  72         [200, ['Content-Type' => 'application/zip', 'Content-Disposition' => 'attachment; filename=pkg.zip'], $fh]
  73 }
  74
  75 sub makelist {
  76         my ($self, $elem, $tree, $lvl, $key) = @_;
  77         my $name = HTML::Element->new('span', class => 'name');
  78         $name->push_content($key);
  79         $elem->push_content($name) if defined $key;
  80         if (ref $tree eq 'ARRAY') {
  81                 my $sel = HTML::Element->new('select', name => 'pkg');
  82                 my $opt = HTML::Element->new('option', value => '');
  83                 $opt->push_content('None');
  84                 $sel->push_content($opt);
  85                 for my $pkg (sort { $a->{name} cmp $b->{name} } values $tree) {
  86                         my $opt = HTML::Element->new('option', value => $pkg->{pkg}, $pkg->{default} ? (selected => 'selected') : ());
  87                         $opt->push_content($pkg->{name});
  88                         $sel->push_content($opt);
  89                 }
  90                 $elem->push_content($sel);
  91         } else {
  92                 my $ul = HTML::Element->new('ul');
  93                 for my $key ($self->{cfg}{sort}->(keys $tree)) {
  94                         my $li = HTML::Element->new('li', class => "level$lvl");
  95                         $self->makelist($li, $tree->{$key}, $lvl + 1, $key);
  96                         $ul->push_content($li);
  97                 }
  98                 $elem->push_content($ul);
  99         }
 100 }
 101
 102 sub makeindex {
 103         my ($self) = @_;
 104         my ($pkgs, $tree) = ($self->{cfg}{pkgs}, {});
 105         for (keys $pkgs) {
 106                 my $ref = DiveRef ($tree, split ',', $pkgs->{$_}{path});
 107                 $$ref = [] unless ref $$ref eq 'ARRAY';
 108                 push $$ref, {pkg => $_, name => $pkgs->{$_}{name}, default => $pkgs->{$_}{default}};
 109         }
 110         my $html = HTML::TreeBuilder->new_from_file('index.html');
 111         $self->makelist(scalar $html->look_down(id => 'list'), $tree, 1);
 112         my $ret = $html->as_HTML('', ' ');
 113         utf8::encode($ret);
 114         [200, ['Content-Type' => 'text/html;charset=utf-8'], [$ret]]
 115 }
 116
 117 sub call{
 118         my ($self, $env) = @_;
 119         my $req = Plack::Request->new($env);
 120         return $self->makepkg($req->param('pkg')) if $req->path eq '/makepkg';
 121         $self->makeindex;
 122 }
 123
 124 1;
 125 __END__
 126
 127 =encoding utf-8
 128
 129 =head1 NAME
 130
 131 App::Web::VPKBuilder - Mix & match Source engine game mods
 132
 133 =head1 SYNOPSIS
 134
 135   use Plack::Builder;
 136   use App::Web::VPKBuilder;
 137   builder {
 138     enable ...;
 139     enable ...;
 140     App::Web::VPKBuilder->new->to_app
 141   }
 142
 143 =head1 DESCRIPTION
 144
 145 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.
 146
 147 =head1 CONFIGURATION
 148
 149 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).
 150
 151 =head2 Global options
 152
 153 =over
 154
 155 =item readme
 156
 157 A string representing the contents of the readme.txt file included with the package.
 158
 159 =item sort_order
 160
 161 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.
 162
 163 =item dir
 164
 165 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).
 166
 167 =item vpk
 168
 169 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.
 170
 171 =item vpk_extension
 172
 173 The extension of a package. Only useful with the C<vpk> option. Defaults to C<vpk>
 174
 175 =back
 176
 177 Example:
 178
 179   ---
 180   readme: "Place the .vpk file in your custom directory (<steam root>/SteamApps/common/Team Fortress 2/tf/custom/)"
 181   sort_order: [Scout, Soldier, Pyro, Demoman, Heavy, Engineer, Medic, Sniper, Spy, Sounds, Model]
 182   dir: work
 183   vpk: ./vpk
 184   vpk_extension: vpk
 185
 186 =head2 Mods
 187
 188 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_->.
 189
 190 Mod options:
 191
 192 =over
 193
 194 =item name
 195
 196 A string representing the (human readable) name of the mod.
 197
 198 =item path
 199
 200 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>).
 201
 202 If multiple mods have the same path, the user will be allowed to choose at most one of them.
 203
 204 =item default
 205
 206 A boolean which, if true, marks this mod as the default mod for its path.
 207
 208 =item deps
 209
 210 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.
 211
 212 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.
 213
 214 =back
 215
 216 Example:
 217
 218   ---
 219   pkgs:
 220     mymod-basher:
 221       name: MyMod
 222       path: "Scout,Boston Basher"
 223       default: true
 224       deps: mymod-base
 225     mymod-sandman:
 226       name: MyMod
 227       path: "Scout,Sandman"
 228       default: true
 229       deps: mymod-base
 230
 231
 232 =head1 TODO
 233
 234 For 0.001:
 235 * Tests
 236 * More/Clearer documentation
 237 * Nicer user interface
 238
 239 =head1 AUTHOR
 240
 241 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 242
 243 =head1 COPYRIGHT AND LICENSE
 244
 245 Copyright (C) 2014 by Marius Gavrilescu
 246
 247 This library is free software; you can redistribute it and/or modify
 248 it under the same terms as Perl itself, either Perl version 5.18.2 or,
 249 at your option, any later version of Perl 5 you may have available.
 250
 251
 252 =cut