PHPのクラスをextensionで構造体に変換してHaskellで操作する

http://d.hatena.ne.jp/n314/20090919/1253353885 の続き。

動作確認まで

point/
     /point2.xml
     /hs/
     /point2/

point2.xmlを書いてひな形生成。

<?xml version="1.0" ?>
<extension name="point2" version="1.1.2">
  <function role="internal" name="MINIT">
    <code>
      <?data
hs_init(0, 0);
      ?>
    </code>
  </function>
  <function role="internal" name="MSHUTDOWN">
    <code>
      <?data
hs_exit();
      ?>
    </code>
  </function>

  <class name="Point">
    <summary>Point</summary>
    <description>Point class</description>
    <function name="__construct">
      <proto>void __construct([int _x[, int _y]])</proto>
    </function>
  </class>

  <class name="PointResult">
    <summary>Point_Result</summary>
    <description>Point Result class</description>
    <function name="__construct">
      <proto>void __construct([int _a])</proto>
    </function>
  </class>

  <class name="PointDistance">
    <summary>Point_Distance</summary>
    <description>Point Distance class</description>
    <function name="calc">
      <proto>int calc(object Point p)</proto>
    </function>
  </class>
</extension>

pecl-gen -f point2.xml

hs/point.hにやりとりする構造体の定義。

typedef struct point
{
    long x;
    long y;
} Point;

typedef struct result
{
    double a;
} Result;

point2/php_point2.hに素の構造体とエクステンションを繋ぐ構造体を定義。
また、Haskellの関数の宣言を書く。ffiで自動生成される宣言はmakeが通らないのでC風に。

#include "../hs/point.h"
extern Result *hsDistance(Point *p1, Point *p2, Result *r);

#define PHP_STRUCT(name)                        \
    struct php_##name                           \
    {                                           \
    zend_object std;                            \
    HashTable *props;                           \
    struct name obj;                            \
    };

PHP_STRUCT(point);
PHP_STRUCT(result);

生成されたpoint2/point2.cを編集。
マクロ使いまくりで見にくいかも。

static zend_object_handlers h_php_point;
static zend_object_handlers h_php_result;

/* static int compare_point(zval *d1, zval *d2 TSRMLS_DC); */
static HashTable *get_properties_point(zval *obj TSRMLS_DC);
static HashTable *get_properties_result(zval *obj TSRMLS_DC);
void write_property_point(zval *obj, zval *member, zval *value TSRMLS_DC);
zval *read_property_point(zval *obj, zval *member, int type TSRMLS_DC);



#define FREE_STORAGE(name)                                          \
    static void free_storage_##name(void *obj TSRMLS_DC)            \
    {                                                               \
        zend_object_std_dtor(&((struct name *)obj)->std TSRMLS_CC); \
        efree(obj);                                                 \
    }

FREE_STORAGE(php_point)
FREE_STORAGE(php_result)

#define FREE_STORAGE(name)                                          \
    static void free_storage_##name(void *obj TSRMLS_DC)            \
    {                                                               \
        zend_object_std_dtor(&((struct name *)obj)->std TSRMLS_CC); \
        efree(obj);                                                 \
    }

FREE_STORAGE(php_point)
FREE_STORAGE(php_result)


#define _NEW_OBJ(class_type, name)                                      \
    struct name *new;                                                   \
    zend_object_value ret;                                              \
    zval *tmp;                                                          \
                                                                        \
    new = emalloc(sizeof(struct name));                                 \
    memset(new, 0, sizeof(struct name));                                \
                                                                        \
    zend_object_std_init(&new->std, class_type TSRMLS_CC);              \
    zend_hash_copy(new->std.properties,                                 \
                   &class_type->default_properties,                     \
                   (copy_ctor_func_t) zval_add_ref,                     \
                   (void *) &tmp, sizeof(zval *));                      \
                                                                        \
    ret.handle = zend_objects_store_put(                                \
      new,                                                              \
      (zend_objects_store_dtor_t)zend_objects_destroy_object,           \
      (zend_objects_free_object_storage_t) free_storage_##name,         \
      NULL TSRMLS_CC);                                                  \
    ret.handlers = &h_##name;

#define NEW_OBJ(name)                                                   \
    static zend_object_value                                            \
    new_##name(zend_class_entry *class_type TSRMLS_DC)                  \
    {                                                                   \
        _NEW_OBJ(class_type, name);                                     \
        return ret;                                                     \
    }

NEW_OBJ(php_point)
NEW_OBJ(php_result)

#define CLONE_OBJ(name)                                                 \
    static zend_object_value clone_##name(zval *ptr TSRMLS_DC)          \
    {                                                                   \
        struct name *old =                                              \
            (struct name *)zend_object_store_get_object(ptr TSRMLS_CC); \
        _NEW_OBJ(old->std.ce, name);                                    \
                                                                        \
        new->obj = old->obj;                                            \
                                                                        \
        return ret;                                                     \
    }

CLONE_OBJ(php_point)
CLONE_OBJ(php_result)

