/**
* 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";
}
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;
}
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 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);
}