function decrypt($str, $key)
{
if ($str == '') {
return '';
}
$v = str2long($str, false);
$k = str2long($key, false);
if (count($k) < 4) {
for ($i = count($k); $i < 4; $i++) {
$k[$i] = 0;
}
}
$n = count($v) - 1;
$z = $v[$n];
$y = $v[0];
$delta = 0x9e3779b9;
$q = floor(6 + 52 / ($n + 1));
$sum = int32($q * $delta);
while ($sum != 0) {
$e = $sum >> 2 & 3;
for ($p = $n; $p > 0; $p--) {
$z = $v[$p - 1];
$mx = int32(($z >> 5 & 0x7ffffff ^ $y << 2) + ($y >> 3 & 0x1fffffff ^ $z << 4)) ^ int32(($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z));
$y = $v[$p] = int32($v[$p] - $mx);
}
$z = $v[$n];
$mx = int32(($z >> 5 & 0x7ffffff ^ $y << 2) + ($y >> 3 & 0x1fffffff ^ $z << 4)) ^ int32(($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z));
$y = $v[0] = int32($v[0] - $mx);
$sum = int32($sum - $delta);
}
return long2str($v, true);
}
/**
* send a command to R
* @param int $command command code
* @param string $v command contents
*/
private function command($command, $v)
{
$pkt = _rserve_make_packet($command, $v);
socket_send($this->socket, $pkt, strlen($pkt), 0);
// get response
$n = socket_recv($this->socket, $buf, 16, 0);
if ($n != 16) {
return FALSE;
}
$len = int32($buf, 4);
$ltg = $len;
while ($ltg > 0) {
$n = socket_recv($this->socket, $b2, $ltg, 0);
if ($n > 0) {
$buf .= $b2;
unset($b2);
$ltg -= $n;
} else {
break;
}
}
$res = int32($buf);
return array('code' => $res, 'is_error' => ($res & 15) != 1, 'error' => $res >> 24 & 127, 'contents' => $buf);
}
/**
* SEXP to REXP objects parser
*/
public static function parseREXP($buf, &$offset)
{
$attr = null;
$r = $buf;
$i = $offset;
// some simple parsing - just skip attributes and assume short responses
$ra = int8($r, $i);
$rl = int24($r, $i + 1);
$i += 4;
$offset = $eoa = $i + $rl;
if (($ra & 64) == 64) {
throw new Exception('Long packets are not supported (yet).');
}
if ($ra > self::XT_HAS_ATTR) {
$ra &= ~self::XT_HAS_ATTR;
$al = int24($r, $i + 1);
$tmp = $i;
$attr = self::parseREXP($buf, $tmp);
$i += $al + 4;
}
$class = $attr ? $attr->at('class') : null;
if ($class) {
$class = $class->getValues();
}
switch ($ra) {
case self::XT_NULL:
$a = new Rserve_REXP_Null();
break;
case self::XT_VECTOR:
// generic vector
$v = array();
while ($i < $eoa) {
$v[] = self::parseREXP($buf, $i);
}
$klass = 'Rserve_REXP_GenericVector';
if ($class) {
if (in_array('data.frame', $class)) {
$klass = 'Rserve_REXP_Dataframe';
}
}
$a = new $klass();
$a->setValues($v);
break;
case self::XT_SYMNAME:
// symbol
$oi = $i;
while ($i < $eoa && ord($r[$i]) != 0) {
$i++;
}
$v = substr($buf, $oi, $i - $oi);
$a = new Rserve_REXP_Symbol();
$a->setValue($v);
break;
case self::XT_LIST_NOTAG:
case self::XT_LANG_NOTAG:
// pairlist w/o tags
$v = array();
while ($i < $eoa) {
$v[] = self::parseREXP($buf, $i);
}
$clasz = $ra == self::XT_LIST_NOTAG ? 'Rserve_REXP_List' : 'Rserve_REXP_Language';
$a = new $clasz();
$a->setValues($a);
break;
case self::XT_LIST_TAG:
case self::XT_LANG_TAG:
// pairlist with tags
$clasz = $ra == self::XT_LIST_TAG ? 'Rserve_REXP_List' : 'Rserve_REXP_Language';
$v = array();
$names = array();
while ($i < $eoa) {
$v[] = self::parseREXP($buf, $i);
$names[] = self::parseREXP($buf, $i);
}
$a = new $clasz();
$a->setValues($v);
$a->setNames($names);
break;
case self::XT_ARRAY_INT:
// integer array
$v = array();
while ($i < $eoa) {
$v[] = int32($r, $i);
$i += 4;
}
$klass = 'Rserve_REXP_Integer';
if ($class) {
if (in_array('factor', $class)) {
$klass = 'Rserve_REXP_Factor';
}
}
$a = new $klass();
$a->setValues($v);
break;
case self::XT_ARRAY_DOUBLE:
// double array
$v = array();
while ($i < $eoa) {
$v[] = flt64($r, $i);
$i += 8;
}
$a = new Rserve_REXP_Double();
$a->setValues($v);
break;
case self::XT_ARRAY_STR:
// string array
$v = array();
$oi = $i;
while ($i < $eoa) {
if (ord($r[$i]) == 0) {
$v[] = substr($r, $oi, $i - $oi);
$oi = $i + 1;
}
$i++;
}
$a = new Rserve_REXP_String();
$a->setValues($v);
break;
case self::XT_ARRAY_BOOL:
// boolean vector
$n = int32($r, $i);
$i += 4;
$k = 0;
$vv = array();
while ($k < $n) {
$v = int8($r, $i++);
$vv[$k] = $v == 1 ? true : ($v == 0 ? false : null);
$k++;
}
$a = new Rserve_REXP_Logical();
$a->setValues($vv);
break;
case self::XT_RAW:
// raw vector
$len = int32($r, $i);
$i += 4;
$v = substr($r, $i, $len);
$a = new Rserve_REXP_Raw();
$a->setValue($v);
break;
case self::XT_ARRAY_CPLX:
$v = array();
while ($i < $eoa) {
$real = flt64($r, $i);
$i += 8;
$im = flt64($r, $i);
$i += 8;
$v[] = array($real, $im);
}
$a = new Rserve_REXP_Complex();
$a->setValues($v);
break;
/*
case 48: // unimplemented type in Rserve
$uit = int32($r, $i);
// echo "Note: result contains type #$uit unsupported by Rserve.<br/>";
$a = null;
break;
*/
/*
case 48: // unimplemented type in Rserve
$uit = int32($r, $i);
// echo "Note: result contains type #$uit unsupported by Rserve.<br/>";
$a = null;
break;
*/
default:
// handle unknown type
$a = new Rserve_REXP_Unknown($ra);
}
if ($attr && is_object($a)) {
$a->setAttributes($attr);
}
return $a;
}
/**
* Debug a Rserve packet
* @param array|string $packet
*/
public function debugPacket($packet)
{
/*
[0] (int) command
[4] (int) length of the message (bits 0-31)
[8] (int) offset of the data part
[12] (int) length of the message (bits 32-63)
*/
if (is_array($packet)) {
$buf = $packet['contents'];
$header = $packet['header'];
} else {
$header = substr($packet, 0, 16);
$buf = substr($packet, 16);
}
$command = int32($header, 0);
$lengthLow = int32($header, 4);
$offset = int32($header, 8);
$lenghtHigh = int32($header, 12);
if ($command & self::CMD_Response) {
$is_error = $command & 15 != 1;
$cmd = 'CMD Response' . ($is_error ? 'OK' : 'Error');
$err = $command >> 24 & 0x7f;
} else {
$cmd = dechex($command) & 0xfff;
}
echo '[header:<' . $cmd . ' Length:' . dechex($lenghtHigh) . '-' . dechex($lengthLow) . ' offset' . $offset . ">\n";
$len = strlen($buf);
$i = 0;
while ($len > 0) {
$type = int8($buf, $i);
$m_len = int24($buf, $i + 1);
$i += 4;
$i += $m_len;
$len -= $m_len + 4;
echo 'data:<' . $this->getDataTypeTitle($type) . ' length:' . $m_len . ">\n";
}
echo "]\n";
}
/**
* Parse a Rserve packet from socket connection
* @param unknown_type $socket
*/
function _rserve_get_response($socket)
{
$n = socket_recv($socket, $buf, 16, 0);
if ($n != 16) {
return FALSE;
}
$len = int32($buf, 4);
$ltg = $len;
while ($ltg > 0) {
$n = socket_recv($socket, $b2, $ltg, 0);
if ($n > 0) {
$buf .= $b2;
unset($b2);
$ltg -= $n;
} else {
break;
}
}
return $buf;
}
function TEAdecrypt($str, $key = EW_RANDOM_KEY)
{
$str = ew_UrlDecode($str);
if ($str == "") {
return "";
}
$v = str2long($str, false);
$k = str2long($key, false);
$cntk = count($k);
if ($cntk < 4) {
for ($i = $cntk; $i < 4; $i++) {
$k[$i] = 0;
}
}
$n = count($v) - 1;
$z = $v[$n];
$y = $v[0];
$delta = 0.0;
$q = floor(6 + 52 / ($n + 1));
$sum = int32($q * $delta);
while ($sum != 0) {
$e = $sum >> 2 & 3;
for ($p = $n; $p > 0; $p--) {
$z = $v[$p - 1];
$mx = int32(($z >> 5 & 0x7ffffff ^ $y << 2) + ($y >> 3 & 0x1fffffff ^ $z << 4)) ^ int32(($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z));
$y = $v[$p] = int32($v[$p] - $mx);
}
$z = $v[$n];
$mx = int32(($z >> 5 & 0x7ffffff ^ $y << 2) + ($y >> 3 & 0x1fffffff ^ $z << 4)) ^ int32(($sum ^ $y) + ($k[$p & 3 ^ $e] ^ $z));
$y = $v[0] = int32($v[0] - $mx);
$sum = int32($sum - $delta);
}
return long2str($v, true);
}
/** Decipher
* @param string binary cipher
* @param string
* @return string plain-text password
*/
function decrypt_string($str, $key)
{
if ($str == "") {
return "";
}
if (!$key) {
return false;
}
$key = array_values(unpack("V*", pack("H*", md5($key))));
$v = str2long($str, false);
$n = count($v) - 1;
$z = $v[$n];
$y = $v[0];
$q = floor(6 + 52 / ($n + 1));
$sum = int32($q * 0x9e3779b9);
while ($sum) {
$e = $sum >> 2 & 3;
for ($p = $n; $p > 0; $p--) {
$z = $v[$p - 1];
$mx = xxtea_mx($z, $y, $sum, $key[$p & 3 ^ $e]);
$y = int32($v[$p] - $mx);
$v[$p] = $y;
}
$z = $v[$n];
$mx = xxtea_mx($z, $y, $sum, $key[$p & 3 ^ $e]);
$y = int32($v[0] - $mx);
$v[0] = $y;
$sum = int32($sum - 0x9e3779b9);
}
return long2str($v, true);
}
public static function parseREXP($buf, $offset, &$attr = NULL)
{
$r = $buf;
$i = $offset;
// some simple parsing - just skip attributes and assume short responses
$ra = int8($r, $i);
$rl = int24($r, $i + 1);
$i += 4;
$offset = $eoa = $i + $rl;
if (($ra & 64) == 64) {
throw new Exception('Long packets are not supported (yet).');
}
if ($ra > self::XT_HAS_ATTR) {
$ra &= ~self::XT_HAS_ATTR;
$al = int24($r, $i + 1);
$attr = self::parseREXP($buf, $i);
$i += $al + 4;
}
switch ($ra) {
case self::XT_NULL:
$a = new Rserve_REXP_Null();
break;
case self::XT_VECTOR:
// generic vector
$v = array();
while ($i < $eoa) {
$v[] = self::parseREXP($buf, $i);
}
$a = new Rserve_REXP_GenericVector();
$a->setValues($v);
break;
case self::XT_SYMNAME:
// symbol
$oi = $i;
while ($i < $eoa && ord($r[$i]) != 0) {
$i++;
}
$v = substr($buf, $oi, $i - $oi);
$a = new Rserve_REXP_Symbol();
$a->setValue($v);
break;
case self::XT_LIST_NOTAG:
case self::XT_LANG_NOTAG:
// pairlist w/o tags
$v = array();
while ($i < $eoa) {
$v[] = self::parseREXP($buf, $i);
}
$clasz = $ra == self::XT_LIST_NOTAG ? 'Rserve_REXP_List' : 'Rserve_REXP_Language';
$a = new $clasz();
$a->setValues($a);
break;
case self::XT_LIST_TAG:
case self::XT_LANG_TAG:
// pairlist with tags
$clasz = $ra == self::XT_LIST_TAG ? 'Rserve_REXP_List' : 'Rserve_REXP_Language';
$v = array();
$names = array();
while ($i < $eoa) {
$v[] = self::parseREXP($buf, $i);
$names[] = self::parseREXP($buf, $i);
}
$a = new $clasz();
$a->setValues($v);
$a->setNames($names);
break;
case self::XT_ARRAY_INT:
// integer array
$v = array();
while ($i < $eoa) {
$v[] = int32($r, $i);
$i += 4;
}
$a = new Rserve_REXP_Integer();
$a->setValues($v);
break;
case self::XT_ARRAY_DOUBLE:
// double array
$v = array();
while ($i < $eoa) {
$v[] = flt64($r, $i);
$i += 8;
}
$a = new Rserve_REXP_Double();
$a->setValues($v);
break;
case self::XT_ARRAY_STR:
// string array
$v = array();
$oi = $i;
while ($i < $eoa) {
if (ord($r[$i]) == 0) {
$v[] = substr($r, $oi, $i - $oi);
$oi = $i + 1;
}
$i++;
}
$a = new Rserve_REXP_String();
$a->setValues($v);
break;
case self::XT_ARRAY_BOOL:
// boolean vector
$n = int32($r, $i);
$i += 4;
$k = 0;
$vv = array();
while ($k < $n) {
$v = int8($r, $i++);
$vv[$k] = $v == 1 ? TRUE : ($v == 0 ? FALSE : NULL);
$k++;
}
$a = new Rserve_REXP_Logical();
$a->setValues($vv);
break;
case self::XT_RAW:
// raw vector
$len = int32($r, $i);
$i += 4;
$v = substr($r, $i, $len);
$a = new Rserve_REXP_Raw();
$a->setValue($v);
break;
case self::XT_ARRAY_CPLX:
$a = FALSE;
break;
case 48:
// unimplemented type in Rserve
$uit = int32($r, $i);
// echo "Note: result contains type #$uit unsupported by Rserve.<br/>";
$a = NULL;
break;
default:
echo 'Warning: type ' . $ra . ' is currently not implemented in the PHP client.';
$a = FALSE;
}
if ($attr && is_object($a)) {
$a->setAttributes($attr);
}
return $a;
}
function parse_SEXP($buf, $offset, $attr = NULL)
{
$r = $buf;
$i = $offset;
// some simple parsing - just skip attributes and assume short responses
$ra = int8($r, $i);
$rl = int24($r, $i + 1);
$i += 4;
$offset = $eoa = $i + $rl;
// echo "[data type ".($ra & 63).", length ".$rl." with payload from ".$i." to ".$eoa."]<br/>\n";
if (($ra & 64) == 64) {
echo "sorry, long packets are not supported (yet).";
return FALSE;
}
if ($ra > 127) {
$ra &= 127;
$al = int24($r, $i + 1);
$attr = parse_SEXP($buf, $i);
$i += $al + 4;
}
if ($ra == 0) {
return NULL;
}
if ($ra == 16) {
// generic vector
$a = array();
while ($i < $eoa) {
$a[] = parse_SEXP($buf, &$i);
}
// if the 'names' attribute is set, convert the plain array into a map
if (isset($attr['names'])) {
$names = $attr['names'];
$na = array();
$n = count($a);
for ($k = 0; $k < $n; $k++) {
$na[$names[$k]] = $a[$k];
}
return $na;
}
return $a;
}
if ($ra == 19) {
// symbol
$oi = $i;
while ($i < $eoa && ord($r[$i]) != 0) {
$i++;
}
return substr($buf, $oi, $i - $oi);
}
if ($ra == 20 || $ra == 22) {
// pairlist w/o tags
$a = array();
while ($i < $eoa) {
$a[] = parse_SEXP($buf, &$i);
}
return $a;
}
if ($ra == 21 || $ra == 23) {
// pairlist with tags
$a = array();
while ($i < $eoa) {
$val = parse_SEXP($buf, &$i);
$tag = parse_SEXP($buf, &$i);
$a[$tag] = $val;
}
return $a;
}
if ($ra == 32) {
// integer array
$a = array();
while ($i < $eoa) {
$a[] = int32($r, $i);
$i += 4;
}
if (count($a) == 1) {
return $a[0];
}
return $a;
}
if ($ra == 33) {
// double array
$a = array();
while ($i < $eoa) {
$a[] = flt64($r, $i);
$i += 8;
}
if (count($a) == 1) {
return $a[0];
}
return $a;
}
if ($ra == 34) {
// string array
$a = array();
$oi = $i;
while ($i < $eoa) {
if (ord($r[$i]) == 0) {
$a[] = substr($r, $oi, $i - $oi);
$oi = $i + 1;
}
$i++;
}
if (count($a) == 1) {
return $a[0];
}
return $a;
}
if ($ra == 36) {
// boolean vector
$n = int32($r, $i);
$i += 4;
$k = 0;
$a = array();
while ($k < $n) {
$v = int8($r, $i++);
$a[$k++] = $v == 1 ? TRUE : ($v == 0 ? FALSE : NULL);
}
if ($n == 1) {
return $a[0];
}
return $a;
}
if ($ra == 37) {
// raw vector
$len = int32($r, $i);
$i += 4;
return substr($r, $i, $len);
}
if ($ra == 48) {
// unimplemented type in Rserve
$uit = int32($r, $i);
// echo "Note: result contains type #$uit unsupported by Rserve.<br/>";
return NULL;
}
echo "Warning: type " . $ra . " is currently not implemented in the PHP client.";
return FALSE;
}
function Rserve_eval($socket, $command, $attr = NULL)
{
$pkt = mkp_str(3, $command);
socket_send($socket, $pkt, strlen($pkt), 0);
$r = get_rsp($socket);
$res = int32($r);
$sc = $res >> 24 & 127;
$rr = $res & 255;
if ($rr != 1) {
echo "eval failed with error code " . $sc;
return FALSE;
}
if (int8($r, 16) != 10) {
echo "invalid response (expecting SEXP)";
return FALSE;
}
$i = 20;
return parse_SEXP($r, $i, &$attr);
}
function Rserve_assign_raw($socket, $name, $what)
{
// CMD_setSEXP
$bl = strlen($what);
if ($bl > 16777088) {
trigger_error("Body in Rserve_assign_raw is too big ({$bl} bytes), only small QAP packets are currently supported.");
}
$n = strlen($name) + 1;
$name .= chr(0);
while (($n & 3) != 0) {
$name .= chr(1);
$n++;
}
// [CMD_setSEXP][DT_STRING(name)][DT_SEXP([XT_RAW, (i32) len, what])] = payload + 4 + 4 + 8
$pkt = mkint32(0x20) . mkint32($n + $bl + 16) . mkint32(0) . mkint32(0) . chr(4) . mkint24($n) . $name . chr(10) . mkint24($bl + 8) . chr(37) . mkint24($bl + 4) . mkint32($bl) . $what;
socket_send($socket, $pkt, strlen($pkt), 0);
$r = get_rsp($socket);
$res = int32($r);
$sc = $res >> 24 & 127;
$rr = $res & 255;
if ($rr != 1) {
echo "eval failed with error code " . $sc;
return FALSE;
}
return TRUE;
}
