#!/usr/bin/perl -w

# This is the package Vbr. It contains some routines to read/write vbr files.

# (c) Copyright by Tels 1999. All Rights Reserved. Do NOT distribute.
# Updates and support on bloodgate.com/thief
# Thanx to Doug Church at TLG

# [08/28/99] v0.0.1 - based on dump_vbr
# [09/14/99] v0.0.2 - fixed: writeVBR contains offset ot start
#                     fixed: fix offets in $footer
# [10/01/99] v0.0.3 - fixed: read Ofs from Dummy.vbr and use this
#                            instead of fixed value
#                     added: getinventory, gettexturelist
# [10/05/99] v0.0.4 - fixed: no TXLIST if none present
#                     added: OBJ_MAP, get Bunch from BRLIST
# [10/22/99] v0.0.5 - fixed: compl. rewritten, dissect mis/vbr file into parts,
#                            replace a part, then reassembly it on writing, OO
#                            now, fixed out of mem bug on huge files
#                     added: isDefined
# [10/29/99] v0.0.6 - added: getChunk
#                     fixed: removed getBR, "data/" removed in writeFile
# 1999-11-08 v0.0.7 - added: decodeChunk 
# 1999-12-17 v0.0.8 - added: chunkHeader
#                     fixed: putChunk now generates the chunk header
# 2000-01-07 v0.0.9 - fixed: small bug in putChunk
# 2000-02-13 v0.1.0 - added: missionEAX, speedup in reading/writing
#                            renderParams
# 2000-03-06 v0.1.1 - added: missionDescription, scriptModules, getChunkList
#                            removeChunks, removeEmptyChunks
# 2000-03-19 v0.1.2 - added: gamesysName, version, fileType, findChunk
#                     fixed: stripHeader returned not ref, but actual data
# 2000-04-17 v0.1.3 - added: songParams
#                     fixed: delChunk takes list
# 2000-05-22 v0.1.4 - added: hotRegions, multibrushes, loadMission/saveMission
#                     fixed: uses strict var 

package Cowgen::Vbr;
require Exporter;
@ISA    = qw(Exporter);
@EXPORT = qw( chunkHeader texturePalette);
@EXPORT_OK = qw( getChunk writeFile create putChunk delChunk isDefined 
                 decodeChunk removeChunks removeEmptyChunks findChunk
                 getINV getTXT getOBJ decodeChunk getChunkList
                 loadMission saveMission
               );

use Fcntl;
use Cowgen::Dromed;
use strict 'vars';
my ($VBR);
my $readBytes;
my $VERSION = 0.14;

#doc: fileType version gamesysName missionDescription scriptModules getChunkList
#doc: renderParams texturePalette multibrushes hotRegions

sub create 
  { 
  # create a VBR object and read the template (param0) or use "dummy.vbr" 
  # as default, extract inventory and then split file into chunks
  my $c = shift; my $n = shift || "dummy.vbr"; my $s = {}; bless $s, 
  $c; $s->init($n, shift); 
  return $s; 
  }

sub init
  {
  my $s = shift; $s->{file} = shift; $s->readTemplate(shift);
  }

sub isDefined
  {
  # return true if a chunk is defined
  my $s = shift;
  my $n = shift || "";
  return 1 if (defined $s->{filebuf}->{$n}); 
  return 0;
  }

sub chunkHeader
  {
  # return a chunks header by taking name, high and low version number
  my $n = shift || "";
  my $hv = shift || 0;
  my $lv = shift || 0;
  return pack ("a12LLL",$n,$hv,$lv,0);
  }

sub getChunk
  {
  # return chunk if it is defined
  my $s = shift;
  my $n = shift || "";
  return \$s->{filebuf}->{$n} if (defined $s->{filebuf}->{$n}); 
  return;
  }

