lib/Games/Wormy/WormEdit.pm

   1 package Games::Wormy::WormEdit;
   2
   3 use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 use Parse::Binary::Nested qw(unpackf);
   8
   9 our $VERSION = '1.00';
  10
  11 our %MAGICID = (
  12         "WormEdit053\000LVL" => 53,
  13         "WormEdit\34195\000LVL" => 95,
  14         "WormEdit\34194\000LVL" => 94,
  15         "WormEdit\34193\000LVL" => 93,
  16 );
  17
  18 sub read {
  19         my ($self, $input, $override) = @_;
  20         my ($id, $version) = (substr($input, 0, 15), ord substr($input, 15, 1));
  21         my $fileversion = $MAGICID{$id}
  22                 or die "File does not match any known WormEdit level header\n";
  23
  24         if ($override) {
  25                 warn "Override version $version to $override\n";
  26                 $version = $override;
  27         }
  28         elsif ($version != $fileversion) {
  29                 warn "Unexpected version $version (expecting $fileversion)\n";
  30         }
  31         elsif ($version == 95) {
  32                 # auto-detect exact variant
  33                 if (ord substr($input, 70, 1) ~~ [1 .. 8]) {
  34                         # valid sprite length instead of description byte
  35                         # (which is usually a letter or nul)
  36                         $version = 94;
  37                 }
  38                 elsif (ord substr($input, 147, 1) == 0) {
  39                         # nul of finish type is 2 bytes later (unlike first char of message)
  40                         $version = 96;
  41                 }
  42                 warn "Ambiguous file version 95; guessing subversion $version\n";
  43         };
  44
  45         $fileversion += 100 if $fileversion < 90;  # 93..95 came before 50..53
  46
  47         my @FORMAT = (
  48                 magic       => 'a15',
  49                 version     => 'C',
  50                 name        => 'C/a32',
  51                 description => 'C/a64x256',
  52                 levelcount  => [1,
  53                         single => 'C',
  54                         multi  => 'C',
  55                         race   => 'C',
  56                         ctf    => 'C',
  57                         total  => 'C',
  58                 ],
  59                 moderef     => [1,
  60                         map { (start => $_, end => $_) } [1,
  61                                 single     => 'C',
  62                                 peaworm    => 'C',
  63                                 tron       => 'C',
  64                                 deathmatch => 'C',
  65                                 foodmatch  => 'C',
  66                                 multifood  => 'C',
  67                                 timematch  => 'C',
  68                                 race       => 'C',
  69                                 ctf        => 'C',
  70                                 reserved   => 'x',
  71                         ],
  72                 ],
  73                 sprite     => ['8C',
  74                         line => 'B8',
  75                 ],
  76                 finish      => [1,
  77                         type    => 's',
  78                         message => 'C/a255',
  79                         code    => 'C/a255',
  80                         reserved=> 'x256',
  81                 ],
  82                 hiname      => 'a3',
  83                 levels      => ['*', # levelcount->total actually
  84                         id         => 'C/a22',
  85                         name       => 'C/a22',
  86                         size       => 'C',
  87                         peas       => 'C',
  88                         delay      => 'C',
  89                         growth     => 'C',
  90                         bsize      => 'C',
  91                         sprite     => ['8C',
  92                                 line => 'B8',
  93                         ],
  94                         balls      => ['32C',
  95                                 y   => 'C',
  96                                 x   => 'C',
  97                                 dir => 'C',
  98                         ],
  99                         worms      => [4,
 100                                 d => 'C',
 101                                 y => 'C',
 102                                 x => 'C',
 103                         ],
 104                         width      => 'C',
 105                         height     => 'C',
 106                         flags      => [2,
 107                                 y => 'C',
 108                                 x => 'C',
 109                         ],
 110                         objects    => ['128C',
 111                                 type => 'C',
 112                                 x1   => 'C',
 113                                 y1   => 'C',
 114                                 x2   => 'C',
 115                                 y2   => 'C',
 116                         ],
 117                 ],
 118         );
 119
 120         given ($fileversion) {
 121                 when (153) { } # current @FORMAT
 122                         $FORMAT[7] = 'C/a64'; # no reserved space after description
 123                         splice @{ $FORMAT[15] }, -2; # finish reserve
 124                         $FORMAT[-1]->[-1]->[0] = '32C'; # less objects
 125                         ref $_ and pop @$_ for @{ $FORMAT[11] }; # 9 moderefs
 126                 when ($version == 96) { }
 127                         ref $_ and pop @$_ for @{ $FORMAT[11] }; # only 8 moderefs (no ctf)
 128                         splice @FORMAT, 6, 2 if $version <= 94;  # earlier version without description
 129                 when (95) { }
 130                         splice @{ $FORMAT[7] }, 4, 2;  # no race
 131                         splice @{ $FORMAT[13] }, 4, 2; # no enddata
 132                         splice @{ $FORMAT[-1] }, 1, 2; # no name
 133                 when (94) { }
 134                         splice @FORMAT, 14, 2; # no hiname
 135                         $FORMAT[-1]->[0] = 64; # constant amount of levels
 136                 when (93) { }
 137                 default {
 138                         die "Cannot parse data for Wormedit $fileversion/$version\n";
 139                 }
 140         }
 141
 142         # convert to an easily accessible hash
 143         push @FORMAT, -trail => 'a*';
 144         my $data = unpackf(\@FORMAT, $input);
 145         warn "Trailing data left unparsed\n" if length delete $data->{-trail};
 146         $data->{format} = 'WormEdit';
 147         return $data;
 148 }
 149
 150 1;
 151
 152 __END__
 153
 154 =head1 NAME
 155
 156 Games::Wormy::WormEdit - Read Wormy levelset from a wormedit file
 157
 158 =head1 SYNOPSIS
 159
 160         my $levelset = Games::Wormy::WormEdit->read($filecontents);
 161         print $levelset->{name};
 162
 163 =head1 AUTHOR
 164
 165 Mischa POSLAWSKY <perl@shiar.org>
 166
 167 =head1 LICENSE
 168
 169 LGPL version 3.
 170