Skip to content
Browse files

sdl net on curl with threads

  • Loading branch information...
1 parent 68f44be commit ab9ef856980db58adebde8775262cf2bac056496 @serp256 committed
View
1 Makefile.android
@@ -1,4 +1,5 @@
include config.android
+META=META.android
include Makefile.in
INSTALL_OPTS = src/android/libpng/libpng.a
View
1 Makefile.in
@@ -11,6 +11,7 @@ debug:
INSTALL_OPTS =
install: release
+ cp $(META) META
$(OCAMLFIND) install lightning META src/lightning.cmxa src/lightning.a src/liblightning.a src/*.cmi src/*.mli src/containers/*.cmi src/containers/*.mli src/syntax/pa_prop.cmo src/syntax/pa_debug.cmo $(INSTALL_OPTS)
uninstall:
View
1 Makefile.ios
@@ -1,3 +1,4 @@
include config.ios
+META=META.ios
include Makefile.in
View
1 Makefile.linux
@@ -1,3 +1,4 @@
include config.linux
+META=META.sdl
include Makefile.in
View
1 Makefile.macos
@@ -1,3 +1,4 @@
include config.macos
+META=META.sdl
include Makefile.in
View
4 src/Button.ml
@@ -56,7 +56,7 @@ module Make
[ False -> ()
| True ->
let open Touch in
- match touchEvent.Event.data with
+ match touchEvent.Ev.data with
[ `Touches touches ->
match touches with
[ [ touch :: _ ] ->
@@ -83,7 +83,7 @@ module Make
| TouchPhaseEnded when isDown ->
(
self#resetContents ();
- self#dispatchEvent (Event.create `TRIGGERED ());
+ self#dispatchEvent (Ev.create `TRIGGERED ());
)
| TouchPhaseCancelled when isDown -> self#resetContents ()
| _ -> ()
View
42 src/DisplayObject.ml
@@ -2,7 +2,7 @@ open Gl;
open LightCommon;
type eventType = [= `ADDED | `ADDED_TO_STAGE | `REMOVED | `REMOVED_FROM_STAGE | `ENTER_FRAME ];
-type eventData = [= Event.dataEmpty | `PassedTime of float ];
+type eventData = [= Ev.dataEmpty | `PassedTime of float ];
module type Param = sig
type evType = private [> eventType ];
@@ -66,13 +66,13 @@ DEFINE RENDER_WITH_MASK(call_render) =
class type dispObj =
object
- method dispatchEvent: ! 'a 'b. Event.t P.evType P.evData ( < .. > as 'a) ( < .. > as 'b) -> unit;
+ method dispatchEvent: ! 'a 'b. Ev.t P.evType P.evData ( < .. > as 'a) ( < .. > as 'b) -> unit;
end;
value onEnterFrameObjects : HSet.t dispObj = HSet.empty ();
value dispatchEnterFrame seconds =
- let enterFrameEvent = Event.create `ENTER_FRAME ~data:(`PassedTime seconds) () in
+ let enterFrameEvent = Ev.create `ENTER_FRAME ~data:(`PassedTime seconds) () in
HSet.iter (fun (obj:dispObj) -> obj#dispatchEvent enterFrameEvent) onEnterFrameObjects;
class virtual _c [ 'parent ] = (*{{{*)
@@ -82,7 +82,7 @@ class virtual _c [ 'parent ] = (*{{{*)
type 'parent =
<
- asDisplayObject: _c _; removeChild': _c _ -> unit; dispatchEvent': !'ct. Event.t P.evType P.evData 'displayObject 'ct -> unit;
+ asDisplayObject: _c _; removeChild': _c _ -> unit; dispatchEvent': !'ct. Ev.t P.evType P.evData 'displayObject 'ct -> unit;
name: string; transformationMatrixToSpace: !'space. option (<asDisplayObject: _c _; ..> as 'space) -> Matrix.t; stage: option 'parent; modified: unit -> unit; ..
>;
@@ -132,7 +132,7 @@ class virtual _c [ 'parent ] = (*{{{*)
method clearParent () = (parent := None;);
(* Events *)
- type 'event = Event.t P.evType P.evData 'displayObject 'self;
+ type 'event = Ev.t P.evType P.evData 'displayObject 'self;
type 'listener = 'event -> unit;
method private enterFrameListenerRemovedFromStage _ lid =
@@ -195,14 +195,14 @@ class virtual _c [ 'parent ] = (*{{{*)
];
);
- method dispatchEvent': !'ct. Event.t P.evType P.evData 'displayObject (< .. > as 'ct) -> unit = fun event -> (*{{{*)
+ method dispatchEvent': !'ct. Ev.t P.evType P.evData 'displayObject (< .. > as 'ct) -> unit = fun event -> (*{{{*)
(
try
- let l = List.assoc event.Event.etype listeners in
- let event = {(event) with Event.currentTarget = Some self} in
- ignore(List.for_all (fun (lid,l) -> (l event lid; event.Event.propagation = `StopImmediate)) l.EventDispatcher.lstnrs);
+ let l = List.assoc event.Ev.etype listeners in
+ let event = {(event) with Ev.currentTarget = Some self} in
+ ignore(List.for_all (fun (lid,l) -> (l event lid; event.Ev.propagation = `StopImmediate)) l.EventDispatcher.lstnrs);
with [ Not_found -> () ];
- match event.Event.bubbles && event.Event.propagation = `Propagate with
+ match event.Ev.bubbles && event.Ev.propagation = `Propagate with
[ True ->
match parent with
[ Some p -> p#dispatchEvent' event
@@ -213,8 +213,8 @@ class virtual _c [ 'parent ] = (*{{{*)
); (*}}}*)
(* всегда ставить таргет в себя и соответственно current_target *)
- method dispatchEvent: ! 't 'ct. Event.t P.evType P.evData ( < .. > as 't) (< .. > as 'ct) -> unit = fun event ->
- let event = {(event) with Event.target = Some self#asDisplayObject; currentTarget = None} in
+ method dispatchEvent: ! 't 'ct. Ev.t P.evType P.evData ( < .. > as 't) (< .. > as 'ct) -> unit = fun event ->
+ let event = {(event) with Ev.target = Some self#asDisplayObject; currentTarget = None} in
self#dispatchEvent' event;
value mutable scaleX = 1.0;
@@ -667,14 +667,14 @@ class virtual container = (*{{{*)
(* method dispatchEventOnChildren: !'ct. Event.t P.evType P.evData 'displayObject (< .. > as 'ct) -> unit = fun event -> (); *)
(* Сделать enum устойчивым к модификациям и переписать на полное использование енумов или щас ? *)
- method dispatchEventOnChildren: !'ct. Event.t P.evType P.evData 'displayObject (< .. > as 'ct) -> unit = fun event ->
+ method dispatchEventOnChildren: !'ct. Ev.t P.evType P.evData 'displayObject (< .. > as 'ct) -> unit = fun event ->
(* method dispatchEventOnChildren event = *)
(
self#dispatchEvent event;
Enum.iter begin fun (child:'displayObject) ->
match child#dcast with
[ `Container cont ->
- (cont :> < dispatchEventOnChildren: !'a. Event.t P.evType P.evData 'displayObject (< .. > as 'a) -> unit >)#dispatchEventOnChildren event
+ (cont :> < dispatchEventOnChildren: !'a. Ev.t P.evType P.evData 'displayObject (< .. > as 'a) -> unit >)#dispatchEventOnChildren event
| `Object obj -> obj#dispatchEvent event
]
end self#children;
@@ -737,14 +737,14 @@ class virtual container = (*{{{*)
numChildren := numChildren + 1;
child#setParent self#asDisplayObjectContainer;
child#modified();
- let event = Event.create `ADDED () in
+ let event = Ev.create `ADDED () in
child#dispatchEvent event;
match self#stage with
[ Some _ ->
- let event = Event.create `ADDED_TO_STAGE () in
+ let event = Ev.create `ADDED_TO_STAGE () in
match child#dcast with
[ `Container cont ->
- let cont = (cont :> < dispatchEventOnChildren: !'a. Event.t P.evType P.evData 'displayObject (< .. > as 'a) -> unit >) in
+ let cont = (cont :> < dispatchEventOnChildren: !'a. Ev.t P.evType P.evData 'displayObject (< .. > as 'a) -> unit >) in
cont#dispatchEventOnChildren event
| `Object _ -> child#dispatchEvent event
]
@@ -788,11 +788,11 @@ class virtual container = (*{{{*)
];
numChildren := numChildren - 1;
self#modified();
- let event = Event.create `REMOVED () in
+ let event = Ev.create `REMOVED () in
child#dispatchEvent event;
match self#stage with
[ Some _ ->
- let event = Event.create `REMOVED_FROM_STAGE () in
+ let event = Ev.create `REMOVED_FROM_STAGE () in
match child#dcast with
[ `Container cont -> cont#dispatchEventOnChildren event
| `Object _ -> child#dispatchEvent event
@@ -830,10 +830,10 @@ class virtual container = (*{{{*)
[ None -> ()
| Some chldrn ->
let evs =
- let event = Event.create `REMOVED () in
+ let event = Ev.create `REMOVED () in
match self#stage with
[ Some _ ->
- let sevent = Event.create `REMOVED_FROM_STAGE () in
+ let sevent = Ev.create `REMOVED_FROM_STAGE () in
fun (child:'displayObject) ->
(
child#dispatchEvent event;
View
2 src/DisplayObject.mli
@@ -1,6 +1,6 @@
type eventType = [= `ADDED | `ADDED_TO_STAGE | `REMOVED | `REMOVED_FROM_STAGE | `ENTER_FRAME ];
-type eventData = [= Event.dataEmpty | `PassedTime of float ];
+type eventData = [= Ev.dataEmpty | `PassedTime of float ];
module type Param = sig
type evType = private [> eventType ];
View
12 src/DisplayObjectT.ml
@@ -1,6 +1,6 @@
type eventType = [= `ADDED | `ADDED_TO_STAGE | `REMOVED | `REMOVED_FROM_STAGE | `ENTER_FRAME ];
-type eventData = [= Event.dataEmpty | `PassedTime of float ];
+type eventData = [= Ev.dataEmpty | `PassedTime of float ];
(* {{{
class type virtual _c' [ 'evType, 'evData, 'parent ] =
@@ -133,16 +133,16 @@ class virtual _c [ 'parent ] : (* _c' [evType,evData,'parent]; = *)
type 'displayObject = _c 'parent;
type 'parent =
<
- asDisplayObject: _c _; removeChild': _c _ -> unit; dispatchEvent': !'ct. Event.t evType evData _ (< .. > as 'ct) -> unit;
+ asDisplayObject: _c _; removeChild': _c _ -> unit; dispatchEvent': !'ct. Ev.t evType evData _ (< .. > as 'ct) -> unit;
name: string; transformationMatrixToSpace: !'space. option (<asDisplayObject: _c _; ..> as 'space) -> Matrix.t; stage: option 'parent; height: float; modified: unit -> unit; .. >;
(* inherit EventDispatcher.c [ 'event_type, 'event_data , _c _ _ _, _]; *)
- type 'event = Event.t evType evData 'displayObject 'self;
+ type 'event = Ev.t evType evData 'displayObject 'self;
type 'listener = 'event -> int -> unit;
method addEventListener: evType -> 'listener -> int;
method removeEventListener: evType -> int -> unit;
- method dispatchEvent: ! 't 'ct. Event.t evType evData ( < .. > as 't) (< .. > as 'ct) -> unit;
- method dispatchEvent': !'ct. Event.t evType evData 'displayObject (< .. > as 'ct) -> unit;
+ method dispatchEvent: ! 't 'ct. Ev.t evType evData ( < .. > as 't) (< .. > as 'ct) -> unit;
+ method dispatchEvent': !'ct. Ev.t evType evData 'displayObject (< .. > as 'ct) -> unit;
method hasEventListeners: evType -> bool;
value name: string;
@@ -234,7 +234,7 @@ class virtual container:
method removeChild': 'displayObject -> unit;
method containsChild': 'displayObject -> bool;
method removeChildren: unit -> unit;
- method dispatchEventOnChildren: !'ct. Event.t evType evData 'displayObject (< .. > as 'ct) -> unit;
+ method dispatchEventOnChildren: !'ct. Ev.t evType evData 'displayObject (< .. > as 'ct) -> unit;
method boundsInSpace: !'space. option (<asDisplayObject: 'displayObject; ..> as 'space) -> Rectangle.t;
method private render': option Rectangle.t -> unit;
method private hitTestPoint': Point.t -> bool -> option ('displayObject);
View
24 src/Event.ml
@@ -1,24 +0,0 @@
-
-type dataEmpty = [= `Empty ];
-
-type t 'etype 'data 'target 'currentTarget =
- {
- etype:'etype ;
- propagation:mutable [= `Propagate | `Stop | `StopImmediate ];
- bubbles:bool;
-(* eventPhase: [= `AT_TARGET | `BUBBLING_PHASE ]; *)
- target: option 'target;
- currentTarget: option 'currentTarget;
- data:'data;
- } constraint 'etype = [> ] constraint 'data = [> dataEmpty ] constraint 'target = < .. > constraint 'currentTarget = < .. >;
-
-
-
-value stopImmediatePropagation event = event.propagation := `StopImmediate;
-value stopPropagaion event =
- match event.propagation with
- [ `Propagate -> event.propagation := `Stop
- | _ -> ()
- ];
-
-value create etype ?(bubbles=False) ?(data=`Empty) () = { etype; propagation = `Propagate; bubbles; data; target = None; currentTarget = None };
View
16 src/EventDispatcher.ml
@@ -1,20 +1,20 @@
-open Event;
+open Ev;
exception Listener_not_found;
-type listener 'eventType 'eventData 'target 'currentTarget = Event.t 'eventType 'eventData 'target 'currentTarget -> unit;
+type listener 'eventType 'eventData 'target 'currentTarget = Ev.t 'eventType 'eventData 'target 'currentTarget -> unit;
type listeners 'eventType 'eventData 'target 'currentTarget = list (int * (listener 'eventType 'eventData 'target 'currentTarget));
type lst 'eventType 'eventData 'target 'currentTarget =
{
counter: mutable int;
(* lstnrs: mutable list (int * (listener 'eventType 'eventData 'target 'currentTarget)); *)
- lstnrs: mutable list (int * (Event.t 'eventType 'eventData 'target 'currentTarget -> int -> unit));
+ lstnrs: mutable list (int * (Ev.t 'eventType 'eventData 'target 'currentTarget -> int -> unit));
};
value fire event lst =
try
- let l = List.assoc event.Event.etype lst in
- ignore(List.for_all (fun (lid,l) -> (l event lid; event.Event.propagation = `StopImmediate)) l.lstnrs);
+ let l = List.assoc event.Ev.etype lst in
+ ignore(List.for_all (fun (lid,l) -> (l event lid; event.Ev.propagation = `StopImmediate)) l.lstnrs);
True
with [ Not_found -> False ];
@@ -86,7 +86,7 @@ class type virtual c [ 'eventType,'eventData,'target,'currentTarget ] =
class virtual simple [ 'eventType , 'eventData , 'target ] =
object(self)
inherit base ['eventType,'eventData,'target,'target];
- type 'event = Event.t 'eventType 'eventData 'target 'target;
+ type 'event = Ev.t 'eventType 'eventData 'target 'target;
(* method private dispatchEvent' event = fire event listeners; *)
@@ -97,8 +97,8 @@ class virtual simple [ 'eventType , 'eventData , 'target ] =
let t = self#asEventTarget in
let event = {(event) with target = Some t; currentTarget = Some t } in
try
- let l = List.assoc event.Event.etype listeners in
- ignore(List.for_all (fun (lid,l) -> (l event lid; event.Event.propagation = `StopImmediate)) l.lstnrs);
+ let l = List.assoc event.Ev.etype listeners in
+ ignore(List.for_all (fun (lid,l) -> (l event lid; event.Ev.propagation = `StopImmediate)) l.lstnrs);
with [ Not_found -> () ];
end;
View
6 src/EventDispatcher.mli
@@ -5,12 +5,12 @@ exception Listener_not_found;
type lst 'eventType 'eventData 'target 'currentTarget =
{
counter: mutable int;
- lstnrs: mutable list (int * (Event.t 'eventType 'eventData 'target 'currentTarget -> int -> unit));
+ lstnrs: mutable list (int * (Ev.t 'eventType 'eventData 'target 'currentTarget -> int -> unit));
};
class base [ 'eventType,'eventData,'target,'currentTarget ]:
object
- type 'listener = Event.t 'eventType 'eventData 'target 'currentTarget -> int -> unit;
+ type 'listener = Ev.t 'eventType 'eventData 'target 'currentTarget -> int -> unit;
value mutable listeners: list ('eventType * (lst 'eventType 'eventData 'target 'currentTarget));
method addEventListener: 'eventType -> 'listener -> int;
method removeEventListener: 'eventType -> int -> unit;
@@ -22,5 +22,5 @@ class virtual simple [ 'eventType , 'eventData , 'target ]:
object
inherit base ['eventType,'eventData,'target,'target];
method virtual private asEventTarget: 'target;
- method dispatchEvent: Event.t 'eventType 'eventData 'target 'target -> unit;
+ method dispatchEvent: Ev.t 'eventType 'eventData 'target 'target -> unit;
end;
View
2 src/FPS.ml
@@ -16,7 +16,7 @@ module Make
method private onEnterFrame event _ =
- match event.Event.data with
+ match event.Ev.data with
[ `PassedTime dt ->
let osecs = int_of_float time in
(
View
17 src/Makefile
@@ -12,7 +12,6 @@ GLPARAM =
MOBJS =
MLOBJSFLAGS =
MLFLAGS += -package extlib -I containers -I utils
-MLSOURCES =
MLDEPFLAGS =
release: lightning.cmxa syntax/pa_prop.cmo
@@ -49,11 +48,11 @@ else
else
gl = gl/2.1
MOBJS += sdl/sdl_stub.o sdl/sdl_image_stub.o
- MLSOURCES += sdl/sdl.ml sdl/sdl_image.ml sdl/sdl_run.ml
+ BMLSOURCES = sdl/sdl.ml sdl/sdl_image.ml
+ AMLSOURCES = sdl/sdl_run.ml
MLOBJSFLAGS = -I sdl
- MLDEPFLAGS += -I sdl sdl/*.ml sdl/*.mli
MLPPOPT += -DSDL
- MLFLAGS += -package curl
+ MLCOMPFLAGS += -package curl,threads -thread
ifeq ($(OS),macos)
LIBFLAGS = -cclib '-framework\ Cocoa' -cclib '-lSDL' -cclib '-lSDL_image' -cclib '-lSDLmain' -cclib '-framework\ OpenGL'
else
@@ -64,17 +63,16 @@ else
endif
-
MOBJS += $(gl)/gl_stub.o
+MLSOURCES = $(gl)/gl.ml $(BMLSOURCES) Debug.ml ProfTimer.ml WeakMemo.ml Dictionary.ml LightCommon.ml Ev.ml EventDispatcher.ml Point.ml Rectangle.ml Matrix.ml RenderSupport.ml \
+ DisplayObject.ml Sprite.ml Quad.ml GLTexture.ml Texture.ml TextureAtlas.ml Image.ml CompiledSprite.ml Touch.ml BitmapFont.ml TextField.ml FPS.ml Timers.ml Timer.ml \
+ Stage.ml Button.ml MovieClip.ml Tween.ml Sound.ml GameCenter.ml LocalStorage.ml URLLoader.ml $(AMLSOURCES) Lightning.ml
$(gl)/gl_stub.o: $(gl)/gl_stub.c
$(OCAMLOPT) -verbose -g $(if $(GLPARAM),-ccopt $(GLPARAM)) -ccopt '-o $(gl)/gl_stub.o' -c $(gl)/gl_stub.c
MLCONTAINERS = containers/MList.ml containers/HSet.ml containers/PriorityQueue.ml containers/WeakHashtbl.ml
MLUTILS = utils/UrlEncoding.ml
-MLSOURCES += $(gl)/gl.ml Debug.ml ProfTimer.ml WeakMemo.ml Dictionary.ml LightCommon.ml Event.ml EventDispatcher.ml Point.ml Rectangle.ml Matrix.ml RenderSupport.ml \
- DisplayObject.ml Sprite.ml Quad.ml GLTexture.ml Texture.ml TextureAtlas.ml Image.ml CompiledSprite.ml Touch.ml BitmapFont.ml TextField.ml FPS.ml Timers.ml Timer.ml \
- Stage.ml Button.ml MovieClip.ml Tween.ml Sound.ml GameCenter.ml LocalStorage.ml URLLoader.ml Lightning.ml
#XMLMFILES = TextureAtlas.ml BitmapFont.ml LightCommon.ml MovieClip.ml
@@ -84,6 +82,7 @@ MLCONTAINERSOBJS = $(MLCONTAINERS:.ml=.cmx)
MLUTILSOBJS = $(MLUTILS:.ml=.cmx)
MLOBJS = $(MLSOURCES:.ml=.cmx)
$(MLOBJS): MLFLAGS += -package xmlm -I $(gl) $(MLOBJSFLAGS)
+$(MLOBJS): Debug.cmx
$(MLOBJS) MLDepend.$(PLATFORM): syntax/pa_debug.cmo
$(MLOBJS) MLDepend.$(PLATFORM): MLPPOPT += syntax/pa_debug.cmo
@@ -95,7 +94,7 @@ lightning.cmxa: MLDepend.$(PLATFORM) $(MLCONTAINERSOBJS) $(MLUTILSOBJS) $(MOBJS)
MLDepend.$(PLATFORM):
$(OCAMLFIND) ocamldep $(MLFLAGS) -I containers $(MLCONTAINERS:.ml=.mli) $(MLCONTAINERS) > MLDepend.$(PLATFORM)
$(OCAMLFIND) ocamldep $(MLFLAGS) -I containers -I utils $(MLUTILS:.ml=.mli) $(MLUTILS) >> MLDepend.$(PLATFORM)
- $(OCAMLFIND) ocamldep $(MLFLAGS) -I $(gl) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) *.mli $(MLSOURCES) >> MLDepend.$(PLATFORM)
+ $(OCAMLFIND) ocamldep $(MLFLAGS) -I $(gl) $(MLOBJSFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) *.mli $(MLSOURCES) >> MLDepend.$(PLATFORM)
doc:
View
2 src/MovieClip.ml
@@ -218,7 +218,7 @@ module Make
method private onEnterFrame event _ =
let () = debug "onEnterFrame: [%s], currentFrame: %d" clipname currentFrameID in
- match event.Event.data with
+ match event.Ev.data with
[ `PassedTime dt ->
(
elapsedTime := elapsedTime +. dt;
View
4 src/Stage.ml
@@ -98,9 +98,9 @@ module Make(D:DisplayObjectT.M with type evType = private [> eventType ] and typ
(* группируем их по таргетам и вперед *)
let fireTouches = List.fold_left (fun res (target,touch) -> MList.add_assoc target (Touch.t_of_n touch) res) [] otherTouches in
let fireTouches = List.fold_left (fun res (target,touch) -> MList.add_assoc target (Touch.t_of_n touch) res) fireTouches processedTouches in
- let event = Event.create ~bubbles:True `TOUCH () in
+ let event = Ev.create ~bubbles:True `TOUCH () in
List.iter begin fun ((target:D.c),touches) ->
- let event = {(event) with Event.data = `Touches touches} in
+ let event = {(event) with Ev.data = `Touches touches} in
target#dispatchEvent event
end fireTouches;
currentTouches := (List.filter (fun (_,t) -> match t.n_phase with [ TouchPhaseEnded -> False | _ -> True ]) processedTouches) @ otherTouches
View
10 src/Timer.ml
@@ -3,7 +3,7 @@ type eventType = [= `TIMER | `TIMER_COMPLETE ];
class type virtual c =
object('self)
- inherit EventDispatcher.simple [eventType,Event.dataEmpty, c ];
+ inherit EventDispatcher.simple [eventType,Ev.dataEmpty, c ];
method running: bool;
method delay: float;
method repeatCount: int;
@@ -18,7 +18,7 @@ class type virtual c =
value create ?(repeatCount=0) delay = (*{{{*)
let o =
object(self)
- inherit EventDispatcher.simple [eventType, Event.dataEmpty, c];
+ inherit EventDispatcher.simple [eventType, Ev.dataEmpty, c];
value mutable running = None;
method running = running <> None;
value mutable currentCount = 0;
@@ -34,15 +34,15 @@ value create ?(repeatCount=0) delay = (*{{{*)
then
(
running := Some (Timers.start delay self#fire);
- let event = Event.create `TIMER () in
+ let event = Ev.create `TIMER () in
self#dispatchEvent event;
)
else
(
running := None;
- let event = Event.create `TIMER () in
+ let event = Ev.create `TIMER () in
self#dispatchEvent event;
- let event = Event.create `TIMER_COMPLETE () in
+ let event = Ev.create `TIMER_COMPLETE () in
self#dispatchEvent event
)
| None -> assert False
View
154 src/URLLoader.ml
@@ -28,7 +28,7 @@ value string_of_httpMethod = fun
value request ?(httpMethod=`GET) ?(headers=[]) ?data url = { httpMethod; headers; data; url};
type eventType = [= `PROGRESS | `COMPLETE | `IO_ERROR ];
-type eventData = [= Event.dataEmpty | `HTTPBytes of int | `IOError of (int * string)];
+type eventData = [= Ev.dataEmpty | `HTTPBytes of int | `IOError of (int * string)];
exception Incorrect_request;
@@ -78,7 +78,7 @@ value prepare_request r =
type loader_wrapper =
{
- onResponse: int -> int64 -> list (string*string) -> unit;
+ onResponse: int -> string -> int64 -> unit;
onData: string -> unit;
onComplete: unit -> unit;
onError: int -> string -> unit
@@ -94,10 +94,10 @@ value get_loader ns_connection =
Hashtbl.find loaders ns_connection
with [ Not_found -> failwith("HTTPConneciton not found") ];
-value url_response ns_connection httpCode totalBytes headers =
+value url_response ns_connection httpCode contentType totalBytes =
let () = debug "url response" in
let w = get_loader ns_connection in
- w.onResponse httpCode totalBytes headers;
+ w.onResponse httpCode contentType totalBytes;
Callback.register "url_response" url_response;
@@ -132,48 +132,119 @@ value start_load wrappers r =
let (url,data) = prepare_request r in
let ns_connection = url_connection url (string_of_httpMethod r.httpMethod) r.headers data in
Hashtbl.add loaders ns_connection wrappers;
+(*}}}*)
+ELSE
+IFDEF SDL THEN (*{{{*)
-ELSE (*}}}*)
-IFDEF SDL THEN
+type thr = ((Event.channel [= `Result of (int * string * Int64.t * string) | `Failure of (int * string) ]) * (Event.channel (string * http_method * list (string*string) * option string)));
+value free_threads: Queue.t thr = Queue.create ();
+value working_threads = ref [];
value curl_initialized = ref False;
+value curl_thread (inch,outch) =
+ let buffer = Buffer.create 1024 in
+ let dataf = (fun str -> (Buffer.add_string buffer str; String.length str)) in
+ loop () where
+ rec loop () =
+ (
+ let e = Event.receive inch in
+ let (url,hmth,headers,body) = Event.sync e in
+ let ccon = Curl.init () in
+ try
+ Curl.set_url ccon url;
+ let headers = List.map (fun (n,v) -> Printf.sprintf "%s:%s" n v) headers in
+ match headers with
+ [ [] -> ()
+ | _ -> Curl.set_httpheader ccon headers
+ ];
+ match hmth with
+ [ `POST -> Curl.set_post ccon True
+ | _ -> ()
+ ];
+ match body with
+ [ Some b -> Curl.set_postfields ccon b
+ | None -> ()
+ ];
+ Curl.set_writefunction ccon dataf;
+ Curl.perform ccon;
+ let httpCode = Curl.get_httpcode ccon
+ and contentType = Curl.get_contenttype ccon
+ and contentLength = Int64.of_float (Curl.get_contentlengthdownload ccon)
+ in
+ Event.sync (Event.send outch (`Result (httpCode,contentType,contentLength,Buffer.contents buffer)));
+ Buffer.clear buffer;
+ Curl.cleanup ccon;
+ with [ Curl.CurlException _ code str -> Event.sync (Event.send outch (`Failure code str))];
+ loop ();
+ );
+
+value global_conn_id = ref 0;
value start_load wrapper r =
(
match !curl_initialized with
[ False -> (Curl.global_init Curl.CURLINIT_GLOBALNOTHING; curl_initialized.val := True)
| True -> ()
];
- (* пока без тридов создаем каждый раз этот курл *)
let (url,data) = prepare_request r in
- let ccon = Curl.init () in
- (
- Curl.set_url ccon url;
- let headers = List.map (fun (n,v) -> Printf.sprintf "%s:%s" n v) r.headers in
- match headers with
- [ [] -> ()
- | _ -> Curl.set_httpheader ccon headers
- ];
- match r.httpMethod with
- [ `POST -> Curl.set_post ccon True
- | _ -> ()
- ];
- match data with
- [ Some d -> Curl.set_postfields ccon d
- | None -> ()
- ];
- (*
- Curl.set_headerfunction ccon (fun str -> (Printf.printf "headerf with: [%s]\n%!" str; String.length str));
- Curl.set_writefunction ccon (fun str -> (Printf.printf "writef with: [%s]\n%!" str; String.length str));
- *)
- Curl.perform ccon;
- print_endline "curl performed";
- wrapper.onResponse (Curl.get_httpcode ccon) (Int64.of_float (Curl.get_contentlengthdownload ccon)) [];
- Curl.cleanup ccon;
- wrapper.onComplete ();
- );
+ let ((_,outch) as channels) =
+ match Queue.is_empty free_threads with
+ [ True ->
+ let inch = Event.new_channel ()
+ and outch = Event.new_channel ()
+ in
+ (
+ ignore(Thread.create curl_thread (outch,inch));
+ ((inch,outch):thr)
+ )
+ | False -> Queue.pop free_threads
+ ]
+ in
+ let e = Event.send outch (url,r.httpMethod,r.headers,data) in
+ working_threads.val := [ (channels,wrapper,`send_request e) :: !working_threads ]
);
+value process_result loader = fun
+ [ `Result (code,contentType,contentLength,data) ->
+ (
+ loader.onResponse code contentType contentLength;
+ loader.onData data;
+ loader.onComplete ();
+ )
+ | `Failure code errmsg -> loader.onError code errmsg
+ ];
+
+value process_events () =
+ match !working_threads with
+ [ [] -> ()
+ | works ->
+ let () = debug "process working threads" in
+ working_threads.val :=
+ ExtList.List.filter_map begin fun ((((inch,outch) as worker),loader,state) as j) ->
+ match state with
+ [ `send_request e ->
+ match Event.poll e with
+ [ None -> Some j
+ | Some () ->
+ let e = Event.receive inch in
+ Some (worker,loader,`wait_result e)
+ ]
+ | `wait_result e ->
+ match Event.poll e with
+ [ None -> Some j
+ | Some result ->
+ (
+ process_result loader result;
+ Queue.push worker free_threads;
+ None
+ )
+ ]
+ ]
+ end works
+ ];
+
+
+(*}}}*)
ELSE
value start_load wrappers r = failwith "Net not implemented on this platform yet";
@@ -191,8 +262,8 @@ class loader ?request () =
value mutable httpCode = 0;
method httpCode = httpCode;
- value mutable httpHeaders = [];
- method httpHeaders = httpHeaders;
+ value mutable contentType = "";
+ method contentType = contentType;
value mutable bytesTotal = 0L;
method bytesTotal = bytesTotal;
value mutable bytesLoaded = 0L;
@@ -200,13 +271,13 @@ class loader ?request () =
value data = Buffer.create 10;
method data = Buffer.contents data;
- method private onResponse c b h =
+ method private onResponse c ct b =
(
debug "onResponse";
httpCode := c;
+ contentType := ct;
bytesTotal := b;
bytesLoaded := 0L;
- httpHeaders := h;
);
method private onData d =
@@ -215,7 +286,7 @@ class loader ?request () =
(
bytesLoaded := Int64.add bytesLoaded (Int64.of_int bytes);
Buffer.add_string data d;
- let event = Event.create `PROGRESS ~data:(`HTTPBytes bytes) () in
+ let event = Ev.create `PROGRESS ~data:(`HTTPBytes bytes) () in
self#dispatchEvent event;
);
@@ -223,7 +294,7 @@ class loader ?request () =
(
debug "onError";
state := Complete;
- let event = Event.create `IO_ERROR ~data:(`IOError (code,msg)) () in
+ let event = Ev.create `IO_ERROR ~data:(`IOError (code,msg)) () in
self#dispatchEvent event
);
@@ -231,9 +302,8 @@ class loader ?request () =
(
debug "on complete";
state := Complete;
- let event = Event.create `COMPLETE () in
+ let event = Ev.create `COMPLETE () in
self#dispatchEvent event
- debug "event fired";
);
method load r =
@@ -247,7 +317,7 @@ class loader ?request () =
in
(
httpCode := 0;
- httpHeaders := [];
+ contentType := "";
bytesTotal := 0L;
bytesLoaded := 0L;
Buffer.clear data;
View
12 src/ios/LightViewController.m
@@ -89,20 +89,26 @@ - (void)viewDidLoad
static value *ml_url_response = NULL;
- (void)connection:(NSURLConnection *)connection didReceiveResponse:(NSHTTPURLResponse *)response {
+ NSLog(@"did revieve response");
caml_acquire_runtime_system();
if (ml_url_response == NULL)
ml_url_response = caml_named_value("url_response");
+ value contentType;
+ Begin_roots1(contentType);
+ contentType = caml_copy_string([[response MIMEType] cStringUsingEncoding:NSUTF8StringEncoding]);
value args[4];
args[0] = (value)connection;
args[1] = Val_int(response.statusCode);
- args[2] = caml_copy_int64(response.expectedContentLength);
- args[3] = 1;
+ args[3] = caml_copy_int64(response.expectedContentLength);
+ args[2] = contentType;
caml_callbackN(*ml_url_response,4,args);
+ End_roots();
caml_release_runtime_system();
}
static value *ml_url_data = NULL;
- (void)connection:(NSURLConnection *)connection didReceiveData:(NSData *)data {
+ NSLog(@"did revieve data");
caml_acquire_runtime_system();
if (ml_url_data == NULL)
ml_url_data = caml_named_value("url_data");
@@ -115,6 +121,7 @@ - (void)connection:(NSURLConnection *)connection didReceiveData:(NSData *)data {
static value *ml_url_failed = NULL;
- (void)connection:(NSURLConnection *)connection didFailWithError:(NSError *)error {
+ NSLog(@"did fail with error");
caml_acquire_runtime_system();
if (ml_url_failed == NULL)
ml_url_failed = caml_named_value("url_failed");
@@ -129,6 +136,7 @@ - (void)connection:(NSURLConnection *)connection didFailWithError:(NSError *)err
static value *ml_url_complete = NULL;
- (void)connectionDidFinishLoading:(NSURLConnection *)connection {
+ NSLog(@"did finish loading");
caml_acquire_runtime_system();
if (ml_url_complete == NULL)
ml_url_complete = caml_named_value("url_complete");
View
6 src/ios/net_ios.m
@@ -9,10 +9,9 @@
CAMLprim value ml_URLConnection(value url, value method, value headers, value data) {
CAMLparam4(url,method,headers,data);
- CAMLlocal1(res);
+ fprintf(stderr,"start create ns connection on [%s]\n",String_val(url));
NSURL *nsurl = [[NSURL alloc] initWithString:[NSString stringWithCString:String_val(url) encoding:NSASCIIStringEncoding]];
NSMutableURLRequest *request = [[NSMutableURLRequest alloc] initWithURL:nsurl];
- [nsurl release];
[request setHTTPMethod:[NSString stringWithCString:String_val(method) encoding:NSASCIIStringEncoding]];
// add headers
value el = headers;
@@ -30,8 +29,9 @@ CAMLprim value ml_URLConnection(value url, value method, value headers, value da
[nsdata release];
}
NSURLConnection *connection = [[NSURLConnection alloc] initWithRequest:request delegate:[LightViewController sharedInstance] startImmediately:YES];
- [request release];
[nsurl release];
+ [request release];
+ fprintf(stderr,"ns connection created\n");
CAMLreturn((value)connection);
}
View
90 src/sdl/sdl_run.ml
@@ -28,52 +28,58 @@ value handle_events frameRate stage =
match quit with
[ True -> ()
| False ->
- let rec event_loop touch cnt =
- if cnt > 3 then ()
- else
- match Event.poll_event () with
- [ Quit -> loop ticks touch True
- | NoEvent -> loop ticks touch False
- | Button ({Event.mousebutton = LEFT;_} as mb) ->
- match touch with
- [ None when mb.buttonstate = PRESSED -> (* tap begin *)
- let globalX = float mb.bx
- and globalY = float mb.by in
- let touch =
- {
- Touch.n_tid = (let r = !touchid in (touchid.val := r + 1; Int32.of_int r));
- n_timestamp = 0.;
- n_globalX = globalX; n_globalY = globalY;
- n_previousGlobalX = globalX; n_previousGlobalY = globalY;
- n_tapCount = 1; n_phase = Touch.TouchPhaseBegan;
- }
- in
- (
- stage#processTouches [touch];
- event_loop (Some touch) (cnt+1)
- )
- | Some touch when mb.buttonstate = RELEASED -> (* FIXME: what about multi touch ? *)
- let touch = {(touch) with Touch.n_globalX = float mb.bx; n_globalY = float mb.by; n_phase = Touch.TouchPhaseEnded} in
- (
- stage#processTouches [ touch ];
- event_loop None (cnt+1)
- )
- | _ -> let () = prerr_endline "fixme Button event" in loop ticks touch False
- ]
- | Event.Motion mm ->
- match touch with
- [ Some touch ->
- let touch = {(touch) with Touch.n_globalX = float mm.mx; n_globalY = float mm.my; n_phase = Touch.TouchPhaseMoved} in
+ (
+ URLLoader.process_events();
+ let rec next_event touch ticks =
+ let cticks = Sdl.Timer.get_ticks() in
+ if cticks - ticks < ticksRate
+ then event_loop touch cticks
+ else loop cticks touch False
+ and event_loop touch ticks =
+ match Event.poll_event () with
+ [ Quit -> loop ticks touch True
+ | NoEvent -> loop ticks touch False
+ | Button ({Event.mousebutton = LEFT;_} as mb) ->
+ match touch with
+ [ None when mb.buttonstate = PRESSED -> (* tap begin *)
+ let globalX = float mb.bx
+ and globalY = float mb.by in
+ let touch =
+ {
+ Touch.n_tid = (let r = !touchid in (touchid.val := r + 1; Int32.of_int r));
+ n_timestamp = 0.;
+ n_globalX = globalX; n_globalY = globalY;
+ n_previousGlobalX = globalX; n_previousGlobalY = globalY;
+ n_tapCount = 1; n_phase = Touch.TouchPhaseBegan;
+ }
+ in
+ (
+ stage#processTouches [touch];
+ next_event (Some touch) ticks
+ )
+ | Some touch when mb.buttonstate = RELEASED -> (* FIXME: what about multi touch ? *)
+ let touch = {(touch) with Touch.n_globalX = float mb.bx; n_globalY = float mb.by; n_phase = Touch.TouchPhaseEnded} in
(
stage#processTouches [ touch ];
- event_loop (Some touch) (cnt+1)
+ next_event None ticks
)
- | None -> event_loop None (cnt + 1)(* FIXME проверить выход за границы *)
- ]
- | _ -> event_loop touch (cnt + 1)
- ]
+ | _ -> let () = prerr_endline "fixme Button event" in loop ticks touch False
+ ]
+ | Event.Motion mm ->
+ match touch with
+ [ Some touch ->
+ let touch = {(touch) with Touch.n_globalX = float mm.mx; n_globalY = float mm.my; n_phase = Touch.TouchPhaseMoved} in
+ (
+ stage#processTouches [ touch ];
+ event_loop (Some touch) ticks
+ )
+ | None -> next_event None ticks
+ ]
+ | _ -> next_event touch ticks
+ ]
in
- event_loop touch 0
+ event_loop touch ticks
+ )
];
)
);

0 comments on commit ab9ef85

Please sign in to comment.
Something went wrong with that request. Please try again.