tools/perllib/Customization.pm

   1 package Customization;
   2
   3 use strict;
   4 use warnings;
   5
   6 # Module boiler plating.
   7
   8 BEGIN {
   9         use Exporter   ();
  10         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  11
  12         # set the version for version checking
  13         $VERSION         = 1.00;
  14         @ISA             = qw(Exporter);
  15         # @EXPORT          = qw(&func1 &func2 &func4);
  16         @EXPORT          = qw(&createNewDataFromVariableInfo &dumpStringInHex &dumpVariableInfo &escapeBinaryData &getVariableInfoFromNewString &getVariableInfoFromOldString &initializeCustomization &removeEscapesFromString);
  17         %EXPORT_TAGS = ( );             # eg: TAG => [ qw!name1 name2! ],
  18
  19         # your exported package globals go here,
  20         # as well as any optionally exported functions
  21         # @EXPORT_OK   = qw($Var1 %Hashit &func3);
  22         @EXPORT_OK         = qw(%IdsByVariableName %VariableNamesById);
  23 }
  24 our @EXPORT_OK;
  25
  26 # exported package globals go here
  27 # e.g.
  28 # our $Var1;
  29 # our %Hashit;
  30
  31 our %IdsByVariableName;
  32 our %VariableNamesById;
  33
  34 # non-exported package globals go here
  35 # e.g.
  36 # our @more;
  37 # our $stuff;
  38 our $Debug;
  39
  40 # initialize package globals, first exported ones
  41 # e.g.
  42 # $Var1   = '';
  43 # %Hashit = ();
  44 %IdsByVariableName = ();
  45 %VariableNamesById = ();
  46
  47 # then the others (which are still accessible as $Some::Module::stuff)
  48 # $stuff  = '';
  49 # @more   = ();
  50 $Debug = 0;
  51
  52 # all file-scoped lexicals must be created before
  53 # the functions below that use them.
  54
  55 # file-private lexicals go here
  56 # e.g.
  57 # my $priv_var    = '';
  58 # my %secret_hash = ();
  59
  60 # here's a file-private function as a closure,
  61 # callable as &$priv_func;      it cannot be prototyped.
  62 # e.g.
  63 # my $priv_func = sub {
  64 #         # stuff goes here.
  65 # };
  66
  67 # make all your functions, whether exported or not;
  68 # remember to put something interesting in the {} stubs
  69 # e.g.
  70 # sub func1              {}        # no prototype
  71 # sub func2()    {}        # proto'd void
  72 # sub func3($$)  {}        # proto'd to 2 scalars
  73
  74 # this one isn't exported, but could be called!
  75 # e.g.
  76 # sub func4(\%)  {}        # proto'd to 1 hash ref
  77
  78 # ======================================================================
  79
  80 sub dumpStringInHex($)
  81 {
  82         my $data           = shift;
  83         my $dataLength = length $data;
  84
  85         print STDERR "dumping string (length=$dataLength characters):\n";
  86         for (my $i = 0; $i < $dataLength; ++$i)
  87         {
  88                 my $character = substr($data, $i, 1);
  89                 if ($character =~ m/\w/)
  90                 {
  91                         printf STDERR "$i: 0x%x ($character)\n", ord($character);
  92                 }
  93                 else
  94                 {
  95                         printf STDERR "$i: 0x%x (<?>)\n", ord($character);
  96                 }
  97         }
  98 }
  99
 100 # ======================================================================
 101 # input: reference to variable info hash,
 102 #                directory string from old-style customization data,
 103 #                string representing variable path up to this point.
 104 #
 105 # output: results returned in variable info hash.
 106 #
 107 # return: return code, 1 if successful, 0 if failed.
 108 #
 109 # private
 110 # ======================================================================
 111
 112 # Extra prototype needed for recursive calling within function.
 113 sub getVariableInfoFromOldStringDirectory(\%$$);
 114
 115 sub getVariableInfoFromOldStringDirectory(\%$$)
 116 {
 117         my $variableInfoRef = shift;
 118         my $dirData                     = shift;
 119         my $fullDirectory       = shift;
 120
 121         # Grab # variables.
 122         if (($dirData =~ s/^([0-9a-fA-F]+)\#//) == 0)
 123         {
 124                 warn "getVariableInfoFromOldStringDirectory(): failed to parse variable count from dir data [$dirData].\n";
 125                 return 0;
 126         }
 127
 128         # Process variables local to this directory.
 129         my $varCount = hex($1);
 130         print "<dir: [$fullDirectory] has $varCount variables.>\n" if $Debug;
 131
 132         for (my $varIndex = 0; $varIndex < $varCount; ++$varIndex)
 133         {
 134                 #-- Variable format: <variable name>#<contentByteCount>#<contents>
 135                 if (($dirData =~ s/^(\w+)\#([0-9a-fA-F]+)\#//) == 0)
 136                 {
 137                         warn "getVariableInfoFromOldStringDirectory(): failed to parse variable name, content size and contents from dir data [$dirData].\n";
 138                         return;
 139                 }
 140
 141                 my $varShortName = $1;
 142                 my $varDataLength = hex($2);
 143
 144                 #-- Take the first $varDataLength bytes off the front of $dirData.
 145                 my $varData = hex(substr($dirData, 0, $varDataLength));
 146                 $dirData        = substr($dirData, $varDataLength);
 147
 148                 #-- Try to fix negative numbers (assume anything over 32637 is really a negative number.
 149                 if (($varData =~ m/^\d+$/) && ($varData > 32637))
 150                 {
 151                         # Assume this is a 32-bit hex encoded negative number.  Fix it up.      I think this code can only
 152                         # work if perl is using 32-bit integers.
 153
 154                         # Do 2's complement formula in reverse to get the absolute value of the negative number.
 155                         my $negativeValue = ($varData - 1);
 156                         $negativeValue = ~$negativeValue;
 157
 158                         $varData = -$negativeValue;
 159                 }
 160
 161                 #-- Add variable to variable info hash.
 162                 my $varFullName = $fullDirectory . $varShortName;
 163                 $$variableInfoRef{$varFullName} = $varData;
 164                 print "<oldVar: [$varFullName] = [$varData]>\n" if $Debug;
 165         }
 166
 167         # Process subdirs local to this directory.
 168
 169         # Grab # subdirs.
 170         if (($dirData =~ s/^([0-9a-fA-F]+)\#//) == 0)
 171         {
 172                 warn "getVariableInfoFromOldStringDirectory(): failed to parse subdirectory count from dir data [$dirData].\n";
 173                 return 0;
 174         }
 175
 176         my $subdirCount = hex($1);
 177         print "<dir: [$fullDirectory] has $subdirCount subdirectories.>\n" if $Debug;
 178
 179         for (my $subdirIndex = 0; $subdirIndex < $subdirCount; ++$subdirIndex)
 180         {
 181                 #-- Variable format: <variable name>#<contentByteCount>#<contents>
 182                 if (($dirData =~ s/^(\w+)\#([0-9a-fA-F]+)\#//) == 0)
 183                 {
 184                         warn "getVariableInfoFromOldStringDirectory(): failed to parse dir name, content size and contents from dir data [$dirData].\n";
 185                         return;
 186                 }
 187
 188                 my $dirShortName = $1;
 189                 my $dirDataLength = hex($2);
 190
 191                 #-- Take the first $varDataLength bytes off the front of $dirData.
 192                 my $subdirData = substr($dirData, 0, $dirDataLength);
 193                 $dirData           = substr($dirData, $dirDataLength);
 194
 195                 #-- Recursively call this function to process the local directory's data.
 196                 my $dirFullName = $fullDirectory . $dirShortName . '/';
 197                 print "<oldDir: [$dirFullName]>\n" if $Debug;
 198
 199                 getVariableInfoFromOldStringDirectory(%$variableInfoRef, $subdirData, $dirFullName);
 200         }
 201
 202         # Indicate success.
 203         return 1;
 204 }
 205
 206 # ======================================================================
 207 # input: reference to variable info hash,
 208 #                directory string from old-style customization data,
 209 #
 210 # output: results returned in variable info hash.
 211 #
 212 # return: return code, 1 if successful, 0 if failed.
 213 # ======================================================================
 214
 215 sub getVariableInfoFromOldString(\%$)
 216 {
 217         # Get parameters.
 218         my $variableInfoRef = shift;
 219         my $oldString           = shift;
 220
 221         # Get the version number.
 222         if (($oldString =~ s/^([0-9a-fA-F]+)\#//) == 0)
 223         {
 224                 warn "getVariableInfoFromOldString:could not parse out version number:string [$oldString]\n";
 225                 return "";
 226         }
 227
 228         if (hex($1) != 2)
 229         {
 230                 warn "getVariableInfoFromOldString:version number [$1] unsupported:string [$oldString]\n";
 231                 return "";
 232         }
 233
 234         # Fill up variable info from the root directory '/'.
 235         return getVariableInfoFromOldStringDirectory(%$variableInfoRef, $oldString, '/');
 236 }
 237
 238 # ======================================================================
 239 # input:  reference to variable info hash
 240 # output: variables encoded with binary encoding scheme version 1.
 241 #
 242 # A variable info hash is a simple hash mapping a full customization
 243 # variable path (e.g. /shared_owner/index_color_skin) to its value
 244 # (e.g. 3).
 245 # ======================================================================
 246
 247 sub createNewDataFromVariableInfo(\%)
 248 {
 249         # Build output string.
 250         my $newData = "";
 251
 252         # Write version number.
 253         $newData .= chr(1);
 254
 255         # Process each variable in the hash mapping variable name to value.
 256         my $varInfoRef    = shift;
 257         my @variableNames = keys %$varInfoRef;
 258
 259         # Pass 1: count how many of these vars exist in the id table.  Any vars not
 260         #                 in the id table will be lost.
 261         my $existingVariableCount = 0;
 262
 263         foreach my $variableName (@variableNames)
 264         {
 265                 # Get value for variable.
 266                 if (defined($IdsByVariableName{$variableName}))
 267                 {
 268                         ++$existingVariableCount;
 269                 }
 270                 else
 271                 {
 272                         print "<varNotMapped: variable [$variableName] length [" . (length $variableName) . "] referenced but is not mapped, dropping value.>\n" if $Debug;
 273                 }
 274         }
 275
 276         # Write variable count.
 277         $newData .= chr($existingVariableCount);
 278
 279         # Setup minimum expected data size.
 280         my $minExpectedDataLength = 2 + 2 * $existingVariableCount;
 281
 282         foreach my $variableName (keys %$varInfoRef)
 283         {
 284                 # Process only if variable exists.
 285                 next if !defined($IdsByVariableName{$variableName});
 286
 287                 # Get id for variable name.
 288                 my $variableId = $IdsByVariableName{$variableName};
 289                 die "variableId $variableId out of valid range 1..127" if ($variableId < 1) || ($variableId > 127);
 290
 291                 my $byteCount;
 292
 293                 # Build combined id: most significant bit is turned on if value is signed short; otherwise value is unsigned char.
 294                 # NOTE: this code assumes only the variable named <something>/blend_flat_chest can contain signed short values since
 295                 #               I have no range info at this stage of the game.  True at time of upgrade.
 296                 if ($variableName =~ m!/blend_flat_chest$!i)
 297                 {
 298                         $variableId |= 0x80;
 299                         $byteCount = 2;
 300                 }
 301                 else
 302                 {
 303                         $byteCount = 1;
 304                 }
 305
 306                 # Get value for variable.
 307                 my $value = $$varInfoRef{$variableName};
 308
 309                 # Write variable id and data.
 310                 $newData .= chr($variableId);
 311                 if ($byteCount == 1)
 312                 {
 313                         $newData .= chr($value & 0xff);
 314                 }
 315                 else
 316                 {
 317                         # Store 16-bit 2's complement number, within range -32768 .. 32767.      As long as this machine uses
 318                         # 2's complement for signed integers, and assuming Perl guarantees at least 32 bits of precision on integer math,
 319                         # then it doesn't matter how many bits the value is stored in so long as the value is within the specified range.
 320                         if ($value > 32767)
 321                         {
 322                                 $value = 32767;
 323                         }
 324                         elsif ($value < -32768)
 325                         {
 326                                 $value = -32768;
 327                         }
 328
 329                         $newData .= chr($value & 0xff);
 330                         $newData .= chr(($value & 0xff00) >> 8);
 331                 }
 332         }
 333
 334         # Check min size.
 335         my $newDataLength = length $newData;
 336         if ($newDataLength < $minExpectedDataLength)
 337         {
 338                 warn "wrote fewer bytes than expected; min expected=$newDataLength, written=$newDataLength.";
 339                 dumpVariableInfo(%$varInfoRef);
 340         }
 341
 342         return $newData;
 343 }
 344
 345 # ======================================================================
 346 # input:  variable info hash, mapping full-path variable info name to value.
 347 # output: dumps variable names and values, sorted by variable name.
 348 # ======================================================================
 349
 350 sub dumpVariableInfo(\%)
 351 {
 352         my $variableInfoRef = shift;
 353
 354         foreach my $variableName (sort keys %$variableInfoRef)
 355         {
 356                 my $value = $$variableInfoRef{$variableName};
 357                 print "[$variableName]=[$value]\n";
 358         }
 359 }
 360
 361 # ======================================================================
 362 # input:  string, possibly with embedded nulls, to be escaped so it doesn't contain embedded nulls.
 363 # output: string, possibly with added escape characters, does not contain any NULLs.
 364 # ======================================================================
 365
 366 sub escapeBinaryData($)
 367 {
 368         my $rawString     = shift;
 369         my $escapedString = "";
 370
 371         my $rawLength = length $rawString;
 372         for (my $i = 0; $i < $rawLength; ++$i)
 373         {
 374                 my $rawChar = substr($rawString, $i, 1);
 375                 if (ord($rawChar) == 0)
 376                 {
 377                         # replace 0x00 with 0xff 0x01
 378                         $escapedString .= chr(0xff) . chr(0x01);
 379                 }
 380                 elsif (ord($rawChar) == 0xff)
 381                 {
 382                         # replace 0xff with 0xff 0x02
 383                         $escapedString .= chr(0xff) . chr(0x02);
 384                 }
 385                 else
 386                 {
 387                         $escapedString .= $rawChar;
 388                 }
 389         }
 390
 391         # Add end-of-data marker.
 392         $escapedString .= chr(0xff);
 393         $escapedString .= chr(0x03);
 394
 395         return $escapedString;
 396 }
 397
 398 # ======================================================================
 399 # input: escaped string.
 400 # output: de-escaped binary data with possible embedded nulls.
 401 # ======================================================================
 402
 403 sub removeEscapesFromString($)
 404 {
 405         my $escapedString = shift;
 406         my $rawString     = "";
 407
 408         my $escapedLength = length $escapedString;
 409         for (my $i = 0; $i < $escapedLength; ++$i)
 410         {
 411                 my $escapedChar = substr($escapedString, $i, 1);
 412                 if (ord($escapedChar) == 0xff)
 413                 {
 414                         # Look at next escaped character to find out what the
 415                         # real binary value looks like, consume it.
 416                         my $nextChar = substr($escapedString, $i+1, 1);
 417                         ++$i;
 418
 419                         if (ord($nextChar) == 0x01)
 420                         {
 421                                 # this is the escape sequence 0xff 0x01 => 0x00
 422                                 $rawString .= chr(0x00);
 423                         }
 424                         elsif (ord($nextChar) == 0x02)
 425                         {
 426                                 # this is the escape sequence 0xff 0x02 => 0xff
 427                                 $rawString .= chr(0xff);
 428                         }
 429                         elsif (ord($nextChar) == 0x03)
 430                         {
 431                                 # ignore, end of data marker.
 432                                 if (($i + 1) != $escapedLength)
 433                                 {
 434                                         warn "found escape for end of data, but at index " . ($i+1) . " of total length $escapedLength.";
 435                                 }
 436                         }
 437                         else
 438                         {
 439                                 my $warningString;
 440                                 $warningString = sprintf("removeEscapesFromString: found invalid escape sequence 0xff 0x%x in escaped string [$escapedString], escape failure.\n", ord($nextChar));
 441                                 warn $warningString;
 442                                 return "";
 443                         }
 444                 }
 445                 else
 446                 {
 447                         $rawString .= $escapedChar;
 448                 }
 449         }
 450
 451         return $rawString;
 452 }
 453
 454 # ======================================================================
 455 # input: pass-by-reference variable info hash.  Will be filled upon return.
 456 # return: 1 if successful, 0 if false.
 457 # ======================================================================
 458
 459 sub getVariableInfoFromNewString(\%$)
 460 {
 461         # Get parameters.
 462         my $variableInfoRef       = shift;
 463         my $encodedDataString = shift;
 464
 465         if ($Debug)
 466         {
 467                 print "<getVariableInfoFromNewString: dumping escaped string>\n";
 468                 dumpStringInHex($encodedDataString);
 469         }
 470
 471         my $data = removeEscapesFromString($encodedDataString);
 472
 473         if ($Debug)
 474         {
 475                 print "<getVariableInfoFromNewString: dumping unescaped string>\n";
 476                 dumpStringInHex($data);
 477         }
 478
 479         # Get version.
 480         my $dataLength = length $data;
 481         my $dataIndex  = 0;
 482
 483         if (ord(substr($data, $dataIndex, 1)) != 1)
 484         {
 485                 warn "getVariableInfoFromNewString: unsupported version " . ord(substr($data, $dataIndex, 1));
 486                 return 0;
 487         }
 488         ++$dataIndex;
 489
 490         # Get variable count.
 491         my $variableCount = ord(substr($data, $dataIndex, 1));
 492         ++$dataIndex;
 493
 494         # Do a quick string size sanity check.
 495         my $minExpectedLength = 2 + $variableCount * 2;
 496         if ($dataLength < $minExpectedLength)
 497         {
 498                 warn "getVariableInfoFromNewString: encoded data string is too small for encoded variable count [$variableCount], expecting at least [$minExpectedLength], has [$dataLength] bytes, padding with 0x20.";
 499                 dumpStringInHex($encodedDataString);
 500                 dumpStringInHex($data);
 501
 502                 # Try padding with spaces.
 503                 $data .= chr(0x20) x ($minExpectedLength + 1 - $dataLength);
 504                 $dataLength = $minExpectedLength + 1;
 505         }
 506
 507         # Handle each variable.
 508         for (my $variableIndex = 0; $variableIndex < $variableCount; ++$variableIndex)
 509         {
 510                 if ($dataIndex + 1 >= $dataLength)
 511                 {
 512                         warn "Truncating variable unpacking due to unexpected termination of packed data.\n";
 513                         last;
 514                 }
 515
 516                 # Get combined variable id.
 517                 my $combinedId = ord(substr($data, $dataIndex, 1));
 518                 ++$dataIndex;
 519
 520                 # Break combined Id into data length and variable id.
 521                 my $variableId             = $combinedId & 0x7f;
 522                 my $variableDataLength = (($combinedId & 0x80) != 0) ? 2 : 1;
 523
 524                 # Get variable's value.
 525                 my $variableValue;
 526
 527                 if ($variableDataLength == 2)
 528                 {
 529                         # Read & interpret as signed 16-bit value.
 530                         my $lowByte = ord(substr($data, $dataIndex, 1));
 531                         ++$dataIndex;
 532
 533                         my $hiByte = ord(substr($data, $dataIndex, 1));
 534                         ++$dataIndex;
 535                         $hiByte = 0x20 if !defined($hiByte);
 536
 537                         if (($hiByte & 0x80) != 0)
 538                         {
 539                                 # represents a negative number.
 540
 541                                 # get binary representation right: assumes 32-bit perl representation, not guaranteed on all platforms.
 542                                 my $negativeValue = 0xffff0000 | ($hiByte << 8) | $lowByte;
 543
 544                                 # interpret as signed integer.
 545                                 $variableValue = sprintf("%d", $negativeValue);
 546                         }
 547                         else
 548                         {
 549                                 $variableValue = ($hiByte << 8) | $lowByte;
 550                         }
 551                 }
 552                 else
 553                 {
 554                         # Read & interpret as single unisgned byte.
 555                         $variableValue = ord(substr($data, $dataIndex, 1));
 556                         ++$dataIndex;
 557                 }
 558
 559                 # Lookup variable name by value.
 560                 my $variableName = $VariableNamesById{$variableId};
 561                 if (!defined($variableName))
 562                 {
 563                         print "newData: found variable id [$variableId] with no name mapping.\n";
 564                         return 0;
 565                 }
 566
 567                 # Map variable name to value in returned parameter
 568                 print "<getVariableInfoFromNewString: variable [$variableName] appears multiple times in customization data>\n" if ($Debug && defined($$variableInfoRef{$variableName}));
 569                 $$variableInfoRef{$variableName} = $variableValue;
 570         }
 571
 572         # Indicate success.
 573         return 1;
 574 }
 575
 576 # ======================================================================
 577 # Read variable id assignment info from customization id manager's MIF file.
 578 #
 579 # input:
 580 #        string: CustomizationIdManager's initialization MIF filename.
 581 # ======================================================================
 582
 583 sub initializeCustomization($)
 584 {
 585         my $filename = shift;
 586         open(MIF_FILE, $filename) or die "failed to open specified CustomizationIdManager mif file [$filename]: $!";
 587
 588         my $nextAssignmentId = 0;
 589         my $expectingId          = 1;
 590
 591         while (<MIF_FILE>)
 592         {
 593                 chomp();
 594                 if (m/int16\s+(\d+)\s*$/)
 595                 {
 596                         # Ensure we're expecting a new id.
 597                         die "error: file [$filename] appears malformed, out of order int16/cstring declarations.\n" if !$expectingId;
 598                         $expectingId = 0;
 599
 600                         $nextAssignmentId = $1;
 601                 }
 602                 elsif (m/cstring\s+\"([^\"]+)\"\s*$/)
 603                 {
 604                         # Ensure we're expecting a variable name.
 605                         die "error: file [$filename] appears malformed, out of order int16/cstring declarations.\n" if $expectingId;
 606                         $expectingId = 1;
 607
 608                         # Add new variable name.  It is associated with $nextAssignmentId collected previously.
 609                         $IdsByVariableName{$1}                            = $nextAssignmentId;
 610                         $VariableNamesById{$nextAssignmentId} = $1;
 611                         print "<existing: mapping variable name [$1] to [$nextAssignmentId]>\n" if $Debug;
 612                 }
 613         }
 614
 615         close(MIF_FILE);
 616
 617         return 1;
 618 }
 619
 620 # ======================================================================
 621
 622 END { }           # module clean-up code here (global destructor)
 623
 624 # Return true from the file.
 625 1;