static zval * instantiate(zend_class_entry *ce, zval *obj TSRMLS_DC)
{
    Z_TYPE_P(obj) = IS_OBJECT;
    object_init_ex(obj, ce);
    /* Z_SET_REFCOUNT_P(obj, 1); */
    /* Z_UNSET_ISREF_P(obj); */
    return obj;
}

(snip)

static void class_init_Point(void)
{
        zend_class_entry ce;

        INIT_CLASS_ENTRY(ce, "Point", Point_methods);
    ce.create_object = new_php_point;
        Point_ce_ptr = zend_register_internal_class_ex(&ce, NULL, NULL TSRMLS_CC
);

    memcpy(&h_php_point, zend_get_std_object_handlers(), sizeof(zend_object_hand
lers));
    h_php_point.clone_obj = clone_php_point;
    h_php_point.get_properties = get_properties_point;
    h_php_point.write_property = write_property_point;
    h_php_point.read_property = read_property_point;
}

static zend_object_value clone_point(zval *ptr TSRMLS_DC)
{
    struct php_point *old = (struct php_point *) zend_object_store_get_object(pt
r TSRMLS_CC);
    _NEW_OBJ(old->std.ce, php_point);

    new->obj = old->obj;

    return ret;
}

zval *read_property_point(zval *obj, zval *member, int type TSRMLS_DC)
{
    struct php_point *p;
    zval *ret;
    zval tmp_member;
    long value = 0;

    if (member->type != IS_STRING){
        tmp_member = *member;
        zval_copy_ctor(&tmp_member);
        convert_to_string(&tmp_member);
        member = &tmp_member;
    }

    p = (struct php_point *)zend_object_store_get_object(obj TSRMLS_CC);
#define GET_VALUE_FROM_STRUCT(n, m)             \
    if (strcmp(Z_STRVAL_P(member), m) == 0){    \
        value = p->obj.n;                       \
    }
    GET_VALUE_FROM_STRUCT(x, "x");
    GET_VALUE_FROM_STRUCT(y, "y");

    ZVAL_LONG(ret, value);
    if (member == &tmp_member){
        zval_dtor(member);
    }

    return ret;
}

void write_property_point(zval *obj, zval *member, zval *value TSRMLS_DC)
{
    struct php_point *p;
    int found = 0;
    zend_object_handlers *h_std;

    p = (struct php_point *)zend_object_store_get_object(obj TSRMLS_CC);

#define SET_VALUE_FROM_STRUCT(n,m)                  \
    if (strcmp(Z_STRVAL_P(member), m) == 0){        \
        found = 1;                                  \
        p->obj.n = Z_LVAL_P(value);                 \
    }

    SET_VALUE_FROM_STRUCT(x, "x");
    SET_VALUE_FROM_STRUCT(y, "y");

    if (!found){
        php_error_docref(NULL TSRMLS_CC, E_WARNING, "Unknown property (%s)", Z_S
TRVAL_P(member));
    }
}

static HashTable *get_properties_point(zval *obj TSRMLS_DC)
{
    HashTable *props;
    zval *zv;
    struct php_point *p;

    p = (struct php_point *)zend_object_store_get_object(obj TSRMLS_CC);
    props = p->std.properties;

    MAKE_STD_ZVAL(zv);
    ZVAL_LONG(zv, p->obj.x);
    zend_hash_update(props, "x", strlen("x")+1, &zv, sizeof(zval), NULL);
    MAKE_STD_ZVAL(zv);
    ZVAL_LONG(zv, p->obj.y);
    zend_hash_update(props, "y", strlen("y")+1, &zv, sizeof(zval), NULL);
    return props;
}

(snip)

static void class_init_PointResult(void)
{
        zend_class_entry ce;

        INIT_CLASS_ENTRY(ce, "PointResult", PointResult_methods);
    ce.create_object = new_php_result;
        PointResult_ce_ptr = zend_register_internal_class_ex(&ce, NULL, NULL TSR
MLS_CC);

    memcpy(&h_php_result, zend_get_std_object_handlers(), sizeof(zend_object_han
dlers));
    h_php_result.clone_obj = clone_php_result;
    h_php_result.get_properties = get_properties_result;
}

static HashTable *get_properties_result(zval *obj TSRMLS_DC)
{
    HashTable *props;
    zval *zv;
    struct php_result *p;

    p = (struct php_result *)zend_object_store_get_object(obj TSRMLS_CC);
    props = p->std.properties;

    MAKE_STD_ZVAL(zv);
    ZVAL_DOUBLE(zv, p->obj.a);
    zend_hash_update(props, "a", strlen("a")+1, &zv, sizeof(zval), NULL);

    return props;
}

(snip)

