… | |
… | |
130 | sub MOVE_ALL (){ 0x1001f } # very special value, more PITA |
130 | sub MOVE_ALL (){ 0x1001f } # very special value, more PITA |
131 | |
131 | |
132 | sub load_ref($) { |
132 | sub load_ref($) { |
133 | my ($path) = @_; |
133 | my ($path) = @_; |
134 | |
134 | |
135 | open my $fh, "<", $path |
135 | open my $fh, "<:raw:perlio", $path |
136 | or die "$path: $!"; |
136 | or die "$path: $!"; |
137 | binmode $fh; |
|
|
138 | local $/; |
137 | local $/; |
139 | |
138 | |
140 | thaw <$fh> |
139 | thaw <$fh> |
141 | } |
140 | } |
142 | |
141 | |
143 | sub save_ref($$) { |
142 | sub save_ref($$) { |
144 | my ($ref, $path) = @_; |
143 | my ($ref, $path) = @_; |
145 | |
144 | |
146 | open my $fh, ">", "$path~" |
145 | open my $fh, ">:raw:perlio", "$path~" |
147 | or die "$path~: $!"; |
146 | or die "$path~: $!"; |
148 | binmode $fh; |
|
|
149 | print $fh freeze $ref; |
147 | print $fh freeze $ref; |
150 | close $fh; |
148 | close $fh; |
151 | rename "$path~", $path |
149 | rename "$path~", $path |
152 | or die "$path: $!"; |
150 | or die "$path: $!"; |
153 | } |
151 | } |
… | |
… | |
201 | if (defined (my $v = delete $ob->{slow_move})) { |
199 | if (defined (my $v = delete $ob->{slow_move})) { |
202 | $ob->{move_slow} |= MOVE_WALK; |
200 | $ob->{move_slow} |= MOVE_WALK; |
203 | $ob->{move_slow_penalty} = $v; |
201 | $ob->{move_slow_penalty} = $v; |
204 | } |
202 | } |
205 | if (defined (my $v = delete $ob->{walk_on})) { |
203 | if (defined (my $v = delete $ob->{walk_on})) { |
|
|
204 | $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; |
206 | $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK |
205 | $ob->{move_on} = $v ? $ob->{move_on} | MOVE_WALK |
207 | : $ob->{move_on} & ~MOVE_WALK; |
206 | : $ob->{move_on} & ~MOVE_WALK; |
208 | } |
207 | } |
209 | if (defined (my $v = delete $ob->{walk_off})) { |
208 | if (defined (my $v = delete $ob->{walk_off})) { |
|
|
209 | $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; |
210 | $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK |
210 | $ob->{move_off} = $v ? $ob->{move_off} | MOVE_WALK |
211 | : $ob->{move_off} & ~MOVE_WALK; |
211 | : $ob->{move_off} & ~MOVE_WALK; |
212 | } |
212 | } |
213 | if (defined (my $v = delete $ob->{fly_on})) { |
213 | if (defined (my $v = delete $ob->{fly_on})) { |
|
|
214 | $ob->{move_on} = MOVE_ALL unless exists $ob->{move_on}; |
214 | $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW |
215 | $ob->{move_on} = $v ? $ob->{move_on} | MOVE_FLY_LOW |
215 | : $ob->{move_on} & ~MOVE_FLY_LOW; |
216 | : $ob->{move_on} & ~MOVE_FLY_LOW; |
216 | } |
217 | } |
217 | if (defined (my $v = delete $ob->{fly_off})) { |
218 | if (defined (my $v = delete $ob->{fly_off})) { |
|
|
219 | $ob->{move_off} = MOVE_ALL unless exists $ob->{move_off}; |
218 | $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW |
220 | $ob->{move_off} = $v ? $ob->{move_off} | MOVE_FLY_LOW |
219 | : $ob->{move_off} & ~MOVE_FLY_LOW; |
221 | : $ob->{move_off} & ~MOVE_FLY_LOW; |
220 | } |
222 | } |
221 | if (defined (my $v = delete $ob->{flying})) { |
223 | if (defined (my $v = delete $ob->{flying})) { |
|
|
224 | $ob->{move_type} = MOVE_ALL unless exists $ob->{move_type}; |
222 | $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW |
225 | $ob->{move_type} = $v ? $ob->{move_type} | MOVE_FLY_LOW |
223 | : $ob->{move_type} & ~MOVE_FLY_LOW; |
226 | : $ob->{move_type} & ~MOVE_FLY_LOW; |
224 | } |
227 | } |
225 | |
228 | |
226 | # convert idiotic event_xxx things into objects |
229 | # convert idiotic event_xxx things into objects |
… | |
… | |
288 | sub read_pak($) { |
291 | sub read_pak($) { |
289 | my ($path) = @_; |
292 | my ($path) = @_; |
290 | |
293 | |
291 | my %pak; |
294 | my %pak; |
292 | |
295 | |
293 | open my $fh, "<", $path |
296 | open my $fh, "<:raw:perlio", $path |
294 | or Carp::croak "$_[0]: $!"; |
297 | or Carp::croak "$_[0]: $!"; |
295 | binmode $fh; |
298 | binmode $fh; |
296 | while (<$fh>) { |
299 | while (<$fh>) { |
297 | my ($type, $id, $len, $path) = split; |
300 | my ($type, $id, $len, $path) = split; |
298 | $path =~ s/.*\///; |
301 | $path =~ s/.*\///; |
… | |
… | |
300 | } |
303 | } |
301 | |
304 | |
302 | \%pak |
305 | \%pak |
303 | } |
306 | } |
304 | |
307 | |
305 | sub read_arch($) { |
308 | sub read_arch($;$) { |
306 | my ($path) = @_; |
309 | my ($path, $toplevel) = @_; |
307 | |
310 | |
308 | my %arc; |
311 | my %arc; |
309 | my ($more, $prev); |
312 | my ($more, $prev); |
310 | |
313 | |
311 | open my $fh, "<", $path |
314 | open my $fh, "<:raw:perlio:utf8", $path |
312 | or Carp::croak "$path: $!"; |
315 | or Carp::croak "$path: $!"; |
313 | |
316 | |
314 | binmode $fh; |
317 | binmode $fh; |
315 | |
318 | |
316 | my $parse_block; $parse_block = sub { |
319 | my $parse_block; $parse_block = sub { |
… | |
… | |
330 | } elsif (/^msg$/i) { |
333 | } elsif (/^msg$/i) { |
331 | while (<$fh>) { |
334 | while (<$fh>) { |
332 | last if /^endmsg\s*$/i; |
335 | last if /^endmsg\s*$/i; |
333 | $arc{msg} .= $_; |
336 | $arc{msg} .= $_; |
334 | } |
337 | } |
|
|
338 | } elsif (/^anim$/i) { |
|
|
339 | while (<$fh>) { |
|
|
340 | last if /^mina\s*$/i; |
|
|
341 | chomp; |
|
|
342 | push @{ $arc{anim} }, $_; |
|
|
343 | } |
335 | } elsif (/^(\S+)\s*(.*)$/) { |
344 | } elsif (/^(\S+)\s*(.*)$/) { |
336 | $arc{lc $1} = $2; |
345 | $arc{lc $1} = $2; |
337 | } elsif (/^\s*($|#)/) { |
346 | } elsif (/^\s*($|#)/) { |
338 | # |
347 | # |
339 | } else { |
348 | } else { |
… | |
… | |
368 | } else { |
377 | } else { |
369 | push @{ $arc{arch} }, $arc; |
378 | push @{ $arc{arch} }, $arc; |
370 | } |
379 | } |
371 | $prev = $arc; |
380 | $prev = $arc; |
372 | $more = undef; |
381 | $more = undef; |
|
|
382 | } elsif ($toplevel && /^(\S+)\s+(.*)$/) { |
|
|
383 | if ($1 eq "lev_array") { |
|
|
384 | while (<$fh>) { |
|
|
385 | last if /^endplst\s*$/; |
|
|
386 | push @{$toplevel->{lev_array}}, $_+0; |
|
|
387 | } |
|
|
388 | } else { |
|
|
389 | $toplevel->{$1} = $2; |
|
|
390 | } |
373 | } elsif (/^\s*($|#)/) { |
391 | } elsif (/^\s*($|#)/) { |
374 | # |
392 | # |
375 | } else { |
393 | } else { |
376 | warn "$path: unparseable top-level line '$_'"; |
394 | die "$path: unparseable top-level line '$_'"; |
377 | } |
395 | } |
378 | } |
396 | } |
379 | |
397 | |
380 | undef $parse_block; # work around bug in perl not freeing $fh etc. |
398 | undef $parse_block; # work around bug in perl not freeing $fh etc. |
381 | |
399 | |