Latest revision as of 22:37, 6 June 2009

[edit] Overview

This page contains a code in R that finds which clothes were created with the Pets EP Bodyshop with a bug.

Use at your own risk. Any comments please use the Talk:Detect Pets Body Shop bug/Source Code page.

[edit] Source

#
# read_package: reads a file (passed by filename)
# and returns a structure
#

library("bitops")     # required for bit operations
library("survival")   # required for date/time operations

debug.everything <- F

read_package <- function(filename, get.str = F, get.everything = F)
{
  # if (debug.everything) 
  f <- file(filename, open="rb")   # open as binary
  x <- read_package_header(f)      # get the header
  if (is.null(x)) {
    cat("Error in", filename, "\n")
    return(NULL)
  }
  x$index <- read_package_index_table(f, x)   # get index table
  x$dir <- read_package_dir(f, x)             # get DIR resource (but won't use it)
  # set compressed flag whenever index != dir
  # but won't use this (and this logic is wrong anyway)
  x$compressed <- NULL
  imax <- ifelse(x$n.index <= 0, 1, x$n.index)
  for (i in 1:imax)
    x$compressed[[i]] <- !(same_index(x$index[[i]], x$dir[[i]]))
  x$files <- NULL
  for (i in 1:imax) {
    x$files[[i]] <- NULL
  }

  # get the property set
  x$property.set <- read_package_property_set(f, x)

  # if this is a CASThumbnails package, do something with it
  x$thumb1 <- read_package_CASThumbnails(f, x)

  # get all files (not recommended: this is too slow)
  if (get.everything) {
    x1 <- x
    for (i in 1:imax) {
      cat("reading file", i, "\n")
      x$files[[i]] <- read_package_file(f, x1, i)
    }
  }

  # get all STR# resources
  if (get.str && !get.everything) {
    x1 <- x
    for (i in 1:imax) {
      if (x$index[[i]]$type.id == "53545223") {
        x$files[[i]] <- read_package_file(f, x1, i)
      }
    }
  }

  # game over
  close(f)
  return(x)
}

read_package_header <- function(f)
{
  x <- NULL    # return value
  x$dbpf <- readChar(f, 4)  # le char[4]
  if (x$dbpf != "DBPF") {
    cat("Error. Instead of DBPF, I got ", x$dbpf, "\n")
    return(NULL)
  }
  x$major <- readBin(f, "int")  # major version
  x$minor <- readBin(f, "int")  # minor version
  unused <- readBin(f, "int", n = 5)  # unused
  x$index.major <- readBin(f, "int")  # major version of index; always 7 in TS2
  x$n.index <- readBin(f, "int") # number of entries in the index
  x$first.index <- readBin(f, "int")  # location of first index entry
  x$size.index <- readBin(f, "int")  # size of index
  x$n.hole <- readBin(f, "int") # number of hole entries in Hole record
  x$location.hole <- readBin(f, "int") # location of Hole record
  x$size.hole <- readBin(f, "int") # size of Hole record
  x$index.minor <- readBin(f, "int") # Minor Version of index + 1
  x$index.minor <- x$index.minor - 1
  reserved <- readBin(f, "int", n = 8)  # 32 bytes (reserved)
  return(x)
}

read_package_file <- function(f, x1, i.index)
{
  file.index <- x1$index[[i.index]]
  seek(f, file.index$location)
  f1 <- NULL
  # compressed files must have a header
  f1$size <- readBin(f, "int")   # compressed size of file
  n <- file.index$size
  if (n <= 0)
    return(NULL)
  if (n == f1$size) {
    if (debug.everything) {
      cat("file[", i.index, "] is probably compressed\n")
      cat(sprintf("First 4 bytes at offset %08X = %08X\n", file.index$location, n))
    }
    f1$raw <- read_compressed_file(f, n - 4)
  }
  else {
    seek(f, -4, origin="current")
    f1$raw <- readBin(f, "raw", n)
  }
  f1$human <- convert_raw(f1$raw, file.index$type.id)  # convert raw to human-readable format
  return(f1)
}

read_package_index_table <- function(f, x1)
{
  seek(f, where = x1$first.index)
  t <- NULL
  imax <- ifelse(x1$n.index <= 0, 1, x1$n.index)
  for (i in 1:imax) {
    t[[i]] <- read_package_indexlike_entry(f, x1)
  }
  return(t)
}

read_package_dir <- function(f, x1)
{
  # find if any type.id in index is a DIR
  i.dir <- 0
  imax <- ifelse(x1$n.index <= 0, 1, x1$n.index)
  for (i in 1:imax) {
    if (x1$index[[i]]$type.id == "E86B1EEF") {  # DIR
      i.dir <- i
      break;
    }
  }
  if (i.dir == 0)
    return(NULL)
  seek(f, x1$index[[i.dir]]$location)
  d <- NULL
  for (i in 1:imax) {
    d[[i]] <- read_package_indexlike_entry(f, x1, location = x1$index[[i]]$location)
  }
  return(d)
}

