pure perl mopaq parser setup

To get started. Can read and parse a mpq header, but neither good nor
efficient. Built from format description at
https://zohar.devklog.net/projects/mpqkit/wiki/MoPaQ_Format

diff --git a/sc.pl b/sc.pl
new file mode 100755 (executable)
index 0000000..222cf1c
--- /dev/null
+++ b/sc.pl
@@ -0,0 +1,289 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Data::Dumper;
+
+{
+#package Data::MPQ::SCM;
+#package File::StarCraft::Map;
+package Archive::MoPaQ;
+
+use strict;
+use warnings;
+use Data::Dumper;
+
+{
+
+sub overflow ($$) {
+       my $self = shift;
+       $_[0] %= 0xFFFF_FFFF + 1;
+}
+
+my @crypttable;
+{
+       my $seed = 0x0010_0001;
+
+       for my $i1 (0 .. 0x100) {
+               my $i2 = $i1;
+               for (0 .. 4) {
+                       $seed  = ($seed * 125 + 3) % 0x2AAAAB;
+                       my $temp1 = ($seed & 0xFFFF) << 16;
+
+                       $seed  = ($seed * 125 + 3) % 0x2AAAAB;
+                       my $temp2 = ($seed & 0xFFFF);
+
+                       $crypttable[$i2] = ($temp1 | $temp2);
+
+                       $i2 += 0x100;
+               }
+       }
+}
+
+sub hashstr {
+       my $self = shift;
+       my ($str, $type) = @_;
+       my ($seed1, $seed2) = (0x7FED_7FED, 0xEEEE_EEEE);
+       for my $ch (unpack "C*", uc $str) {
+               $seed1 += $seed2;
+               $self->overflow($seed1);
+               $seed1 ^= $crypttable[$type*0x100 + $ch];
+               $seed2 *= 33;
+               $seed2 += $ch + $seed1 + 3;
+               $self->overflow($seed2);
+       }
+       return $seed1;
+}
+
+sub decrypt ($$$) {
+       my $self = shift;
+       my ($in, $key) = @_;
+       my $seed = 0xEEEE_EEEE;
+
+       my @out = unpack "V*", $in;
+       for my $ch (@out) {
+               $seed += $crypttable[0x400 + ($key & 0xFF)];
+               $self->overflow($seed);
+               $ch ^= $self->overflow($key + $seed);
+               $key = $self->overflow((~$key << 21) + 0x1111_1111) | ($key >> 11);
+               $seed *= 33;
+               $seed += $ch + 3;
+       }
+       return pack "V*", @out;
+}
+
+}
+
+# Archive Header - File Data - File Data - Special Files - Hash Table - Block Table - Extended Block Table - Strong Digital signature
+
+sub new {
+       my ($class, $file) = @_;
+       my $fh = $file || \*STDIN;
+       bless {
+               fh => $fh,
+       }, $class;
+}
+
+sub _read {
+       my $self = shift;
+       my ($size, $seek) = @_;
+       my $fh = $self->{fh};
+       seek *$fh, $seek, 0 if $seek;
+       read(*$fh, my $in, $size) eq $size or return undef;
+       return $in;
+}
+
+sub open {
+       my $self = shift;
+
+       local $_ = $self->_read(8) #, 0
+               and my ($magic, $headsize) = unpack "a4V", $_
+               or die "Couldn't read file header\n";
+
+       $magic eq "MPQ\032"
+               or die "File is not a valid MoPaQ archive\n";
+
+       $headsize == 32
+               or die "Unrecognized header size\n";
+
+       $self->{header} = $self->_read($headsize) #, 8
+               or die "Couldn't read header of $headsize bytes\n";
+
+       my (
+               $archivesize,  # Size of the whole archive, including the header. Does not include the strong digital signature, if present. This size is used, among other things, for determining the region to hash in computing the digital signature. This field is deprecated in the Burning Crusade MoPaQ format, and the size of the archive is calculated as the size from the beginning of the archive to the end of the hash table, block table, or extended block table (whichever is largest).
+               $version,      # MoPaQ format version. MPQAPI will not open archives where this is negative. Known versions:
+# 0000h: Original format. HeaderSize should be 20h, and large archives are not supported.
+# 0001h: Burning Crusade format. Header size should be 2Ch, and large archives are supported.
+               $sectorsize,   # Power of two exponent specifying the number of 512-byte disk sectors in each logical sector in the archive. The size of each logical sector in the archive is 512 * 2^SectorSizeShift. Bugs in the Storm library dictate that this should always be 3 (4096 byte sectors).
+
+               $hashoffset,  # Offset to the beginning of the hash table, relative to the beginning of the archive.
+               $blockoffset,  # Offset to the beginning of the block table, relative to the beginning of the archive.
+               $hashentries, # Number of entries in the hash table. Must be a power of two, and must be less than 2^16 for the original MoPaQ format, or less than 2^20 for the Burning Crusade format.
+               $blockentries, # Number of entries in the block table.
+       ) = unpack "Vvcx VVVV", $self->{header};
+
+       my (
+               $eblockoffset, # (>=BC) Offset to the beginning of the extended block table, relative to the beginning of the archive.
+               $hashoffsethb, # (>=BC) High 16 bits of the hash table offset for large archives.
+               $blockoffsethb, # (>=BC) High 16 bits of the block table offset for large archives.
+       ) = unpack "C8ss", substr $self->{header}, -4 if $version >= 1;
+
+       my $hashdata = $self->_read($hashentries * 16, $hashoffset)
+               or die $!;
+       $self->{hash} = {
+               map unpack("a11xV", $_),
+               unpack "(a16)*", $self->decrypt($hashdata, $self->hashstr('(hash table)', 3))
+       };
+
+       my $blockdata = $self->_read($blockentries * 16, $blockoffset)
+               or die $!;
+       $self->{block} = [
+               unpack "(a16)*", $self->decrypt($blockdata, $self->hashstr('(block table)', 3))
+       ];
+
+       return $self;
+}
+
+sub extract {
+       my $self = shift;
+       my ($index) = @_;
+       my (
+               $offset,   # Offset of the beginning of the block, relative to the beginning of the archive.
+               $size,     # Size of the block in the archive.
+               $filesize, # Size of the file data stored in the block. Only valid if the block is a file; otherwise meaningless, and should be 0. If the file is compressed, this is the size of the uncompressed file data.
+               $flags,
+       ) = unpack "V4", $self->{block}[$index];
+
+       my $data = $self->_read($size, $offset) or die $!;
+       $self->decrypt($data, 0);
+}
+
+}
+
+{
+
+package Data::StarCraft::Map;
+
+use constant {
+       BWREP_HEADER_SIZE => 0x279,
+};
+
+sub new {
+       my ($class, $file) = @_;
+       my $fh = $file || \*STDIN;
+       bless {
+               fh => $fh,
+       }, $class;
+}
+
+sub _read {
+       my $self = shift;
+       my ($size, $seek) = @_;
+       my $fh = $self->{fh};
+       seek *$fh, $seek, 0 if $seek;
+       read(*$fh, my $in, $size) eq $size or return undef;
+       return $in;
+}
+
+=cut
+sub unpack {
+       my %esi;
+       $esi{m24} = rep;
+       $esi{m1C} = 0x800;
+       $esi{m20} = func_esi28(myesi->m2234, myesi->m1C, myesi->m24);
+       $esi{m20} <= 4 and return 3;
+       $esi{m04} = (int)rep->src[0];
+       $esi{m0C} = (int)rep->src[1];
+       $esi{m14} = (int)rep->src[2];
+       $esi{m18} = 0;
+       $esi{m1C} = 3;
+       $esi{m0C} < 4 || $esi{m0C} > 6 and return 1;
+       $esi{m10} = (1 << $esi{m0C}) - 1;  # 2^n - 1
+
+#      /* if ($esi{m04} == 1) printf("Oops\n"); */                        /* Should never be true */
+       $esi{m04} == 0 or return 2;
+
+       memcpy(myesi->m30F4, off_5071D0, sizeof(off_5071D0));               /* dst, src, len */
+       com1(sizeof(off_5071E0), myesi->m30F4, off_5071E0, myesi->m2B34);   /* len, src, str, dst */
+       memcpy(myesi->m3104, off_5071A0, sizeof(off_5071A0));               /* dst, src, len */
+       memcpy(myesi->m3114, off_5071B0, sizeof(off_5071B0));               /* dst, src, len */
+       memcpy(myesi->m30B4, off_507120, sizeof(off_507120));               /* dst, src, len */
+       com1(sizeof(off_507160), myesi->m30B4, off_507160, myesi->m2A34);   /* len, src, str, dst */
+       unpack_rep_chunk(myesi);
+}
+=cut
+
+sub unpack_section
+{
+       my ($self, $size) = @_;
+
+       $size > 0 or return;
+=cut
+#    replay_enc_t    rep;
+#    esi_t           myesi;
+#    byte            buffer[0x2000];
+#    int             check, count, length, n, len=0, m1C, m20=0;
+
+       my $check = $self->_read(4) or return;
+       my $count = $self->_read(4) or return;
+
+       my $m20 = 0;
+       for (my $n = 0, $m1C = 0; $n < $count; $n++, $m1C += sizeof(buffer), $m20 += $len) {
+               my $length = $this->_read(4);
+               $length <= $size - $m20 or return;
+               my $result = $this->_read($length) or return;
+               continue if $length == min($size - $m1C, sizeof($buffer));
+
+               # init rep struct 
+               rep.src = (byte*)result;
+               rep.m04 = 0;
+               rep.m08 = $buffer;
+               rep.m0C = 0;
+               rep.m10 = $length;
+               rep.m14 = sizeof(buffer);
+               # unpack replay section 
+               if (unpack_rep_section(&myesi, &rep) == 0 && rep.m0C <= sizeof(buffer)) len = rep.m0C; else len = 0;
+               if (len == 0 || len > size) return 4;
+
+               # Main decompression functions
+               /*
+               unsigned long outlength = sizeof(buffer);
+               Explode4(buffer, &outlength, result, length);
+               len = (int)outlength;
+               */
+
+               memcpy(result, buffer, len);
+               $result += $len;
+       }
+       return $check;
+}
+=cut
+
+sub open {
+       my $self = shift;
+
+       local $_ = $self->_read(16)
+               and my ($magic, $headsize) = unpack "a16", $_
+               or die "Couldn't read file header\n";
+
+       $magic eq "\xA7\x7E\x7E\x2B\001\000\000\000\004\000\000\000reRS"
+               or die "File is not a valid starcraft replay\n";
+
+       $self->{header} = $self->unpack_section(BWREP_HEADER_SIZE)
+               or die "Couldn't read header of ".BWREP_HEADER_SIZE." bytes\n";
+}
+
+}
+
+my $rep = Data::StarCraft::Map->new;
+$rep->open;
+print join ",", map ord, split //, $rep->{header};
+print "\n";
+exit;
+
+my $mpq = Archive::MoPaQ->new;
+$mpq->open;
+print $mpq->extract(0);
+#print Dumper [ $mpq->extract(0) ];
+
+#print Dumper pack('V*', $self->hashstr('(index)', 1));
+