sub findChunk
  {
  # find a chunk by name (case insensitive)
  my $s = shift;
  my $n = lc(shift) || return; 
  return $n if (defined $s->{filebuf}->{$n}); 
  # exact match first
  foreach (keys %{$s->{filebuf}})
    {
    return $_ if (lc($_) eq $n);
    }
  # fuzzy search
  foreach (keys %{$s->{filebuf}})
    {
    return $_ if (lc($_) =~ /$n/);
    }
  return;
  }

sub decodeChunk
  {
  # take a chunk and split it into parts, then take one of the fields of
  # each part and make this a key into a hash, assigning the part to it.
  # returns the hash.
  # parameters: chunkname, splitdescription (a Perl pack/unpack string),
  # part length (maximum or fixed length), keyfield (number), inital offset
  my $s = shift;
  my $h = {};
  my $n = shift || "";
  my $split = shift || return $h;
  my $partlen = shift || return $h;
  my $keyfield = shift || 0;
  my $offset = shift || 0;
  return $h if (!defined $s->{filebuf}->{$n});
  my $part = \$s->{filebuf}->{$n}; 
  my $ol = length($$part); my $ofs = $s->headerSize()+$offset;  
  my (@l);
  #print "split: $split\n";
  while ($ofs < $ol)
     {
     @l = unpack ($split,substr($$part,$ofs,$partlen));
     $h->{$l[$keyfield]} = [@l];
     #print " $l[$keyfield] => ";
     #foreach (@l) { print "$_,"; }
     #print "\n";
     $ofs += $partlen;
    } # end decode
  return $h; # hash
  }

sub template 
  {
  # return name of template file
  my $s = shift; return $s->{file};
  }

sub readTemplate
  {
  # new version, correctly read inventory and then split footer into parts
  my $s = shift; my $debug = shift;
  my $file = $s->{file};
  $file = "data/$file" if (-e "data/$file");
  print "Reading $file\n" if (defined $debug);
  my $size = -s $file;
  my ($rc,$footer,$invofs);
  if (defined $debug)
    {
    sysopen (VBR, $file,0)  
     || die ("Cant open $file for reading: $!\n");
    }
  else
    {
    sysopen (VBR, $file,0)  
     || die ("Cant open $file fore reading: $!\nSee readme.txt for help.");
    }
  binmode (VBR);
  $rc = read (VBR,$s->{header},0x110);
  die ("$file seems not to be a proper vbr/miss/sav file!") 
   if ($s->{header} !~ /\xde\xad\xbe\xef$/);
  $rc = read (VBR,$footer,$size-0x110);
  $invofs = unpack ("L",$s->{header}); 
  print "Start of inventory of $s->{file} is $invofs\n\n" if (defined $debug);
  $s->splitInventory(\$footer,$invofs);
  $s->{type} = $s->fileType();
  $s->{version} = THIEF;
  }

sub writeFile
  {
  # new version, reassemble parts and write to mis/vbr file
  my $s = shift;
  my ($file) = @_;
  my $newext = lc($file); 
  my $oldext = lc($s->{file}); 
  $newext =~ s/^[^\.]*(\..{0,3})$/$1/; $oldext =~ s/^[^\.]*(\..{0,3})$/$1/;
  if ($newext ne $oldext)
    {
    print "Vbr: Warning: Writing a '$newext' file using a '$oldext' ", 
     "file as template.\n              This will likely crash DromEd!!\n";
    }
  sysopen (VBR, "$file", O_CREAT | O_WRONLY | O_TRUNC) 
   or die "cant open $file: $!";  
  binmode (VBR);
  
  my ($n,$cnt,$inv,$partlen,$invofs,$footer); # reassemble parts hereinto
  $invofs = length($s->{header}); $inv = ""; $cnt = 0;
  foreach (sort keys %{$s->{filebuf}})
    {
    $partlen = length($s->{filebuf}->{$_});
    $inv .= pack ("Z12LL",$_,$invofs,$partlen-24); $invofs += $partlen; $cnt++; 
    }
  # calc new invofs
  substr($s->{header},0,4) = pack ("L",$invofs); 
  print VBR $s->{header};
  foreach (sort keys %{$s->{filebuf}})
    {
    print VBR $s->{filebuf}->{$_};
    }
  print VBR pack ("L",$cnt);
  print VBR $inv;
  close(VBR);
  return;
  }