#
# read one block of indexlike entries - used for Index and DIR
#
read_package_indexlike_entry <- function(f, x1, location)
{
  t1 <- NULL
  r1 <- readBin(f, "int", 4, size=1)  # Type ID
  if (length(r1) < 4) {    # error
    return(NULL)
  }
  r1 <- r1 %% 256
  t1$type.id <- sprintf("%02X%02X%02X%02X", r1[4], r1[3], r1[2], r1[1])
  t1$group.id <- readBin(f, "raw", 4) # Group ID
  t1$instance.id <- readBin(f, "raw", 4) # instance ID
  if (x1$index.minor == 1)   # version 7.1
    t1$second.instance.id <- readBin(f, "raw", 4)  # second instance ID
  if (missing(location))   # index
    t1$location <- readBin(f, "int")  # location of the file
  else
    t1$location <- location   # DIR
  t1$size <- readBin(f, "int")  # size of the file
  return(t1)
}

read_package_property_set <- function(f, x1)
{
  # find if any type.id in index is a Property Set
  i.property.set <- 0
  imax <- ifelse(x1$n.index <= 0, 1, x1$n.index)
  for (i in 1:imax) {
    if (x1$index[[i]]$type.id == "EBCF3E27") {  # Property Set
      i.property.set <- i
      break;
    }
  }
  if (debug.everything)
    cat("i.property.set =", i.property.set, "\n")
  if (i.property.set == 0)
    return(NULL)
  f1 <- NULL  #
  if (is.null(f1)) {
    f1 <- read_package_file(f, x1, i.property.set)
    return(f1)
  }
  # compressed files must have a header
  cat("These lines are never executed. Why I don't delete them?")
  f1$size <- readBin(f, "int")   # compressed size of file
  f1$qfs <- readBin(f, "raw", 2)  # 0x10FB
  f1$uncompressed.size <- readBin(f, "int")  # 3 bytes or 4 bytes ???
  r1 <- readBin(f, "int", 4, size=1)  # Type ID
  r1 <- r1 %% 256
  f1$type.id <- sprintf("%02X%02X%02X%02X", r1[4], r1[3], r1[2], r1[1])
  if (f1$type.id != "CBE7505E" && f1$type.id != "CBE750E0")
    return (f1)
  # CPF
  f1$version <- readBin(f, "int", size = 2)
  f1$n.items <- readBin(f, "int")
  f1$items <- NULL
  for (i in 1:(f1$n.items)) {
    f2 <- NULL
    r1 <- readBin(f, "int", 4, size=1)  # Type ID
    r1 <- r1 %% 256
    f2$data.type <- sprintf("%02X%02X%02X%02X", r1[4], r1[3], r1[2], r1[1])
    f2$length <- readBin(f, "int", size=1)
    if (debug.everything || f2$length <= 0)
      cat("data.type=", f2$data.type, "length =", f2$length, "\n")
    f2$name <- readBin(f, "character", f2$length)
    if (f2$data.type == "EB61E4F7" || f2$data.type == "0C264712") {   # int
      f2$data <- readBin(f, "int", f2$length)
    }
    else if (f2$data.type == "0B8BEA18") {   # string
      f2$data <- readBin(f, "character", f2$length)
    }
    else if (f2$data.type == "ABC78708") {   # float (4 bytes)
      f2$data <- readBin(f, "double", f2$length, size=4)
    }
    else if (f2$data.type == "CBA908E1") {   # boolean (1 byte)
      f2$data <- readBin(f, "raw", f2$length)
    }
    f1$items[[i]] <- f2
  }
  return(f1)
}

# depois de pegar o Index tem que pegar o DIR resource
# que comeca com ef 1e 6b e8
# CTSS = 53 53 54 43
# XML = 25 e9 a8 cc
# STR# = 23 52 54 53
# Property Set = EBCF3E27
#

read_package_CASThumbnails <- function(f, x1)
{
  if (x1$n.index <= 0)
    return(NULL)
  if (x1$index[[1]]$type.id != "0C7E9A76")
    return(NULL)
  f1 <- NULL  #
  if (is.null(f1)) {
    f1 <- read_package_file(f, x1, 1)
  }
  return(f1)
}

