Source file ogg_decoder.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
(** Ogg stream demuxer *)
type metadata = string * (string * string) list
type ('a, 'b) decoder = {
name : string;
info : unit -> 'a * metadata;
decode : ('b -> unit) -> unit;
restart : fill:(unit -> unit) -> Ogg.Stream.stream -> unit;
samples_of_granulepos : Int64.t -> Int64.t;
}
type audio_info = { channels : int; sample_rate : int }
type audio_data = float array array
type audio_ba_data =
(float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array
type video_plane =
(int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
(** Only supported for now: plannar YUV formats. *)
type video_format =
| Yuvj_420
| Yuvj_422
| Yuvj_444
type video_info = {
fps_numerator : int;
fps_denominator : int;
width : int; (** Width of the Y' luminance plane *)
height : int; (** Height of the luminance plane *)
}
type video_data = {
format : video_format;
frame_width : int;
frame_height : int;
y_stride : int; (** Length, in bytes, per line *)
uv_stride : int; (** Length, in bytes, per line *)
y : video_plane; (** luminance data *)
u : video_plane; (** Cb data *)
v : video_plane; (** Cr data *)
}
type decoders =
| Video of (video_info, video_data) decoder
| Audio of (audio_info, audio_data) decoder
| Audio_ba of (audio_info, audio_ba_data) decoder
| Audio_both of
(audio_info, audio_data) decoder * (audio_info, audio_ba_data) decoder
| Unknown
type callbacks = {
read : bytes -> int -> int -> int;
seek : (int -> int) option;
tell : (unit -> int) option;
}
type index_element = {
index_bytes : int;
samples : Int64.t;
total_samples : Int64.t;
}
type stream = {
mutable os : Ogg.Stream.stream;
mutable position : float;
index : (Int64.t, index_element) Hashtbl.t;
mutable read_samples : Int64.t;
dec : decoders;
}
type t = {
sync : Ogg.Sync.t;
callbacks : callbacks;
mutable started : bool;
mutable last_p : int option;
log : string -> unit;
streams : (nativeint, stream) Hashtbl.t;
finished_streams : (nativeint, stream) Hashtbl.t;
}
type track =
| Audio_track of (string * nativeint)
| Video_track of (string * nativeint)
exception Internal of (Ogg.Page.t * int option)
exception Exit of nativeint * Ogg.Stream.stream * decoders
exception Track of (bool * nativeint * stream)
exception Invalid_stream
exception Not_available
exception End_of_stream
type register_decoder =
(Ogg.Stream.packet -> bool)
* (fill:(unit -> unit) -> Ogg.Stream.stream -> decoders)
let get_some x = match x with Some x -> x | None -> assert false
let ogg_decoders = Hashtbl.create 1
let log dec = Printf.ksprintf dec.log
let eos dec =
dec.started
&& Hashtbl.length dec.streams = 0
&& Hashtbl.length dec.finished_streams = 0
let granuleconv dec granulepos cur =
try
let ret =
match dec with
| Audio_ba d -> d.samples_of_granulepos granulepos
| Audio_both (d, _) -> d.samples_of_granulepos granulepos
| Audio d -> d.samples_of_granulepos granulepos
| Video d -> d.samples_of_granulepos granulepos
| Unknown -> assert false
in
if ret > Int64.zero then ret else cur
with _ -> cur
let feed_page ~position decoder page =
let serial = Ogg.Page.serialno page in
try
let stream = Hashtbl.find decoder.streams serial in
if stream.dec <> Unknown then begin
Ogg.Stream.put_page stream.os page;
let granulepos = Ogg.Page.granulepos page in
let total_samples =
granuleconv stream.dec granulepos stream.read_samples
in
if total_samples > stream.read_samples then begin
begin
match position with
| Some p ->
if not (Hashtbl.mem stream.index granulepos) then
Hashtbl.add stream.index granulepos
{
index_bytes = p;
samples = Int64.sub total_samples stream.read_samples;
total_samples = stream.read_samples;
}
| None -> ()
end;
stream.read_samples <- total_samples
end
end;
if Ogg.Page.eos page then begin
log decoder "Reached last page of logical stream %nx" serial;
Hashtbl.remove decoder.streams serial;
if stream.dec <> Unknown then
Hashtbl.add decoder.finished_streams serial stream
end
with Not_found ->
log decoder "Couldn't find a decoder for page in stream %nx" serial;
raise Invalid_stream
let get_page decoder =
if eos decoder then raise End_of_stream;
let position =
match decoder.callbacks.tell with None -> None | Some f -> Some (f ())
in
let page = Ogg.Sync.read decoder.sync in
match decoder.callbacks.tell with
| Some f ->
if Some (f ()) = position then (decoder.last_p, page)
else begin
let pos = decoder.last_p in
decoder.last_p <- position;
(pos, page)
end
| _ -> (None, page)
let feed decoder =
let position, page = get_page decoder in
feed_page ~position decoder page
let test dec page =
let serial = Ogg.Page.serialno page in
log dec "Found a ogg logical stream, serial: %nx" serial;
let os = Ogg.Stream.create ~serial () in
Ogg.Stream.put_page os page;
let packet = Ogg.Stream.peek_packet os in
try
Hashtbl.iter
(fun format (check, decode) ->
log dec "Trying ogg/%s format" format;
if check packet then (
log dec "ogg/%s format detected for stream %nx" format serial;
raise (Exit (serial, os, decode ~fill:(fun () -> feed dec) os)))
else ())
ogg_decoders;
log dec "Couldn't find a decoder for ogg logical stream with serial %nx"
serial;
raise (Exit (serial, os, Unknown))
with Exit (s, o, d) -> (s, o, d)
(** This should be called only
* when we are near the end of
* a stream... *)
let abort dec =
dec.started <- true;
begin
try
while Hashtbl.length dec.streams > 0 do
feed dec
done
with _ -> Hashtbl.clear dec.streams
end;
Hashtbl.clear dec.finished_streams
let parse dec =
assert (not (eos dec));
let rec parse () =
try
let position, page = get_page dec in
if not (Ogg.Page.bos page) then raise (Internal (page, position));
let serial, os, decoder = test dec page in
if Hashtbl.mem dec.streams serial then raise Invalid_stream;
let stream =
{
os;
position = 0.;
read_samples = Int64.zero;
index = Hashtbl.create 10;
dec = decoder;
}
in
Hashtbl.add dec.streams serial stream;
parse ()
with Internal (p, position) -> feed_page ~position dec p
in
parse ();
dec.started <- true;
dec
let init ?(log = fun _ -> ()) c =
let sync = Ogg.Sync.create c.read in
let streams = Hashtbl.create 2 in
let finished_streams = Hashtbl.create 2 in
let pos = match c.tell with None -> None | Some f -> Some (f ()) in
parse
{
sync;
started = false;
log;
streams;
callbacks = c;
last_p = pos;
finished_streams;
}
let unix_callbacks fd =
{
read = Unix.read fd;
tell = Some (fun () -> Unix.lseek fd 0 Unix.SEEK_CUR);
seek = Some (fun len -> Unix.lseek fd len Unix.SEEK_SET);
}
let init_from_fd ?log fd = init ?log (unix_callbacks fd)
let init_from_file ?log filename =
let fd = Unix.openfile filename [Unix.O_RDONLY] 0o640 in
(init_from_fd ?log fd, fd)
let get_ogg_sync dec = dec.sync
let reset dec =
if Hashtbl.length dec.streams > 0 || Hashtbl.length dec.finished_streams > 0
then log dec "Reseting a stream that has not ended!";
Hashtbl.clear dec.streams;
Hashtbl.clear dec.finished_streams;
dec.started <- false;
ignore (parse dec)
let fold_tracks dec f x =
let x = Hashtbl.fold f dec.streams x in
Hashtbl.fold f dec.finished_streams x
let get_track dec dtype =
let test ended id stream =
match (stream.dec, dtype) with
| Audio_ba _, Audio_track (_, x) when x = id ->
raise (Track (ended, id, stream))
| Audio_both _, Audio_track (_, x) when x = id ->
raise (Track (ended, id, stream))
| Audio _, Audio_track (_, x) when x = id ->
raise (Track (ended, id, stream))
| Video _, Video_track (_, x) when x = id ->
raise (Track (ended, id, stream))
| _ -> ()
in
try
Hashtbl.iter (test false) dec.streams;
Hashtbl.iter (test true) dec.finished_streams;
raise Not_found
with Track t -> t
let get_tracks dec =
let f id stream l =
match stream.dec with
| Audio_ba d -> Audio_track (d.name, id) :: l
| Audio_both (d, _) -> Audio_track (d.name, id) :: l
| Audio d -> Audio_track (d.name, id) :: l
| Video d -> Video_track (d.name, id) :: l
| Unknown -> l
in
fold_tracks dec f []
type standard_tracks = {
mutable audio_track : track option;
mutable video_track : track option;
}
let drop_track dec dtype =
let get_tracks id s l =
match (s.dec, dtype) with
| Audio_ba _, Audio_track (_, x) when x = id -> (id, s) :: l
| Audio_both _, Audio_track (_, x) when x = id -> (id, s) :: l
| Audio _, Audio_track (_, x) when x = id -> (id, s) :: l
| Video _, Video_track (_, x) when x = id -> (id, s) :: l
| _ -> l
in
let tracks = fold_tracks dec get_tracks [] in
let stype =
match dtype with Audio_track _ -> "audio" | Video_track _ -> "video"
in
let f (a, x) =
log dec "Dropping %s track with serial %nx." stype a;
Hashtbl.replace dec.streams a
{
os = x.os;
index = x.index;
read_samples = x.read_samples;
position = x.position;
dec = Unknown;
}
in
List.iter f tracks
let get_standard_tracks ?tracks dec =
let f id stream (a_t, v_t, l) =
match stream.dec with
| Audio_ba d when a_t = None -> (Some (Audio_track (d.name, id)), v_t, l)
| Audio_ba d -> (a_t, v_t, Audio_track (d.name, id) :: l)
| Audio_both (d, _) when a_t = None ->
(Some (Audio_track (d.name, id)), v_t, l)
| Audio_both (d, _) -> (a_t, v_t, Audio_track (d.name, id) :: l)
| Audio d when a_t = None -> (Some (Audio_track (d.name, id)), v_t, l)
| Audio d -> (a_t, v_t, Audio_track (d.name, id) :: l)
| Video d when v_t = None -> (a_t, Some (Video_track (d.name, id)), l)
| Video d -> (a_t, v_t, Video_track (d.name, id) :: l)
| _ -> (a_t, v_t, l)
in
let a_t, v_t, drop = fold_tracks dec f (None, None, []) in
List.iter (drop_track dec) drop;
match tracks with
| None -> { audio_track = a_t; video_track = v_t }
| Some x ->
x.audio_track <- a_t;
x.video_track <- v_t;
x
let update_standard_tracks dec tracks = ignore (get_standard_tracks ~tracks dec)
let get_standard_tracks dec = get_standard_tracks dec
let rec sample_rate_priv d dec =
try
match d with
| Audio_ba d -> ((fst (d.info ())).sample_rate, 1)
| Audio_both (d, _) -> ((fst (d.info ())).sample_rate, 1)
| Audio d -> ((fst (d.info ())).sample_rate, 1)
| Video d ->
((fst (d.info ())).fps_numerator, (fst (d.info ())).fps_denominator)
| _ -> assert false
with Ogg.Not_enough_data ->
feed dec;
sample_rate_priv d dec
let sample_rate dec dtype =
let _, _, stream = get_track dec dtype in
sample_rate_priv stream.dec dec
let get_track_position dec dtype =
let _, _, stream = get_track dec dtype in
stream.position
let get_position dec =
if Hashtbl.length dec.streams = 0 && Hashtbl.length dec.finished_streams = 0
then raise Not_available;
let f _ stream pos =
match stream.dec with
| Audio_ba _ | Audio_both _ | Audio _ | Video _ -> min stream.position pos
| _ -> pos
in
fold_tracks dec f max_float
let can_seek dec = dec.callbacks.seek <> None && dec.callbacks.tell <> None
type sync_point = {
sync_stream : stream;
sync_id : nativeint;
sync_rate : float;
mutable sync_seen : bool;
mutable sync_granulepos : Int64.t;
mutable sync_skip_samples : int;
mutable sync_bytes : int;
}
let sync_seek dec pos =
Ogg.Sync.reset dec.sync;
let seek = get_some dec.callbacks.seek in
ignore (seek pos);
Ogg.Sync.seek dec.sync
exception Position of (Int64.t * index_element)
let find_seek_pos dec time sync_point =
let samples = Int64.of_float (time *. sync_point.sync_rate) in
while sync_point.sync_stream.read_samples <= samples do
feed dec
done;
let f granulepos index_element =
if
index_element.total_samples <= samples
&& Int64.add index_element.total_samples index_element.samples >= samples
then raise (Position (granulepos, index_element))
in
let granulepos, index_element =
try
Hashtbl.iter f sync_point.sync_stream.index;
raise Not_found
with Position x -> x
in
let skip_samples = Int64.sub samples index_element.total_samples in
sync_point.sync_stream.read_samples <- index_element.total_samples;
sync_point.sync_granulepos <- granulepos;
sync_point.sync_skip_samples <- Int64.to_int skip_samples;
sync_point.sync_bytes <- index_element.index_bytes;
sync_point.sync_stream.position <-
Int64.to_float
(Int64.add sync_point.sync_stream.read_samples
(Int64.of_int sync_point.sync_skip_samples))
/. sync_point.sync_rate
let feed_sync_page sync_point page =
if Ogg.Page.granulepos page = sync_point.sync_granulepos then
sync_point.sync_seen <- true;
if sync_point.sync_seen then
Ogg.Stream.put_page sync_point.sync_stream.os page
exception Found_sync
let feed_sync dec sync_points =
let page = Ogg.Sync.read dec.sync in
try
List.iter
(fun sync_point ->
if Ogg.Page.serialno page = sync_point.sync_id then begin
feed_sync_page sync_point page;
raise Found_sync
end)
sync_points;
assert false
with Found_sync -> ()
let sync_forward dec sync_points sync_point =
let rec skip (cur, skipped) =
try
let pos = Ogg.Stream.peek_granulepos sync_point.sync_stream.os in
let total_samples = granuleconv sync_point.sync_stream.dec pos cur in
let diff = Int64.to_int (Int64.sub total_samples cur) in
if skipped + diff < sync_point.sync_skip_samples then begin
Ogg.Stream.skip_packet sync_point.sync_stream.os;
skip (total_samples, skipped + diff)
end
else
sync_point.sync_stream.position <-
(Int64.to_float sync_point.sync_stream.read_samples +. float skipped)
/. sync_point.sync_rate
with
| Ogg.Out_of_sync -> skip (cur, skipped)
| Ogg.Not_enough_data ->
feed_sync dec sync_points;
skip (cur, skipped)
in
skip (sync_point.sync_stream.read_samples, 0)
let seek ?(relative = false) dec time =
if (not (can_seek dec)) || get_tracks dec = [] then raise Not_available;
if eos dec then raise End_of_stream;
let orig_time = get_position dec in
if relative then
log dec "Seeking to %.02f sec from current position at %.02f sec" time
orig_time;
let time = if relative then time +. orig_time else time in
let time = if time < 0. then 0. else time in
log dec "Seeking to absolute position at %.2f sec" time;
let f id stream l =
let sample_rate () =
let x, y = sample_rate_priv stream.dec dec in
float x /. float y
in
match stream.dec with
| Audio_ba _ | Audio_both _ | Audio _ ->
{
sync_id = id;
sync_stream = stream;
sync_rate = sample_rate ();
sync_seen = false;
sync_granulepos = Int64.zero;
sync_skip_samples = 0;
sync_bytes = 0;
}
:: l
| Video _ ->
{
sync_id = id;
sync_stream = stream;
sync_rate = sample_rate ();
sync_seen = false;
sync_granulepos = Int64.zero;
sync_skip_samples = 0;
sync_bytes = 0;
}
:: l
| _ -> l
in
let sync_points = Hashtbl.fold f dec.streams [] in
List.iter (find_seek_pos dec time) sync_points;
let f x y = Hashtbl.add dec.streams x y in
Hashtbl.iter f dec.finished_streams;
Hashtbl.clear dec.finished_streams;
let sync_bytes =
let f cur sync_point =
if sync_point.sync_bytes < cur then sync_point.sync_bytes else cur
in
List.fold_left f max_int sync_points
in
let page = sync_seek dec sync_bytes in
let reiniate x =
x.sync_stream.os <- Ogg.Stream.create ~serial:x.sync_id ();
if Ogg.Page.serialno page = x.sync_id then feed_sync_page x page
in
List.iter reiniate sync_points;
let resync x =
sync_forward dec sync_points x;
let fill () = feed dec in
match x.sync_stream.dec with
| Audio_ba d -> d.restart ~fill x.sync_stream.os
| Audio_both (d, _) -> d.restart ~fill x.sync_stream.os
| Audio d -> d.restart ~fill x.sync_stream.os
| Video d -> d.restart ~fill x.sync_stream.os
| _ -> ()
in
List.iter resync sync_points;
let sync_time = get_position dec in
log dec "Found nearest seek point at %.02f sec" sync_time;
if relative then sync_time -. orig_time else sync_time
let seek ?relative dec time =
try seek ?relative dec time
with End_of_stream ->
abort dec;
raise End_of_stream
let incr_pos dec stream len =
let x, y = sample_rate_priv stream.dec dec in
let rate = float x /. float y in
stream.position <- stream.position +. (float len /. rate)
let rec audio_info dec dtype =
let _, _, stream = get_track dec dtype in
try
match stream.dec with
| Audio_ba d -> d.info ()
| Audio_both (d, _) -> d.info ()
| Audio d -> d.info ()
| _ -> raise Not_found
with Ogg.Not_enough_data ->
feed dec;
audio_info dec dtype
let can_decode_ba dec dtype =
let _, _, stream = get_track dec dtype in
match stream.dec with Audio_ba _ | Audio_both _ -> true | _ -> false
let rec video_info dec dtype =
let _, _, stream = get_track dec dtype in
try match stream.dec with Video d -> d.info () | _ -> raise Not_found
with Ogg.Not_enough_data ->
feed dec;
video_info dec dtype
let decode_audio_gen ~get_decoder ~length dec dtype f =
let ended, id, stream = get_track dec dtype in
try
let f x =
begin
try incr_pos dec stream (length x.(0)) with _ -> ()
end;
f x
in
(get_decoder stream.dec).decode f
with
| ( End_of_stream
| Ogg.Not_enough_data ) as e
->
if ended then begin
log dec "All data from stream %nx has been decoded" id;
Hashtbl.remove dec.finished_streams id
end
else if e = Ogg.Not_enough_data then raise e;
if eos dec then raise End_of_stream
let decode_audio =
let get_decoder = function
| Audio d -> d
| Audio_both (d, _) -> d
| _ -> raise Not_available
in
let length = Array.length in
decode_audio_gen ~get_decoder ~length
let decode_audio_ba =
let get_decoder = function
| Audio_ba d -> d
| Audio_both (_, d) -> d
| _ -> raise Not_available
in
let length = Bigarray.Array1.dim in
decode_audio_gen ~get_decoder ~length
let decode_video dec dtype f =
let ended, id, stream = get_track dec dtype in
try
let f x =
incr_pos dec stream 1;
f x
in
match stream.dec with Video d -> d.decode f | _ -> assert false
with (End_of_stream | Ogg.Not_enough_data) as e ->
if ended then begin
log dec "All data from stream %nx has been decoded: droping stream." id;
Hashtbl.remove dec.finished_streams id
end
else if e = Ogg.Not_enough_data then raise e;
if eos dec then raise End_of_stream
let decode_rec g dec dtype f =
let rec exec () =
try g dec dtype f
with Ogg.Not_enough_data ->
feed dec;
exec ()
in
exec ()
let decode_audio = decode_rec decode_audio
let decode_audio_ba = decode_rec decode_audio_ba
let decode_video = decode_rec decode_video