sub splitInventory
  {
  my $s = shift;
  my ($footer,$invofs) = @_;
  my (%inv,%filebuf,$count,$cnt,$hl,$c,$i,$o,$l,$name);
  $hl = length($s->{header});
  my $ofs = $invofs-$hl; 
  # get count of items in inv
  $count = unpack ("L",substr($$footer,$ofs,4)); $ofs += 4; $cnt = 0;
  my $txofs = 0; my $txl = 0; my $ol = 0; my $oofs = 0;
  while ($cnt < $count)
    {
    ($name,$o,$l) = unpack ("Z12LL",substr($$footer,$ofs,20)); $ofs += 20;
    $inv{$name} = "$o,$l"; # store
    $filebuf{$name} = substr($$footer,$o-$hl,$l+24); # store
    $cnt ++; 
    }
  $s->{filebuf} = \%filebuf;
  $s->{inv} = \%inv;
  }

sub getINV
  {
  # return inventory of mis/vbr template file
  my $s = shift;
  return %{$s->{inv}}; 
  } 

sub getChunkList
  {
  # return list of chunk names
  my $s = shift;
  return keys %{$s->{inv}}; 
  } 

sub getOBJ 
  {
  # take objmap part and return list of objects in it
  my $s = shift;
  my ($ofs,$ol,$list,$part,$name,$i,%objmap,$id,$len);
  $part = \$s->{filebuf}->{'OBJ_MAP'};
  return if (!defined $part);
  $ol = length($$part); $ofs = 24; 
  while ($ofs < $ol)
     { 
     ($id,$len) = unpack ("lL",substr($$part,$ofs,8)); # id, length
     $ofs += 8;
     $name = unpack ("Z".$len,substr($$part,$ofs,$len));
     $objmap{$id} = $name;
    } # end OBJMAP
  return %objmap;
  }

sub getTXT
  {
  # old variant of texturePalette
  return texturePalette(@_);
  }

sub texturePalette
  {
  # take texture-map part and return list of it
  my $s = shift;
  my $h = shift;
  if (!defined $h)
    {
    # decode 
    my (@family,$l,$j,$s1,$num,$val,$v1,$ofs,$ol,$list,$part,$name,%txlist);
    $part = \$s->{filebuf}->{'TXLIST'};
    return if (!defined $part);
    $ol = length($$part); $ofs = 24+8; 
    while ($ofs < $ol)
      {
      $l = unpack ("L",substr($$part,$ofs,4));
      print "Texture families: $l\n";
      $ofs += 4; $num = 0;
      for ($j=0;  $j<$l; $j++)
        { 
        $family[$num++] = unpack("Z16",substr($$part,$ofs,16)); $ofs += 16;
        }
      $num = 0;
      while ($ofs < $ol)
        { 
        ($v1,$val,$s1,$name) = unpack ("CCSZ16",substr($$part,$ofs,20)); $ofs += 20;
        $txlist{"$family[$val-1]/$name"} = "$num;-1;$val;$v1" if ($num > 0); 
        $num++;
        }
      } # end txlist
    $txlist{"skyhack/sky"} = "249;-1;0;0";
    return \%txlist;
    }
  else
    {
    # take a hash with texture names and numbers, encode it as vbr chunk
    # like $vbr->encodeTextureList ( { 7 => 'core/sand.pcx' } );
    my ($fam,$part,%fams,$name,%family);
    foreach (keys %$h)
      {
      #print "$h->{$_}\n"; # debug
      $fam = $h->{$_}; $fam =~ s/\/.*$//; 
      $fams{$fam} = 1; # unique family list
      }
    my $famcount = 1 + scalar keys %fams; # "fam" + 
    my $txtcount = 1 + scalar keys %$h; # "null" +
    $part = pack ("LLL", $txtcount*20+$famcount*16+12, $txtcount, $famcount);
    $part .= pack ("Z16",'fam');
    my $num = 1;
    foreach (keys %fams)
      {
      $part .= pack ("Z16",$_); $family{$_} = $num++; # name to nr mapping
      }
    $part .= pack ("CCSZ16", 0,0,0, 'null' );
    foreach (sort by_num keys %$h)
      {
      $name = $h->{$_};
      $fam = $name; $fam =~ s/\/.*$//; 
      $name =~ s/.*\///;
      #print "$_ ($fam $family{$fam} )=> $name\n";
      $fam = $family{$fam}; # name => nr
      $part .= pack ("CCSZ16", 1,$fam+1,0, $name );
      }
    $s->putChunk ('TXLIST',\$part,1,0);
    }
  return $s;
  }

