Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file gobject.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402(**************************************************************************)(* Lablgtk *)(* *)(* This program is free software; you can redistribute it *)(* and/or modify it under the terms of the GNU Library General *)(* Public License as published by the Free Software Foundation *)(* version 2, with the exception described in file COPYING which *)(* comes with the library. *)(* *)(* This program is distributed in the hope that it will be useful, *)(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)(* GNU Library General Public License for more details. *)(* *)(* You should have received a copy of the GNU Library General *)(* Public License along with this program; if not, write to the *)(* Free Software Foundation, Inc., 59 Temple Place, Suite 330, *)(* Boston, MA 02111-1307 USA *)(* *)(* *)(**************************************************************************)(* $Id$ *)openStdLabelsopenGauxtype-'aobjtypeg_typetypeg_classtypeg_valuetypeg_closuretype'aobjtype=g_typetypebasic=[`CHARofchar|`CAMLofObj.t|`BOOLofbool|`INTofint|`FLOAToffloat|`STRINGofstringoption|`POINTERofGpointer.boxedoption|`INT64ofint64]typedata_get=[basic|`NONE|`OBJECTofunitobjoption]type'adata_set=[basic|`OBJECTof'aobjoption|`INT32ofint32|`LONGofnativeint]typebase_data=[`BOOLEAN|`CHAR|`UCHAR|`INT|`UINT|`LONG|`ULONG|`INT64|`UINT64|`ENUM|`FLAGS|`FLOAT|`DOUBLE|`STRING|`POINTER|`BOXED|`OBJECT]typedata_kind=[`INT32|`UINT32|`OTHERofg_type|base_data]typedata_conv_get=[`INT32ofint32|data_get]type'adata_conv={kind:data_kind;proj:(data_conv_get->'a);inj:('a->unitdata_set)}typefundamental_type=[`INVALID|`NONE|`INTERFACE|`PARAM|base_data]typesignal_type=[`RUN_FIRST|`RUN_LAST|`NO_RECURSE|`ACTION|`NO_HOOKS]externaldo_unref:unit->unit="ml_g_object_do_unref"letunref_alarm=Gc.create_alarmdo_unrefmoduleType=structexternalinit:unit->unit="ml_g_type_init"let()=init()externalname:g_type->string="ml_g_type_name"external_from_name:string->g_type="ml_g_type_from_name"externalparent:g_type->g_type="ml_g_type_parent"externaldepth:g_type->int="ml_g_type_depth"externalis_a:g_type->g_type->bool="ml_g_type_is_a"externalfundamental:g_type->fundamental_type="ml_G_TYPE_FUNDAMENTAL"externalof_fundamental:fundamental_type->g_type="ml_Fundamental_type_val"externalinterface_prerequisites:g_type->g_typelist="ml_g_type_interface_prerequisites"(** @since GTK 2.2 *)externalregister_static:parent:g_type->name:string->g_type="ml_g_type_register_static"letinvalid=of_fundamental`INVALIDletfrom_names=lett=_from_namesinift=invalidthenfailwith("Gobject.Type.from_name: "^s);texternalg_caml_get_type:unit->g_type="ml_g_caml_get_type"letcaml=g_caml_get_type()endmoduleValue=structexternalcreate_empty:unit->g_value="ml_g_value_new"(* create a g_value owned by ML *)externalinit:g_value->g_type->unit="ml_g_value_init"letcreatety=letv=create_empty()ininitvty;v(* create and initialize a g_value *)externalrelease:g_value->unit="ml_g_value_release"(* invalidate a g_value, releasing resources *)externalget_type:g_value->g_type="ml_G_VALUE_TYPE"externalcopy:g_value->g_value->unit="ml_g_value_copy"externalreset:g_value->unit="ml_g_value_reset"externaltype_compatible:g_type->g_type->bool="ml_g_value_type_compatible"externaltype_transformable:g_type->g_type->bool="ml_g_value_type_transformable"externaltransform:g_value->g_value->bool="ml_g_value_transform"externalget:g_value->data_get="ml_g_value_get_mlvariant"externalset:g_value->'adata_set->unit="ml_g_value_set_mlvariant"externalget_pointer:g_value->Gpointer.boxed="ml_g_value_get_pointer"externalget_nativeint:g_value->nativeint="ml_g_value_get_nativeint"externalget_int32:g_value->int32="ml_g_value_get_int32"letget_convkindv=trymatchkindwith(* special case to get all 32 bits *)|`INT32|`UINT32->`INT32(get_int32v)(* special case to avoid copy of boxed *)|`POINTER->`POINTER(trySome(get_pointerv)withGpointer.Null->None)|_->(getv:>data_conv_get)withFailure("Gobject.get_int32"|"Gobject.get_pointer")->`NONEendmoduleClosure=structtypeargstypeargv={result:g_value;nargs:int;args:args}externalcreate:(argv->unit)->g_closure="ml_g_closure_new"external_nth:args->pos:int->g_value="ml_g_value_shift"letntharg~pos=ifpos<0||pos>=arg.nargstheninvalid_arg"Gobject.Closure.nth";_ntharg.args~posletresultargv=argv.resultletget_result_typearg=Value.get_type(resultarg)letget_typearg~pos=Value.get_type(ntharg~pos)letgetarg~pos=Value.get(ntharg~pos)letset_resultarg=Value.set(resultarg)letget_argsarg=letrecloopargs~pos=ifpos<0thenargselseloop(getarg~pos::args)~pos:(pos-1)inloop[]~pos:(arg.nargs-1)letget_pointerarg~pos=Value.get_pointer(ntharg~pos)letget_nativeintarg~pos=Value.get_nativeint(ntharg~pos)letget_int32arg~pos=Value.get_int32(ntharg~pos)endletobjtype_from_name~callername=lett=Type._from_namenameinletf=Type.fundamentaltiniff=`INVALIDthenfailwith(caller^" : type "^name^" is not yet defined");iff<>`OBJECTthenfailwith(caller^" : "^name^" is not an object type");texternalget_type:'aobj->g_type="ml_G_TYPE_FROM_INSTANCE"externalget_object_type:'aobj->g_type="ml_G_TYPE_FROM_INSTANCE"letis_aobjname=Type.is_a(get_typeobj)(objtype_from_name~caller:"Gobject.is_a"name)exceptionCannot_castofstring*stringexternalunsafe_cast:'aobj->'bobj="%identity"lettry_castwname=ifis_awnamethenunsafe_castwelseraise(Cannot_cast(Type.name(get_typew),name))externalcoerce:'aobj->unitobj="%identity"externalcoerce_option:'aobjoption->unitobjoption="%identity"(* [coerce] is safe *)externalunsafe_create:g_type->(string*'adata_set)list->'bobj="ml_g_object_new"(* This is dangerous! *)externalunsafe_unref:'aobj->unit="ml_g_object_unref"externalget_ref_count:'aobj->int="ml_g_object_ref_count"type('a,'b)property={name:string;conv:'bdata_conv}type'aparam=string*unitdata_setletdyn_parampropv=(prop,(Obj.magic(v:'adata_set):unitdata_set))letparam(prop:('a,'b)property)d:'aparam=dyn_paramprop.name(prop.conv.injd)letunsafe_create~classel=unsafe_create(objtype_from_name~caller:"Gobject.unsafe_create"classe)lletget_oid(obj:'aobj):int=(snd(Obj.magicobj)lor0)moduleData=structletboolean={kind=`BOOLEAN;proj=(function`BOOLb->b|_->failwith"Gobject.get_bool");inj=(funb->`BOOLb)}letchar={kind=`CHAR;proj=(function`CHARc->c|_->failwith"Gobject.get_char");inj=(func->`CHARc)}letuchar={charwithkind=`UCHAR}letint={kind=`INT;proj=(function`INTc->c|_->failwith"Gobject.get_int");inj=(func->`INTc)}letuint={intwithkind=`UINT}letlong={intwithkind=`LONG}letulong={intwithkind=`ULONG}letint32={kind=`INT32;proj=(function`INT32c->c|_->failwith"Gobject.get_int32");inj=(func->`INT32c)}letuint32={int32withkind=`UINT32}letflagstbl={kind=`FLAGS;proj=(function`INTc->Gpointer.decode_flagstblc|_->failwith"Gobject.get_flags");inj=(func->`INT(Gpointer.encode_flagstblc))}letenumtbl={kind=`ENUM;proj=(function`INTc->Gpointer.decode_varianttblc|_->failwith"Gobject.get_enum");inj=(func->`INT(Gpointer.encode_varianttblc))}letint64={kind=`INT64;proj=(function`INT64c->c|_->failwith"Gobject.get_int64");inj=(func->`INT64c)}letuint64={int64withkind=`UINT64}letfloat={kind=`FLOAT;proj=(function`FLOATc->c|_->failwith"Gobject.get_float");inj=(func->`FLOATc)}letdouble={floatwithkind=`DOUBLE}letstring={kind=`STRING;proj=(function`STRING(Somes)->s|`STRINGNone->""|_->failwith"Gobject.get_string");inj=(funs->`STRING(Somes))}letstring_option={kind=`STRING;proj=(function`STRINGs->s|_->failwith"Gobject.get_string_option");inj=(funs->`STRINGs)}letpointer={kind=`POINTER;proj=(function`POINTERc->c|_->failwith"Gobject.get_pointer");inj=(func->`POINTERc)}letunsafe_pointer={kind=`POINTER;proj=(function`POINTER(Somec)->Obj.magicc|_->failwith"Gobject.get_pointer");inj=(func->`POINTER(Some(Obj.magicc)))}letmagic:'aoption->'boption=Obj.magicletunsafe_pointer_option={kind=`POINTER;proj=(function`POINTERc->magicc|_->failwith"Gobject.get_pointer");inj=(func->`POINTER(magicc))}letboxed_typet=ifType.fundamentalt<>`BOXEDthenfailwith"Gobject.Data.boxed_type";`OTHERtletboxedt={pointerwithkind=boxed_typet}letunsafe_boxedt={unsafe_pointerwithkind=boxed_typet}letunsafe_boxed_optiont={unsafe_pointer_optionwithkind=boxed_typet}letgobject_option={kind=`OBJECT;proj=(function`OBJECTc->may_map~f:unsafe_castc|_->failwith"Gobject.get_object");inj=(func->`OBJECT(may_map~f:unsafe_castc))}letgobject={kind=`OBJECT;proj=(function`OBJECT(Somec)->unsafe_castc|`OBJECTNone->raiseGpointer.Null|_->failwith"Gobject.get_object");inj=(func->`OBJECT(Some(unsafe_castc)))}letgobject_by_namename={gobjectwithkind=`OTHER(Type.from_namename)}letcaml={kind=`OTHERType.caml;proj=(function`CAMLv->Obj.objv|_->failwith"Gobject.get_caml");inj=(funv->`CAML(Obj.reprv))}letcaml_option={kind=`OTHERType.caml;proj=(function`CAMLv->Some(Obj.objv)|`NONE->None|_->failwith"Gobject.get_caml");inj=(functionNone->`POINTERNone|Somev->`CAML(Obj.reprv))}letwrap~inj~projconv={kind=conv.kind;proj=(funx->proj(conv.projx));inj=(funx->conv.inj(injx))}letof_valueconvv=conv.proj(Value.get_convconv.kindv)lettype_of_kind=function|`INT32->Type.of_fundamental`INT|`UINT32->Type.of_fundamental`UINT|`OTHERt->t|#base_dataasx->Type.of_fundamentalxletget_typeconv=type_of_kindconv.kindletto_valueconvx=letv=Value.create(get_typeconv)inValue.setv(conv.injx);vendmoduleProperty=structexternalfreeze_notify:'aobj->unit="ml_g_object_freeze_notify"externalthaw_notify:'aobj->unit="ml_g_object_thaw_notify"externalnotify:'aobj->string->unit="ml_g_object_notify"externalset_value:'aobj->string->g_value->unit="ml_g_object_set_property"externalget_value:'aobj->string->g_value->unit="ml_g_object_get_property"externalget_type:'aobj->string->g_type="ml_my_g_object_get_property_type"(* [get_property_type o name] may raise [Invalid_argument name] *)(* Converted the following to C to avoid too many calls
let set_dyn obj prop data =
let t = get_type obj prop in
let v = Value.create t in
Value.set v data;
set_value obj prop v
let get_dyn obj prop =
let t = get_type obj prop in
let v = Value.create t in
get_value obj prop v;
Value.get v
*)externalset_dyn:'aobj->string->'bdata_set->unit="ml_g_object_set_property_dyn"externalget_dyn:'aobj->string->data_get="ml_g_object_get_property_dyn"letset(obj:'aobj)(prop:('a,_)property)x=set_dynobjprop.name(prop.conv.injx)letget(obj:'aobj)(prop:('a,_)property)=letv=matchprop.conv.kindwith(* Special cases: need to bypass normal conversion *)|`INT32|`UINT32|`POINTERask->lett=get_typeobjprop.nameinletv=Value.createtinget_valueobjprop.namev;Value.get_convkv|_->(get_dynobjprop.name:>data_conv_get)inprop.conv.projvletget_someobjprop=matchgetobjpropwithSomex->x|None->failwith("Gobject.Property.get_some: "^prop.name)letcheckobjprop=lettpobj=Type.name(get_object_typeobj)inlet_data=tryget_dynobjprop.namewithInvalid_argument_->failwith(tpobj^" has no property "^prop.name)|exn->prerr_endline("exception while looking for "^tpobj^"->"^prop.name);raiseexnintryignore(getobjprop)withFailures->failwith(s^" cannot handle "^tpobj^"->"^prop.name)|exn->failwith(tpobj^"->"^prop.name^" raised "^Printexc.to_stringexn)letmay_conspropxl=matchxwithSomex->parampropx::l|None->lletmay_cons_optpropxl=matchxwithSome_->parampropx::l|None->lendletsetpox=Property.setopxletgetpo=Property.getopletset_paramsobjparams=List.iterparams~f:(fun(prop,arg)->Property.set_dynobjproparg)