#
# Check if the entry from "index" is the same as from "dir"
#
same_index <- function(index, dir)
{
  if (is.null(dir))
    return(T)
  if (is.null(index$type.id) | is.null(dir$type.id) |
      is.null(index$group.id)| is.null(dir$group.id) |
      is.null(index$instance.id) | is.null(dir$instance.id) |
      is.null(index$location) | is.null(dir$location) |
      is.null(index$size) | is.null(dir$size))
    return(T)

  if (index$type.id != dir$type.id)
    return(F)
  if (any(index$group.id != dir$group.id))
    return(F)
  if (any(index$instance.id != dir$instance.id))
    return(F)
  if (index$location != dir$location)
    return(F)
  if (index$size != dir$size)
    return(F)
  return(T)
}

#
# read_compressed_file is dmchess's try_decompress
#
read_compressed_file <- function(FH, len, try_decompress = T)
{
  if (!try_decompress) {
    if (debug.everything || len <= 0)
      cat("Reading", len, "bytes as raw\n")
    answer <- readBin(FH, "raw", len - 4)
    return(answer)
  }
  header <- readBin(FH, "int", 5, size=1) %% 256 # first five bytes
  if (debug.everything)
    cat(sprintf("header = %02X %02X %02X %02X %02X\n", 
      header[1], header[2], header[3], header[4], header[5]));
  len <- len - 5
  answer <- NULL
  answerlen <- 0
  byte1 <- byte2 <- byte3 <- 0
  # begin of dmchess's try_decompress perl code converted to R
  sp <- seek(FH, where=NA) # my $sp = tell FH
  while (len > 0) {
    if (len %% 1000 == 0) cat(".")   # pacifier for very long files
    cc <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $cc = unpack "C", $buf;
    len <- len - 1 # $len -= 1;
#    printf "      Control char is %02x, len remaining is %08x. \n",$cc,$len;
    if (cc >= 0xfc) {
      numplain <- bitAnd(cc, 0x03) # $numplain = $cc & 0x03;
      if (numplain > len) numplain <- len # $numplain = $len if ($numplain > $len);
      numcopy <- 0
      offset <- 0
    } 
    else if (cc >= 0xe0)  {
      numplain <- bitShiftL(cc - 0xdf, 2) # $numplain = ($cc - 0xdf) << 2; 
      numcopy <- 0
      offset <- 0
    } 
    else if (cc >= 0xc0) {
      len <- len - 3 # $len -= 3;
      byte1 <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $byte1 = unpack "C", $buf;
      byte2 <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $byte2 = unpack "C", $buf;
      byte3 <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $byte3 = unpack "C", $buf;
      numplain <- bitAnd(cc, 0x03) # $numplain = $cc & 0x03;
      numcopy <- bitShiftL(bitAnd(cc, 0x0c), 6) + 5 + byte3 # $numcopy = (($cc & 0x0c) <<6) + 5 + $byte3;
      offset <- bitShiftL(bitAnd(cc, 0x10), 12) + bitShiftL(byte1, 8) + byte2 # ...
      # $offset = (($cc & 0x10) << 12 ) + ($byte1 << 8) + $byte2;
    } 
    else if (cc >= 0x80) {
      len <- len - 2 # $len -= 2;
      byte1 <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $byte1 = unpack "C", $buf;
      byte2 <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $byte2 = unpack "C", $buf;
      numplain <- bitShiftR(bitAnd(byte1, 0xc0), 6) # $numplain = ($byte1 & 0xc0) >> 6;
      numcopy <- bitAnd(cc, 0x3f) + 4 # $numcopy = ($cc & 0x3f) + 4;
      offset <- bitShiftL(bitAnd(byte1, 0x3f), 8) + byte2 # $offset = (($byte1 & 0x3f) << 8) + $byte2;
    } 
    else {
      byte1 <- readBin(FH, "int", 1, size=1) %% 256 # read FH,$buf,1; my $byte1 = unpack "C", $buf;
#      cat("byte1 = ", byte1, "\n")
      len <- len - 1 # $len -= 1;
      numplain <- bitAnd(cc, 0x03) # $numplain = ($cc & 0x03);
      numcopy <- bitShiftR(bitAnd(cc, 0x1c), 2) + 3 # $numcopy = (($cc & 0x1c) >> 2) + 3;
      offset <- bitShiftL(bitAnd(cc, 0x60), 3) + byte1 # $offset = (($cc & 0x60) << 3) + $byte1;
    }
#    printf "      plain, copy, offset: $numplain, $numcopy, $offset \n";
    len <- len - numplain # $len -= $numplain;
    if (numplain > 0) {   # perl didn't check this
      buf <- readBin(FH, "raw", numplain) # read FH,$buf,$numplain;
      answer <- c(answer, buf) # $answer = $answer.$buf;
    }
    fromoffset <- length(answer) - (offset + 1) # my $fromoffset = length($answer) - ($offset + 1);  # 0 == last char

    if (numcopy > 0)
      answer <- c(answer, answer[(fromoffset+1):(fromoffset+numcopy)])
#
#    for ($i=0;$i<$numcopy;$i++) {
#      $answer = $answer.substr($answer,$fromoffset+$i,1);
#    }
    answerlen <- answerlen + numplain # $answerlen += $numplain;
    answerlen <- answerlen + numcopy  # $answerlen += $numcopy;
    if (debug.everything) {
      cat("     cc=", sprintf("%x", cc), "\n")
      cat("     byte1 =", byte1, "byte2 =", byte2, "\n")
      cat("     numplain =", numplain, "numcopy =", numcopy, 
        "offset =" , offset, "fromoffset =", fromoffset, "\n") 
    }

    if (len < 0)
      cat("     UNDERFLOW\n") # if ($len<0) { printf "      UNDERFLOW \n"; }

  }
  # printf(   "      Answer length is %08x (%08x). \n", answerlen, length(answer)) # ...
  # printf "      Answer length is %08x (%08x). \n",$answerlen,length($answer);

  seek(FH, sp) # seek FH,$sp,0;
  return(answer) # return $answer;
}