# used by texturePalette
sub by_num { $a <=> $b; }
 
sub putChunk
  {
  # name = newbuffer, replace a chunk with new binary data
  my $empty = "";
  my $s = shift; my $name = shift || return; my $buf = shift || \$empty;
  my $hl = shift || 0; my $vl = shift || 0;
  $s->{filebuf}->{$name} = chunkHeader($name,$hl,$vl) . $$buf;
  }

sub delChunk
  {
  # chunk "name" is deleted from inventory, works for lists of names 
  my $s = shift; 
  foreach (@_) { delete $s->{filebuf}->{$_}; }
  }

sub removeChunks 
  {  
  # delete all chunks that match the given regex
  # return number of removed chunks
  # parameter: namregexp (f.i. '^(P|L|LD)\$')
  my $s = shift;
  my $exp = shift || return 0;
  my $count = 0;
  foreach (keys %{$s->{inv}})
    {
    if ($_ =~ /$exp/)
      {
      $count++; $s->delChunk($_); 
      }
    } 
  $count;
  }

sub removeEmptyChunks
  {
  # remove empty property and link chunks (for strip and cleaning)
  # return number of removed chunks
  my $s = shift;
  my $count = 0; my $hr = $s->headerSize();
  foreach (keys %{$s->{inv}})
    {
    next unless /^(P|LD|L)\$/;
    next if (length($s->{filebuf}->{$_}) > $hr);
    $s->delChunk($_); $count ++;
    }
  return $count;
  }

sub stripHeader
  {
  # strip the header from a chunk
  my $s = shift;
  my $chunk = shift || return;
  $chunk = substr($$chunk,$s->headerSize(),length($$chunk)-$s->headerSize())
    if (length($$chunk)>$s->headerSize());
  \$chunk;
  }

sub headerSize
  {
  return 24; # currently static
  }

sub readBytes
  {
  my $s = shift;
  my ($len) = @_;
  my ($rc);

  $rc = read (VBR,$s->{buf},$len);
  $readBytes += $rc;
  return $rc;
  }

sub readWord
  {
  my $s = shift;
  my $rc = readBytes(2);
  return -1 if ($rc != 2);
  my $buf2  = substr($s->{buf},1,1);
  return (ord($s->{buf})  + (ord($buf2) << 8));
  }

sub readByte
  {
  my $s = shift;
  my $rc = readBytes(1);
  return -1 if ($rc != 1);
  return ord($s->{buf});
  }

sub version
  {
  # get version file (THIEF, THIEF2, SHOCK2, UNREAL etc)
  my $s = shift;
  $s->{version} = $_[0] if (defined $_[0]);
  return $s->{version};
  }

# easier loading/saving of files

