Hello, Win32 API(OCaml) World!

Posted on 3月 9th, 2013 by cx20

Win32 API(OCaml)

Win32 API は、Windows の機能にアクセスする為の API(Application Programming Interface)である。
以下は OCaml による Win32 API 呼出しの例となっている。

ソースコード(C言語)

#include <stdio.h>
#include <windows.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
 
#define Is_nil(v) ((v) == Val_int(0))
#define Head(v) (Field((v), 0))
#define Tail(v) (Field((v), 1))
 
#define Declare_constants(name) 
    extern DWORD name[]; 
    extern int num_##name
 
#define Define_constants(name) 
    int num_##name = sizeof(name) / sizeof(DWORD)
 
#define Constant_val(val, constants) (constants[Int_val(val)])
 
#define Handle_val(v) (*((HANDLE*)(v)))
value alloc_handle(HANDLE h);
 
value val_constant_with_count(DWORD constant, int num_constants, DWORD* constants);
 
#define Val_constant(constant, constants) 
    (val_constant_with_count((constant), num_##constants, constants))
 
Declare_constants(standard_control_ids);
 
DWORD standard_control_ids[] = {
    IDABORT,
    IDCANCEL,
    IDCLOSE,
    IDHELP,
    IDIGNORE,
    IDNO,
    IDOK,
    IDRETRY,
    IDYES
};
Define_constants(standard_control_ids);
 
DWORD message_box_options[] = {
    MB_ABORTRETRYIGNORE,
    MB_APPLMODAL,
    MB_DEFAULT_DESKTOP_ONLY,
    MB_DEFBUTTON1,
    MB_DEFBUTTON2,
    MB_DEFBUTTON3,
    MB_DEFBUTTON4,
    MB_HELP,
    MB_ICONASTERISK,
    MB_ICONERROR,
    MB_ICONEXCLAMATION,
    MB_ICONHAND,
    MB_ICONINFORMATION,
    MB_ICONQUESTION,
    MB_ICONSTOP,
    MB_ICONWARNING,
    MB_OK,
    MB_OKCANCEL,
    MB_RETRYCANCEL,
    MB_RIGHT,
    MB_RTLREADING,
    MB_SETFOREGROUND,
    MB_SYSTEMMODAL,
    MB_TASKMODAL,
    MB_TOPMOST,
    MB_YESNO,
    MB_YESNOCANCEL
};
 
value val_constant_with_count(DWORD constant, int num_constants, DWORD* constants)
{
    int i;
 
    for (i = 0; i < num_constants; ++i)
        if (constants[i] == constant)
            return Val_int(i);
    failwith("Invalid constant");
    return Val_int(0);
}
 
CAMLprim value get_null_hwnd(value unit)
{
    return alloc_handle(NULL);
}
 
value alloc_handle(HANDLE h)
{
    value val;
 
    val = alloc_small(sizeof(HANDLE) / sizeof(value), Abstract_tag);
    Handle_val(val) = h;
    return val;
}
 
DWORD flags_val(value list, DWORD* constants)
{
    int result;
 
    result = 0;
    for (; !Is_nil(list); list = Tail(list))
        result |= Constant_val(Head(list), constants);
    return result;
}
 
char* new_string(value v)
{
    return strdup(String_val(v));
}
 
void free_string(char* s)
{
    free(s);
}
 
static value* win32_error_exception = NULL;
 
void raise_win32_error(DWORD error)
{
    if (win32_error_exception == NULL)
        win32_error_exception = caml_named_value("win32 error");
    raise_with_arg(*win32_error_exception, Val_int((int)error));
}
 
void raise_last_error(void)
{
    raise_win32_error(GetLastError());
}
 
CAMLprim value message_box(value wnd, value text, value caption, value type)
{
    CAMLparam4(wnd, text, caption, type);
    HWND hwnd;
    char* txt;
    char* capt;
    UINT typ;
    int result;
 
    hwnd = Handle_val(wnd);
    txt = new_string(text);
    capt = new_string(caption);
    typ = flags_val(type, message_box_options);
    enter_blocking_section();
    result = MessageBox(hwnd, txt, capt, typ);
    leave_blocking_section();
    free_string(txt);
    free_string(capt);
    if (result == 0)
        raise_last_error();
    CAMLreturn(Val_constant(result, standard_control_ids));
}

ソースコード(OCaml)

type hwnd
 
type message_box_option =
    MB_ABORTRETRYIGNORE
  | MB_APPLMODAL
  | MB_DEFAULT_DESKTOP_ONLY
  | MB_DEFBUTTON1
  | MB_DEFBUTTON2
  | MB_DEFBUTTON3
  | MB_DEFBUTTON4
  | MB_HELP
  | MB_ICONASTERISK
  | MB_ICONERROR
  | MB_ICONEXCLAMATION
  | MB_ICONHAND
  | MB_ICONINFORMATION
  | MB_ICONQUESTION
  | MB_ICONSTOP
  | MB_ICONWARNING
  | MB_OK
  | MB_OKCANCEL
  | MB_RETRYCANCEL
  | MB_RIGHT
  | MB_RTLREADING
  | MB_SETFOREGROUND
  | MB_SYSTEMMODAL
  | MB_TASKMODAL
  | MB_TOPMOST
  | MB_YESNO
  | MB_YESNOCANCEL
 
type standard_control_id =
    IDABORT
  | IDCANCEL
  | IDCLOSE
  | IDHELP
  | IDIGNORE
  | IDNO
  | IDOK
  | IDRETRY
  | IDYES
 
external get_null_hwnd : unit -> hwnd = "get_null_hwnd"
let null_hwnd = get_null_hwnd ()
 
external message_box :
    wnd:hwnd ->
    text:string ->
    caption:string ->
    options:message_box_option list ->
    standard_control_id = "message_box"
 
let () =
  ignore ( message_box ~wnd:null_hwnd ~text:"Hello, Win32 API World!" ~caption:"Hello, World!" ~options:[MB_OK] );

実行方法

C:¥> ocamlopt -o hello.exe hello.ml hello_stubs.c

実行結果

---------------------------
Hello, World!
---------------------------
Hello, Win32 API World!
---------------------------
OK   
---------------------------

Tags:

Categories: OCaml, Win32 API

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

WP-SpamFree by Pole Position Marketing