convert_raw <- function(raw, type.id)
{
  if (type.id == "EBCF3E27" & all(as.integer(raw[1:4]) == c(0xe0, 0x50, 0xe7, 0xcb)))
    return(convert_cpf(raw[-(1:4)]))
  if (type.id == "53545223")
    return(convert_str(raw))
  return(NULL)
}

convert_cpf <- function(raw)
{
  if (debug.everything)
    cat("converting raw to cpf\n")
  cpf <- NULL
  cpf$id <- "CPF"
  cpf$version <- get_little_endian(raw, 2)
  n <- get_little_endian(raw[3:6], 4)
  cpf$data <- NULL
  pos <- 7
  for (i in 1:n) {
    xtype <- get_little_endian(raw[pos:(pos+3)], 4)
    pos <- pos + 4
    nlen <- get_little_endian(raw[pos:(pos+3)], 4)  # len of field name
    pos <- pos + 4
    # the code below is very stupid, but I don't know how to do it in an intelligent way
    name <- rawToChar(raw[pos:(pos+nlen-1)])
    pos <- pos + nlen
    if (xtype == 0xEB61E4F7 || xtype == 0x0C264712 || xtype == 0xABC78708) {  # integer or float
      data <- get_little_endian(raw[pos:(pos+3)], 4)
      pos <- pos + 4
      cpf[[name]] <- data
    }
    else if (xtype == 0x0B8BEA18) { # string
      slen <- get_little_endian(raw[pos:(pos+3)], 4)
      pos <- pos + 4
      str <- rawToChar(raw[pos:(pos+slen-1)])
      pos <- pos + slen
      cpf[[name]] <- str
    }
    else if (xtype == 0xCBA908E1) { # boolean
      cpf[[name]] <- raw[pos]
      pos <- pos + 1
    }
  }
  return(cpf)
}

convert_str <- function(raw)
{
  # not ok, but will do for now
  return(rawToChar(raw[70:length(raw)]))
}

get_little_endian <- function(bytes, n)
{
# I bet there's a more elegant way to do this
  return(sum(256^(0:(n-1)) * as.integer(bytes[1:n])))
}

#
# The next routine opens _all_ package files since
# some date and tests if it was infected by the bug
# in the Pets EP Bodyshop. start_date must be passed
# as an ISO-8601 string.
#
find_pets_ep_bug <- function(start_date = "2006-10-01")
{
  # create vector with all filenames that end in .package
  s_date <- as.POSIXlt(start_date, "GMT")
  fnlist <- list.files(pattern = ".package$") 
  for (i in 1:length(fnlist)) {
    filename <- fnlist[i]
    # get modification time of package
    m_date  <- as.POSIXlt(file.info(filename)$mtime, "GMT")
    # skip if package is older than start date
    if (m_date < s_date)
      next  # in C or similar languages, this would be a continue
    # now let's do the hard work
    x <- try(read_package(filename, get.everything = F))
    # there should be some sanity checks here!
    if (is.null(x)) {
      cat(filename, "seems to have another error\n")
      next
    }
    if (is.null(x$property.set)) next
    if (is.null(x$property.set$human)) next
    if (is.null(x$property.set$human$type)) next
    if (is.null(x$property.set$human$type != "skin")) next
    # everything suggests that this is a recolor / outfit / clothing
    if (is.null(x$property.set$human$outfit)) 
      cat(filename, "seems to include the Pets EP Bodyshop bug\n")
  }
  # done
  cat("Total of", length(fnlist), "files processed\n")
}

[edit] See Also

• CPF/Source Code
• Describe all packages/Source Code