PHP_METHOD(PointDistance, calc)
{
        zend_class_entry * _this_ce;

        zval * _this_zval = NULL;
        zval * p1 = NULL;
        zval * p2 = NULL;

    struct php_point *pp1, *pp2;
    struct php_result *r1;
    struct result *test;


        if (zend_parse_method_parameters(ZEND_NUM_ARGS() TSRMLS_CC, getThis(), "
OOO", &_this_zval, PointDistance_ce_ptr, &p1, Point_ce_ptr, &p2, Point_ce_ptr) =
= FAILURE) {
                return;
        }

        _this_ce = Z_OBJCE_P(_this_zval);


    pp1 = (struct php_point *) zend_object_store_get_object(p1 TSRMLS_CC);
    pp2 = (struct php_point *) zend_object_store_get_object(p2 TSRMLS_CC);
    instantiate(PointResult_ce_ptr, return_value TSRMLS_CC);
    r1 = zend_object_store_get_object(return_value TSRMLS_CC);

    test = hsDistance(&pp1->obj, &pp2->obj, &r1->obj);
    printf("test:%p == %p\n", test, &r1->obj);

}

cd point2
phpize
./configure --enable-point2
make

hs/src.hsにHaskellのコードを書いてコンパイル、リンク。
hsc2hsを使う。

{-# OPTIONS -ffi #-}

#include "point.h"

module PhpPoint where

import Foreign
import Foreign.C.Types

data CPoint = CPoint { x::CInt, y::CInt }
type CPointPtr = Ptr (CPoint)

data CResult = CResult { a::CDouble }
type CResultPtr = Ptr (CResult)

instance Storable CPoint where
    sizeOf _ = (#size Point)
    alignment _ = alignment (undefined :: CInt)
    peek ptr = do
      x' <- (#peek Point, x) ptr
      y' <- (#peek Point, y) ptr
      return CPoint { x=x', y=y' }
    poke ptr (CPoint x' y') = do
                           (#poke Point, x) ptr x'
                           (#poke Point, y) ptr y'

instance Storable CResult where
    sizeOf _ = (#size Result)
    alignment _ = alignment (undefined :: CDouble)
    peek ptr = do
      a' <- (#peek Result, a) ptr
      return CResult { a=a' }
    poke ptr (CResult a') = do
                           (#poke Result, a) ptr a'



distance :: CPoint -> CPoint -> CDouble
distance (CPoint x1 y1) (CPoint x2 y2) =
    sqrt $ fromIntegral $ (x1 - x2)^2 + (y1 - y2)^2

foreign export ccall hsDistance ::
    CPointPtr -> CPointPtr -> CResultPtr -> IO CResultPtr
hsDistance a b r = do
  a' <- peek a
  b' <- peek b
  poke r CResult { a = distance a' b' }
  return r

cd hs
hsc2hs src.hs -o point.hs
ghc -c point.hs
cd ..

ghc -optl-shared point2/.libs/point2.o hs/point.o hs/point_stub.o -optl-Wl,-soname -optl-Wl,point2.so -o point2.so
cp point2.so /usr/lib/php5/20060613+lfs/

テストコードtest2.phpを書いて実行。

<?php
dl('point2.so');
$point = new Point("3",4);
var_dump($point);
$point2 = clone $point;
var_dump($point2);

$distance = new PointDistance();
var_dump($distance);

$ret = $distance->calc($point, new Point(4, 5));
var_dump($ret);

% php test2.php
object(Point)#1 (2) {
  ["x"]=>
  int(3)
  ["y"]=>
  int(4)
}
object(Point)#2 (2) {
  ["x"]=>
  int(3)
  ["y"]=>
  int(4)
}
object(PointDistance)#3 (0) {
}
test:0xb784babc == 0xb784babc
object(PointResult)#5 (1) {
  ["a"]=>
  float(1.4142135623731)
}

test:%p == %p は、Haskellとのやりとりをテストしているだけなので戻り値はvoidでもいい。

メモ

Haskellのexportする関数は、引数がポインタで戻り値がIOポインタ
- peekでPtrから実体に変換
zend_objects_storeを使って、zvalから自分で定義した構造体を取り出す
- 自分で定義した構造体を関連付けるためにzend_objects_store_putを使う
  - そのためにオブジェクト生成関数は自分で作らなければならない

static void class_init_Point(void)
{
        zend_class_entry ce;

        INIT_CLASS_ENTRY(ce, "Point", Point_methods);
    ce.create_object = new_php_point;
        Point_ce_ptr = zend_register_internal_class_ex(&ce, NULL, NULL TSRMLS_CC
);

    memcpy(&h_php_point, zend_get_std_object_handlers(), sizeof(zend_object_hand
lers));
    h_php_point.clone_obj = clone_php_point;
    h_php_point.get_properties = get_properties_point;
    h_php_point.write_property = write_property_point;
    h_php_point.read_property = read_property_point;
}

write_propertyでプロパティへの書き込みを独自定義構造体にしている
PHPオブジェクトのプロパティアクセスはread_propertyが使われるが、var_dumpやイテレート処理などではget_propertiesが使われるので両方必要（？）
- たぶんzend_hash_updateでエクステンション用クラスのプロパティを更新するんじゃなくてstd.propsを独自定義した方がいい