sub loadMission 
  {
  # load a mission and accompanion gamfile, create a bunch and texture list from
  # it and return vbr,gf,bunch,txt
  # parameters: mission_file, gamfile (optional)
  my ($m,$g) = @_;
  my ($vbr,$gf,$bunch,$txt);
  $vbr = Cowgen::Vbr->create($m); 
  $gf = Cowgen::Gamfile->create($g);
  $bunch = Cowgen::Bunch->create ( $m, $vbr, $gf ); 
  $txt = Cowgen::Texture->create( $vbr->texturePalette() );
  return ($vbr,$gf,$bunch,$txt);
  }

sub saveMission  
  {
  # take bunch and gamfile, stuff it to vbr using gamefile and write out to file
  # parameters: self, gamfile, bunch, outfilepathname
  my $s = shift || return;
  my ($gf,$bunch,$outfile) = @_;
  $bunch->stuff2vbr($s,$gf);
  $s->writeFile($outfile);
  }

##############################################################################
# Chunk en/decoders
##############################################################################

sub missionEAX
  {
  # get/set mission eax parameters,
  # named parameters: eax, dampeningfactor, heightoverride
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk("MissionEAX"));
    my @r = unpack ("LLL", $$buffer) if (defined $buffer);
    @r = (0,0,0) if (!defined $buffer);
    return { eax => $r[0], dampeningfactor => $r[1], heightoverride => $r[2] };
    }
  else
    {
    $p = { @_ } if (ref($p) ne 'HASH'); # user did give array
    my $buffer = pack ("LLL",
       ($p->{eax} || 1)-1,$p->{dampeningfactor}||0,$p->{heightoverride}||0);
    $s->putChunk('MissionEAX',\$buffer,1,0);
    }
  }  

sub renderParams
  {
  # get/set renderparams (palette res string, ambient factor)
  # named parameters: paletteres (16 char string), ambient (either as 20 or 20/256)
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk("RENDPARAMS"));
    my @r = unpack ("Z16f", $$buffer) if (defined $buffer);
    @r = ("",0) if (!defined $buffer);
    return { paletteres => $r[0], ambient => $r[1] };
    }
  else
    {
    $p = { @_ } if (ref($p) ne 'HASH'); # user did give array
    my $a = $p->{ambient} || 0; $a = $a / 256 if ($a >= 1);
    my $buffer = pack ("Z16f", ($p->{paletteres} || ""),$a);
    $s->putChunk('RENDPARAMS',\$buffer,1,0);
    }
  }  

sub missionDescription
  {
  # get/set mission description (number and name/path)
  # named parameters: number (long), path (string, max. 8 chars)
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk("DARKMISS"));
    my @r = unpack ("LZ256", $$buffer) if (defined $buffer);
    @r = ("",0) if (!defined $buffer);
    return { number => $r[0], path => $r[1] };
    }
  else
    {
    $p = { @_ } if (ref($p) ne 'HASH'); # user did give array
    my $a = $p->{path} || ""; 
    my $buffer = pack ("LZ".(length($a)+1), ($p->{number} || 0),$a);
    $s->putChunk('DARKMISS',\$buffer,1,0);
    }
  }  

sub scriptModules
  {
  # get/set script modules
  # parameters: list (of modulenames)
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk("ScrModules"));
    my $count = length($$buffer)/128;
    my @r = unpack ("Z128"x$count, $$buffer) if (defined $buffer);
    @r = ("") if (!defined $buffer);
    return @r;
    }
  else
    {
    my $buffer = ""; my %names;
    foreach (@_) 
      {
      $names{uc($_)} = 1;
      }
    foreach (keys %names) { $buffer .= pack ("Z128", $_); }
    $s->putChunk('ScrModules',\$buffer,1,1);
    }
  }  

sub skyMode
  {
  # get/set sky mode (0 = textures, 1 => stars)
  # parameters: skymode 
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk('SKYMODE'));
    my @r = unpack ("L", $$buffer) if (defined $buffer);
    $r[0] = 0 if (!defined $buffer);
    return $r[0];
    }
  else
    {
    my $buffer = "";
    $buffer .= pack ("L", $p); 
    $s->putChunk('SKYMODE',\$buffer,1,0);
    }
  }  

sub gamesysName
  {
  # get/set name of game sys file 
  # parameters: name (with extension, if missing, .gam will be added)
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk('GAM_FILE'));
    return "" if (!defined $buffer);
    return unpack ("Z256", $$buffer);
    }
  else
    {
    $p .= ".GAM" if ($p !~ /\..*$/);
    my $buffer = pack ("Z256", $p); 
    $s->putChunk('GAM_FILE',\$buffer,0,1);
    }
  }

sub fileType
  {
  # get/set type file (VBRFILE/GAMFILE,MISFILE)
  # parameters: type 
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk('FILE_TYPE'));
    return 0 if (!defined $buffer);
    return unpack ("L", $$buffer);
    }
  else
    {
    my $buffer = pack ("L", $p); 
    $s->putChunk('FILE_TYPE',\$buffer,1,0);
    }
  }

sub paddedNamesChunk
  {
  # get/set list of names (for hotRegions and multibrush)
  # returns : ref_to_hash
  # parameters: chunkname, ref_to_hash (containing timeid => name)
  my $s = shift || return;
  my $cname = shift;
  my $p = $_[0];
  my ($id,$len,$length,$name,$ofs,$hr);
  if (!defined $p)
    {
    $hr = {};
    my $buffer = $s->stripHeader($s->getChunk($cname));
    return $hr if (!defined $buffer);
    $ofs = 0;
    # throw away first entry
    ($id,$length) = unpack ("LL",substr($$buffer,$ofs,8)); $ofs += 8;
    $name = unpack("Z".$length,substr($$buffer,$ofs,$length)); $ofs += $length;
    $len = length($$buffer);
    while ($ofs < $len)
      {  
      ($id,$length) = unpack ("LL",substr($$buffer,$ofs,8)); $ofs += 8;
      last if ($id == 0xFFFFFFFF); # stop at padding area
      $name = unpack("Z".$length,substr($$buffer,$ofs,$length));
      $ofs += $length;
      $hr->{$id} = $name;
      }
    return $hr;
    }
  else
    {
    my $buffer = pack ("LLZ11", 0x0100,length($cname)+1,$cname); # fixed string & ID 
    $ofs = length($buffer);
    foreach (keys %$p) 
      {
      next if ($p->{$_} eq ""); # skip empty ones
      $len = length($p->{$_})+1;
      $buffer .= pack ("LLZ$len", $_,$len,$p->{$_});
      $ofs += 8+$len; 
      }
    # dromed likes to padd it with 0xFF so we do, too 
    # put at least 16 in case Dromed unpacks id+length (8) plus some for
    # safety (8). Do we really need as much as DromEd adds?
    $buffer .= "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF";
    $s->putChunk($cname,\$buffer,1,0);
    }
  }

sub hotRegions
  {
  # get/set list of names of hotregions (area brushes)
  # returns : ref_to_hash
  # parameters: ref_to_hash (containing name => timeid)
  my $s = shift || return;
  return $s->paddedNamesChunk('HotRegions',@_);
  }

sub multibrushes
  {
  # get/set list of names of multibrushs
  # returns : ref_to_hash
  # parameters: ref_to_hash (containing name => timeid)
  my $s = shift || return;
  return $s->paddedNamesChunk('MultiBrush',@_);
  }

########################################################################
# Thief II

sub songParams
  {
  # get/set song params (string) (thief 2 only)
  # parameters: type 
  my $s = shift || return;
  my $p = $_[0];
  if (!defined $p)
    {
    my $buffer = $s->stripHeader($s->getChunk('SONGPARAMS'));
    return "" if (!defined $buffer);
    return unpack ("Z32", $$buffer);
    }
  else
    {
    my $buffer = pack ("Z32", $p); 
    $s->putChunk('SONGPARAMS',\$buffer,1,0);
    }
  }

1;
