diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml new file mode 100644 index 0000000..17ee71c --- /dev/null +++ b/.github/workflows/main.yml @@ -0,0 +1,22 @@ +name: CI + +on: [push] + +jobs: + cancel_previous_run: + runs-on: ubuntu-latest + steps: + - name: Cancel Previous Runs + uses: styfle/cancel-workflow-action@0.4.0 + with: + access_token: ${{ github.token }} + + build: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-latest] + steps: + - name: Build and test module + uses: savonet/build-and-test-ocaml-module@main diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..04d31b9 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*~ +_build +*.byte +*.native +_tests +.merlin +*.install +.*.sw* diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..857030a --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,10 @@ +version=0.25.1 +profile = conventional +break-separators = after +space-around-lists = false +doc-comments = before +match-indent = 2 +match-indent-nested = always +parens-ite +exp-grouping = preserve +module-item-spacing = compact diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..23a79a4 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,128 @@ +0.8.0 (unreleased) +====== +* Add optional `fill` argument to ogg decoders. + +0.7.4 (2023-05-07) +===== +* Add `Stream.terminate` + +0.7.3 (14-08-2022) +===== +* Fix build error with OCaml `4.14` + +0.7.2 (28-06-2022) +===== +* Use `caml_alloc_custom_mem` for packet allocations (#2348) + +0.7.1 (07-03-2022) +===== +* Added decoder API for audio big array. + +0.7.0 (06-03-2021) +===== +* Switch to `dune` + +0.6.1 (19-10-2020) +===== +* Revert back to autoconf (See: savonet/liquidsoap#1378) + +0.6.0 (07-10-2020) +===== +* Switch to read callbacks with bytes in Ogg.Sync. + +0.5.2 (07-10-2017) +===== +* Fix compilation with OCaml 4.06 + +0.5.1 (11-04-2017) +===== +* Install .cmx files + +0.5.0 (03-08-2015) +===== +* Removed old Ogg.Stream backward compatibility functions. +* Switch to Bytes API. + +0.4.5 (08-05-2013) +===== +* Added optional fill parameter to [get_page] + to try to limit ogg logical pages size. + +0.4.4 (18-02-2013) +===== +* Added Ogg.Internal_error exception. +* Updated configure. + +0.4.3 (04-10-2011) +===== +* New Ogg_demuxer.End_of_stream exception, raised at the end of + logical streams. The former incorrect behavior was to raise + Ogg.End_of_stream, which is intended to signify the end of data. + +0.4.2 (02.07.2011) +===== +* Added [Ogg_demuxer] module to + decode ogg streams. +* Added the following functions: + - [Sync.sync] + - [Stream.{peek_granulepos, + skip_packet, + packet_granulepos}] +* Fixed incorrect mention of INRIA in + license headers. + +0.4.1 (04-09-2010) +===== +* Raise Out_of_sync in Sync.read + when data is not synced, e.g. + ogg_sync_pageout returned -1. + +0.4.0 (19-08-2010) +===== +* Removed sync reference in Stream.get_packet + and actually raise Out_of_sync exception. + No packet should be returned when the stream is + out of sync. + +0.3.1 (12-10-2009) +===== +* Added support for --enable-debugging configure option +* Added NO_CUSTOM to build + in standard mode. +* Added prefix to main compilation variables + if passed to configure. +* Makefile now honnors LIBDIRS + variable for linking against libraries + located in other places than then standard + ones. + +0.3.0 (17-02-2009) +===== +* Added file descriptor to Ogg.Sync.create_from_file + in order to be able to close it and let the Gc clean + everything.. +* Added Ogg.Stream.eos +* Added Ogg.Stream.peek_packet to peek a packet + without advancing the stream. Usefull to test first + packet when parsing ogg streams. + +0.2.0 (16-04-2008 +===== +* More portable invokation of make +* Now installs .cmx file +* Reworked API, added more functions. + + Binding is now ready to decode theora + and multiplexed streams + + Compatibility functions are available, + old code should compile on the new + API + +0.1.1 (05-11-2007) +===== +* Cleared out license headers. + Now using LGPL + linking exception +Acked-by: smimram + +0.1.0 (16-10-2007) +===== +* Initial release diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..d5bbede --- /dev/null +++ b/COPYING @@ -0,0 +1,525 @@ +The software distributed in this tarball is licenced under the GNU Lesser General +Public License, with a special exception: + +As a special exception to the GNU Library General Public License, you may +link, statically or dynamically, a "work that uses the Library" with a publicly +distributed version of the Library to produce an executable file containing +portions of the Library, and distribute that executable file under terms of +your choice, without any of the additional requirements listed in clause 6 +of the GNU Library General Public License. +By "a publicly distributed version of the Library", we mean either the unmodified +Library as distributed by The Savonet Team, or a modified version of the Library that is +distributed under the conditions defined in clause 3 of the GNU Library General +Public License. This exception does not however invalidate any other reasons why +the executable file might be covered by the GNU Library General Public License. + + + +The GNU Lesser General Public Licence text is: + +<---------------------------------------------------------------------- + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! + + diff --git a/README.md b/README.md new file mode 100644 index 0000000..849d876 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +ocaml-ogg +========= + +This package contains an OCaml interface for the `ogg` library + +Please read the COPYING file before using this software. + +Prerequisites: +============== + +- ocaml +- libogg +- findlib +- dune >= 2.0 + +Compilation: +============ + +``` +$ dune build +``` + +This should build both the native and the byte-code version of the +extension library. + +Installation: +============= + +Via `opam`: + +``` +$ opam install ogg +``` + +Via `dune` (for developers): +``` +$ dune install +``` + +This should install the library file (using ocamlfind) in the +appropriate place. + diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..0ffb0f8 --- /dev/null +++ b/dune-project @@ -0,0 +1,83 @@ +(lang dune 2.8) +(version 1.0.0) +(name ogg) +(source (github savonet/ocaml-xiph)) +(license "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception") +(authors "The Savonet Team ") +(maintainers "The Savonet Team ") + +(generate_opam_files true) +(use_standard_c_and_cxx_flags false) + +(package + (name ogg) + (synopsis "Bindings to libogg") + (depends + conf-libogg + conf-pkg-config + (ocaml (>= 4.08.0)) + dune + dune-configurator) +) + +(package + (name vorbis) + (synopsis "Bindings to libvorbis") + (depends + conf-libvorbis + conf-pkg-config + (ocaml (>= 4.03.0)) + dune + dune-configurator + (ogg (= :version))) +) + +(package + (name speex) + (synopsis "Bindings to libspeex") + (depends + conf-libogg + conf-libspeex + conf-pkg-config + dune + dune-configurator + (ocaml (>= 4.07)) + (ogg (= :version))) +) + +(package + (name theora) + (synopsis "Bindings to libtheora") + (depends + conf-libtheora + conf-pkg-config + dune + dune-configurator + (ogg (= :version))) +) + +(package + (name opus) + (synopsis "Bindings to libopus") + (depends + conf-libogg + conf-libopus + conf-pkg-config + (ocaml (>= 4.08.0)) + dune + dune-configurator + (ogg (= :version))) +) + +(package + (name flac) + (synopsis "Bindings to libflac") + (depends + conf-libflac + conf-pkg-config + (ocaml (>= 4.03.0)) + dune + dune-configurator) + (depopts + (ogg (= :version))) +) diff --git a/flac.opam b/flac.opam new file mode 100644 index 0000000..dd3b826 --- /dev/null +++ b/flac.opam @@ -0,0 +1,35 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "Bindings to libflac" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/savonet/ocaml-xiph" +bug-reports: "https://github.com/savonet/ocaml-xiph/issues" +depends: [ + "conf-libflac" + "conf-pkg-config" + "ocaml" {>= "4.03.0"} + "dune" {>= "2.8"} + "dune-configurator" + "odoc" {with-doc} +] +depopts: [ + "ogg" {= version} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/savonet/ocaml-xiph.git" diff --git a/flac/config/discover_flac.ml b/flac/config/discover_flac.ml new file mode 100644 index 0000000..7975e96 --- /dev/null +++ b/flac/config/discover_flac.ml @@ -0,0 +1,22 @@ +module C = Configurator.V1 + +external is_big_endian : unit -> bool = "ocaml_mm_is_big_endian" + +let () = + C.main ~name:"flac-pkg-config" (fun c -> + C.C_define.gen_header_file c ~fname:"flac_config.h" + [("BIGENDIAN", Switch (is_big_endian ()))]; + + let default : C.Pkg_config.package_conf = + { libs = ["-lflac"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match C.Pkg_config.query pc ~package:"flac" with + | None -> default + | Some deps -> deps) + in + C.Flags.write_sexp "flac_c_flags.sexp" conf.cflags; + C.Flags.write_sexp "flac_c_library_flags.sexp" conf.libs) diff --git a/flac/config/discover_flac_ogg.ml b/flac/config/discover_flac_ogg.ml new file mode 100644 index 0000000..989a19a --- /dev/null +++ b/flac/config/discover_flac_ogg.ml @@ -0,0 +1,17 @@ +module C = Configurator.V1 + +let () = + C.main ~name:"flac-ogg-pkg-config" (fun c -> + let default : C.Pkg_config.package_conf = + { libs = ["-logg"; "-lflac"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match C.Pkg_config.query pc ~package:"ogg flac" with + | None -> default + | Some deps -> deps) + in + C.Flags.write_sexp "flac_ogg_c_flags.sexp" conf.cflags; + C.Flags.write_sexp "flac_ogg_c_library_flags.sexp" conf.libs) diff --git a/flac/config/dune b/flac/config/dune new file mode 100644 index 0000000..1be63cc --- /dev/null +++ b/flac/config/dune @@ -0,0 +1,12 @@ +(executable + (name discover_flac) + (modules discover_flac) + (foreign_stubs + (language c) + (names endianess)) + (libraries dune.configurator)) + +(executable + (name discover_flac_ogg) + (modules discover_flac_ogg) + (libraries dune.configurator)) diff --git a/flac/config/endianess.c b/flac/config/endianess.c new file mode 100644 index 0000000..458070f --- /dev/null +++ b/flac/config/endianess.c @@ -0,0 +1,20 @@ +#include +#include + +enum +{ + OCAML_MM_LITTLE_ENDIAN = 0x0100, + OCAML_MM_BIG_ENDIAN = 0x0001, +}; + +static const union { unsigned char bytes[2]; uint16_t value; } host_order = + { { 0, 1 } }; + +CAMLprim value ocaml_mm_is_big_endian(value unit) { + CAMLparam0(); + + if (host_order.value == OCAML_MM_BIG_ENDIAN) + CAMLreturn(Val_bool(1)); + + CAMLreturn(Val_bool(0)); +} diff --git a/flac/dune b/flac/dune new file mode 100644 index 0000000..266e601 --- /dev/null +++ b/flac/dune @@ -0,0 +1,47 @@ +(library + (name flac) + (public_name flac) + (synopsis "OCaml bindings for libflac") + (modules flac) + (libraries unix) + (foreign_stubs + (language c) + (names flac_stubs) + (extra_deps "flac_config.h") + (flags + (:include flac_c_flags.sexp))) + (c_library_flags + (:include flac_c_library_flags.sexp))) + +(library + (name flac_ogg) + (public_name flac.ogg) + (synopsis "API to decode flac data in ogg container") + (libraries flac ogg) + (optional) + (modules flac_ogg) + (foreign_stubs + (language c) + (names flac_ogg_stubs) + (flags + (:include flac_ogg_c_flags.sexp))) + (c_library_flags + (:include flac_ogg_c_library_flags.sexp))) + +(library + (name flac_decoder) + (public_name flac.decoder) + (synopsis "Flac decoder for the ogg-decoder library") + (libraries ogg.decoder flac.ogg) + (optional) + (modules flac_decoder)) + +(rule + (targets flac_config.h flac_c_flags.sexp flac_c_library_flags.sexp) + (action + (run ./config/discover_flac.exe))) + +(rule + (targets flac_ogg_c_flags.sexp flac_ogg_c_library_flags.sexp) + (action + (run ./config/discover_flac_ogg.exe))) diff --git a/flac/flac.ml b/flac/flac.ml new file mode 100644 index 0000000..1051fc7 --- /dev/null +++ b/flac/flac.ml @@ -0,0 +1,242 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-flac. + * + * Ocaml-flac is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-flac 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-flac; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(* Author; Romain Beauxis *) + +exception Internal + +let () = Callback.register_exception "flac_exn_internal" Internal + +module Decoder = struct + type t + + (** Possible states of a decoder. *) + type state = + [ `Search_for_metadata + | `Read_metadata + | `Search_for_frame_sync + | `Read_frame + | `End_of_stream + | `Ogg_error + | `Seek_error + | `Aborted + | `Memory_allocation_error + | `Uninitialized ] + + exception Lost_sync + exception Bad_header + exception Frame_crc_mismatch + exception Unparseable_stream + exception Not_flac + + let () = + Callback.register_exception "flac_dec_exn_lost_sync" Lost_sync; + Callback.register_exception "flac_dec_exn_bad_header" Bad_header; + Callback.register_exception "flac_dec_exn_crc_mismatch" Frame_crc_mismatch; + Callback.register_exception "flac_dec_exn_unparseable_stream" + Unparseable_stream + + type info = { + sample_rate : int; + channels : int; + bits_per_sample : int; + total_samples : int64; + md5sum : string; + } + + type comments = string * (string * string) list + type comments_array = string * string array + + external info : t -> info * comments_array option = "ocaml_flac_decoder_info" + + let split_comment comment = + try + let equal_pos = String.index_from comment 0 '=' in + let c1 = String.uppercase_ascii (String.sub comment 0 equal_pos) in + let c2 = + String.sub comment (equal_pos + 1) + (String.length comment - equal_pos - 1) + in + (c1, c2) + with Not_found -> (comment, "") + + let _comments cmts = + match cmts with + | None -> None + | Some (vd, cmts) -> + Some (vd, Array.to_list (Array.map split_comment cmts)) + + let info x = + try + let info, comments = info x in + (info, _comments comments) + with Internal -> raise Not_flac + + external alloc : + seek:(int64 -> unit) option -> + tell:(unit -> int64) option -> + length:(unit -> int64) option -> + eof:(unit -> bool) option -> + read:(bytes -> int -> int -> int) -> + write:(float array array -> unit) -> + unit -> + t = "ocaml_flac_decoder_alloc_bytecode" "ocaml_flac_decoder_alloc_native" + + external cleanup : t -> unit = "ocaml_flac_cleanup_decoder" + external init : t -> unit = "ocaml_flac_decoder_init" + + let create ?seek ?tell ?length ?eof ~read ~write () = + let write pcm = write (Array.copy pcm) in + let dec = alloc ~seek ~tell ~length ~eof ~read ~write () in + Gc.finalise cleanup dec; + init dec; + let info, comments = info dec in + (dec, info, comments) + + external state : t -> state = "ocaml_flac_decoder_state" + external process : t -> unit = "ocaml_flac_decoder_process" + external seek : t -> Int64.t -> bool = "ocaml_flac_decoder_seek" + external flush : t -> bool = "ocaml_flac_decoder_flush" + external reset : t -> bool = "ocaml_flac_decoder_reset" + external to_s16le : float array array -> string = "caml_flac_float_to_s16le" + + module File = struct + type handle = { + fd : Unix.file_descr; + dec : t; + info : info; + comments : (string * (string * string) list) option; + } + + let create_from_fd ~write fd = + let read = Unix.read fd in + let seek n = + let n = Int64.to_int n in + ignore (Unix.lseek fd n Unix.SEEK_SET) + in + let tell () = Int64.of_int (Unix.lseek fd 0 Unix.SEEK_CUR) in + let length () = + let stats = Unix.fstat fd in + Int64.of_int stats.Unix.st_size + in + let eof () = + let stats = Unix.fstat fd in + Unix.lseek fd 0 Unix.SEEK_CUR = stats.Unix.st_size + in + let dec, info, comments = + create ~seek ~tell ~length ~eof ~write ~read () + in + { fd; comments; dec; info } + + let create ~write filename = + let fd = Unix.openfile filename [Unix.O_RDONLY] 0o640 in + try create_from_fd ~write fd + with e -> + Unix.close fd; + raise e + end +end + +module Encoder = struct + type priv + + type params = { + channels : int; + bits_per_sample : int; + sample_rate : int; + compression_level : int option; + total_samples : int64 option; + } + + type comments = (string * string) list + type t = priv * params + + exception Invalid_data + exception Invalid_metadata + + let () = + Callback.register_exception "flac_enc_exn_invalid_metadata" Invalid_metadata + + external vorbiscomment_entry_name_is_legal : string -> bool + = "ocaml_flac_encoder_vorbiscomment_entry_name_is_legal" + + external vorbiscomment_entry_value_is_legal : string -> bool + = "ocaml_flac_encoder_vorbiscomment_entry_value_is_legal" + + external alloc : + (string * string) array -> + seek:(int64 -> unit) option -> + tell:(unit -> int64) option -> + write:(bytes -> int -> unit) -> + params -> + priv = "ocaml_flac_encoder_alloc" + + external cleanup : priv -> unit = "ocaml_flac_cleanup_encoder" + external init : priv -> unit = "ocaml_flac_encoder_init" + + let create ?(comments = []) ?seek ?tell ~write p = + if p.channels <= 0 then raise Invalid_data; + let comments = Array.of_list comments in + let write b len = write (Bytes.sub b 0 len) in + let enc = alloc comments ~seek ~tell ~write p in + Gc.finalise cleanup enc; + init enc; + (enc, p) + + external process : priv -> float array array -> int -> unit + = "ocaml_flac_encoder_process" + + let process (enc, p) data = + if Array.length data <> p.channels then raise Invalid_data; + process enc data p.bits_per_sample + + external finish : priv -> unit = "ocaml_flac_encoder_finish" + + let finish (enc, _) = finish enc + + external from_s16le : string -> int -> float array array + = "caml_flac_s16le_to_float" + + module File = struct + type handle = { fd : Unix.file_descr; enc : t } + + let create_from_fd ?comments params fd = + let write s = + let len = Bytes.length s in + let rec f pos = + if pos < len then ( + let ret = Unix.write fd s pos (len - pos) in + f (pos + ret)) + in + f 0 + in + let seek n = + let n = Int64.to_int n in + ignore (Unix.lseek fd n Unix.SEEK_SET) + in + let tell () = Int64.of_int (Unix.lseek fd 0 Unix.SEEK_CUR) in + let enc = create ?comments ~seek ~tell ~write params in + { fd; enc } + + let create ?comments params filename = + let fd = Unix.openfile filename [Unix.O_CREAT; Unix.O_RDWR] 0o640 in + create_from_fd ?comments params fd + end +end diff --git a/flac/flac.mli b/flac/flac.mli new file mode 100644 index 0000000..72a827d --- /dev/null +++ b/flac/flac.mli @@ -0,0 +1,335 @@ +(* + * Copyright 2003-2010 Savonet team + * + * This file is part of Ocaml-flac. + * + * Ocaml-flac is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-flac 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-flac; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(* Author; Romain Beauxis *) + +(** {1 Native FLAC decoder/encoder modules for OCaml} *) + +(** Decode native FLAC data *) +module Decoder : sig + (** {3 Usage} *) + + (** A typical use of the FLAC decoder is the following: + * + * {v (* Raise this when streams has ended. *) + * exception End_of_stream + * (* Define a read function *) + * let input = (..a function of type read..) in + * (* Define a write function *) + * let output = (..a function of type write..) in + * (* Create callbacks *) + * let callbacks = Flac.Decoder.get_callbacks input write in + * (* Create an unitialized decoder *) + * let decoder = Flac.Decoder.create callbacks in + * (* Initialize decoder *) + * let decoder,info,comments = Flac.Decoder.init decoder callbacks in + * (..do something with info and comments..) + * (* Decode data *) + * match Flac.Decoder.state decoder c with + * | `Search_for_metadata + * | `Read_metadata + * | `Search_for_frame_sync + * | `Read_frame -> + * Flac.Decoder.process decoder callbacks + * | _ -> raise End_of_stream v} + * + * Some remarks: + * - Exceptions raised by callbacks should be treated + * as fatal errors. The dehaviour of the flac library + * after being interrupted by an exception is unknown. + * The only notable exception is Ogg/flac decoding, where + * the read callback raises [Ogg.Not_enough_data]. + * - The state of the decoder should be checked prior to calling + * [process]. Termination may not be detected nor raise an + * exception so it is the caller's responsibility to check + * on this. + * - See FLAC documentation for the information on the + * callbacks. + * - The variant type for decoder and callbacks is used + * to make sure that different type of decoders + * (generic, file, ogg) are only used with the same + * type of callbacks. *) + + (** {3 Types } *) + + type t + + type info = { + sample_rate : int; + channels : int; + bits_per_sample : int; + total_samples : int64; + md5sum : string; + } + + (** (Vorbis) comments of decoded FLAC data. *) + type comments = string * (string * string) list + + (** Possible states of a decoder. *) + type state = + [ (* The decoder is ready to search for metadata. *) + `Search_for_metadata + (* The decoder is ready to or is in the process of reading metadata. *) + | `Read_metadata + (* The decoder is ready to or is in the process of searching for the + frame sync code. *) + | `Search_for_frame_sync + (* The decoder is ready to or is in the process of reading a frame. *) + | `Read_frame (* The decoder has reached the end of the stream. *) + | `End_of_stream (* An error occurred in the underlying Ogg layer. *) + | `Ogg_error + (* An error occurred while seeking. The decoder must be flushed + or reset before decoding can continue. *) + | `Seek_error (* The decoder was aborted by the read callback. *) + | `Aborted + (* An error occurred allocating memory. The decoder is in an invalid + state and can no longer be used. *) + | `Memory_allocation_error + (* This state is seen in the case of + an uninitialized ogg decoder. *) + | `Uninitialized ] + + (** {3 Exceptions } *) + + (** An error in the stream caused the decoder to lose synchronization. *) + exception Lost_sync + + (** The decoder encountered a corrupted frame header. *) + exception Bad_header + + (** The frame's data did not match the CRC in the footer. *) + exception Frame_crc_mismatch + + (** The decoder encountered reserved fields in use in the stream. *) + exception Unparseable_stream + + (** Raised if trying to decode a stream that + * is not flac. *) + exception Not_flac + + (** {3 Functions} *) + + (** Create a decoder. The decoder will be used to decode + * all metadata. Initial audio data shall be immediatly available + * after this call. *) + val create : + ?seek:(int64 -> unit) -> + ?tell:(unit -> int64) -> + ?length:(unit -> int64) -> + ?eof:(unit -> bool) -> + read:(bytes -> int -> int -> int) -> + write:(float array array -> unit) -> + unit -> + t * info * comments option + + (** Decode one frame of audio data. *) + val process : t -> unit + + (** Flush the input and seek to an absolute sample. + * Decoding will resume at the given sample. Note + * that because of this, the next write callback may + * contain a partial block. The client must support seeking + * the input or this function will fail and return [false]. + * Furthermore, if the decoder state is [`Seek_error] + * then the decoder must be flushed or reset + * before decoding can continue. *) + val seek : t -> Int64.t -> bool + + (** Flush the stream input. + * The decoder's input buffer will be cleared and the state set to + * [`Search_for_frame_sync]. This will also turn + * off MD5 checking. *) + val flush : t -> bool + + (** Reset the decoding process. + * The decoder's input buffer will be cleared and the state set to + * [`Search_for_metadata]. MD5 checking will be restored to its original + * setting. + * + * If the decoder is seekable, the decoder will also attempt to seek to + * the beginning of the stream. If this rewind fails, this function will + * return [false]. It follows that [reset] cannot be used when decoding + * from [stdin]. + * + * If the decoder is not seekable (i.e. no seek callback was provided) + * it is the duty of the client to start feeding data from the beginning + * of the stream on the next [process]. *) + val reset : t -> bool + + (** Get the state of a decoder. *) + val state : t -> state + + (** {3 Convenience} *) + + (** Convert an audio array to a S16LE string for + * decoding FLAC to WAV and raw PCM *) + val to_s16le : float array array -> string + + (** Local file decoding. *) + module File : sig + (** Convenience module to + * decode local files *) + + (** {3 Types} *) + + (* Handler for file decoder *) + type handle = { + fd : Unix.file_descr; + dec : t; + info : info; + comments : (string * (string * string) list) option; + } + + (** {3 Functions} *) + + (** Create a file decoder from a Unix file + * descriptor + * + * Note: this decoder requires seeking thus will only work on seekable + * file descriptor. *) + val create_from_fd : + write:(float array array -> unit) -> Unix.file_descr -> handle + + (** Create a file decoder from a file URI *) + val create : write:(float array array -> unit) -> string -> handle + end +end + +(** Encode native FLAC data *) +module Encoder : sig + (** {3 Usage} *) + + (** A typical use of the FLAC encoder is the following: + * {v (* A function to write encoded data *) + * let write = (..a function of type write..) in + * (* Create the encoding callbacks *) + * let callbacks = Flac.Encoder.get_callbacks write in + * (* Define the parameters and comments *) + * let params = (..a value of type params ..) in + * let comments = [("title","FLAC encoding example")] in + * (* Create an encoder *) + * let enc = Flac.Encoder.create ~comments params callbacks in + * (* Encode data *) + * let data = (..a value of type float array array.. in + * Flac.Encoder.process enc callbacks data ; + * (..repeat encoding process..) + * (* Close encoder *) + * Flac.Encoder.finish enc callbacks v} + * + * Remarks: + * - Exceptions raised by the callbacks should be treated + * as fatal. The behaviour of the FLAC encoding library is + * unknown after interrupted by an exception. + * - Encoded data should have the same number of channels as + * specified in encoder's parameters and the same number of + * samples in each channels. + * - See FLAC documentation for informations about the callbacks. + * Note in particular that some information about encoded data + * such as md5 sum and total samples are only written when a + * [seek] callback is given. + * - Variant types for callbacks and encoder are used to make sure + * that different type of callbacks (generic, file, ogg) are always + * used with the corresponding decoder type. *) + + (** {3 Types} *) + + (** Type of an encoder. *) + type t + + (** Type of encoding parameters *) + type params = { + channels : int; + bits_per_sample : int; + sample_rate : int; + compression_level : int option; + total_samples : int64 option; + } + + (** (Vorbis) comments for encoding *) + type comments = (string * string) list + + (** {3 Exceptions} *) + + (** Raised when submiting invalid data to + * encode *) + exception Invalid_data + + (** Raised when initiating an encoder with + * invalid metadata. You can use `vorbiscomment_entry_name_is_legal` + * and `vorbiscomment_entry_value_is_legal` to check submitted metadata. *) + exception Invalid_metadata + + (** {3 Functions} *) + + (** Check if a comment label is valid *) + val vorbiscomment_entry_name_is_legal : string -> bool + + (** Check if a comment value is valid *) + val vorbiscomment_entry_value_is_legal : string -> bool + + (** Create an encoder *) + val create : + ?comments:comments -> + ?seek:(int64 -> unit) -> + ?tell:(unit -> int64) -> + write:(bytes -> unit) -> + params -> + t + + (** Encode some data *) + val process : t -> float array array -> unit + + (** Terminate an encoder. Causes the encoder to + * flush remaining encoded data. The encoder should + * not be used anymore afterwards. *) + val finish : t -> unit + + (** {3 Convenience} *) + + (** Convert S16LE pcm data to an audio array for + * encoding WAV and raw PCM to flac. *) + val from_s16le : string -> int -> float array array + + (** Encode to a local file *) + module File : sig + (** Convenience module to encode to a local native FLAC file. *) + + (** {3 Types} *) + + (** Handle for file encoder *) + type handle = { fd : Unix.file_descr; enc : t } + + (** {3 Functions} *) + + (** Create a file encoder writing data to a given Unix file descriptor. + * + * Note: this encoder requires seeking thus will only work on seekable + * file descriptor. *) + val create_from_fd : + ?comments:comments -> params -> Unix.file_descr -> handle + + (** Create a file encoder writing data to the given file URI *) + val create : ?comments:comments -> params -> string -> handle + end +end + +(** Raised when an internal error occured. Should be + * reported if seen. *) +exception Internal diff --git a/flac/flac_decoder.ml b/flac/flac_decoder.ml new file mode 100644 index 0000000..e06da5a --- /dev/null +++ b/flac/flac_decoder.ml @@ -0,0 +1,77 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-flac. + * + * Ocaml-flac is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-flac 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-flac; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +let check = Flac_ogg.Decoder.check_packet + +let mk_decoder ~fill ~write os = + let dec, info, m = Flac_ogg.Decoder.create ~fill ~write os in + let meta = match m with None -> ("Unknown vendor", []) | Some x -> x in + (dec, info, meta) + +let decoder ~fill os = + let decoder = ref None in + let write_ref = ref (fun _ -> ()) in + let write ret = + let fn = !write_ref in + fn ret + in + let get_decoder () = + match !decoder with + | None -> + let dec, info, meta = mk_decoder ~fill ~write os in + decoder := Some (dec, info, meta); + (dec, info, meta) + | Some d -> d + in + let info () = + let _, info, m = get_decoder () in + ( { + Ogg_decoder.channels = info.Flac.Decoder.channels; + sample_rate = info.Flac.Decoder.sample_rate; + }, + m ) + in + let decode write = + write_ref := write; + let decoder, _, _ = get_decoder () in + match Flac.Decoder.state decoder with + | `Search_for_metadata | `Read_metadata | `Search_for_frame_sync + | `Read_frame -> + Flac.Decoder.process decoder + (* Ogg decoder is responsible for detecting end of stream vs. end of track. *) + | _ -> raise Ogg.Not_enough_data + in + let restart ~fill new_os = + (write_ref := fun _ -> ()); + let d, _, _ = get_decoder () in + (* Flush error are very unlikely. *) + assert (Flac.Decoder.flush d); + decoder := Some (mk_decoder ~fill ~write new_os) + in + Ogg_decoder.Audio + { + Ogg_decoder.name = "flac"; + info; + decode; + restart; + samples_of_granulepos = (fun x -> x); + } + +let register () = Hashtbl.add Ogg_decoder.ogg_decoders "flac" (check, decoder) diff --git a/flac/flac_decoder.mli b/flac/flac_decoder.mli new file mode 100644 index 0000000..1865cbc --- /dev/null +++ b/flac/flac_decoder.mli @@ -0,0 +1,25 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-flac. + * + * Ocaml-flac is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-flac 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-flac; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** Ogg flac decoder implementation for + * the [Ogg_demuxer] module. *) + +(** Register the decoder. *) +val register : unit -> unit diff --git a/flac/flac_ogg.ml b/flac/flac_ogg.ml new file mode 100644 index 0000000..dd820a8 --- /dev/null +++ b/flac/flac_ogg.ml @@ -0,0 +1,118 @@ +(* + * Copyright 2003-2010 Savonet team + * + * This file is part of Ocaml-flac. + * + * Ocaml-flac is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-flac 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-flac; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(* Author; Romain Beauxis *) + +module Decoder = struct + external get_packet_data : Ogg.Stream.packet -> string + = "ocaml_flac_decoder_packet_data" + + let ogg_header_len = 9 + + let create ~fill ~write os = + let read_data = Buffer.create 1024 in + let is_first_packet = ref true in + let rec read bytes ofs len = + try + if Buffer.length read_data = 0 then ( + let p = Ogg.Stream.get_packet os in + let data = get_packet_data p in + let data = + if !is_first_packet then ( + let len = String.length data in + assert (len > ogg_header_len); + String.sub data ogg_header_len (len - ogg_header_len)) + else data + in + is_first_packet := false; + Buffer.add_string read_data data); + let c = Buffer.contents read_data in + let c_len = String.length c in + let len = min len c_len in + let rem = String.sub c len (c_len - len) in + Buffer.reset read_data; + Buffer.add_string read_data rem; + Bytes.blit_string c 0 bytes ofs len; + len + with + | Ogg.Not_enough_data -> + fill (); + read bytes ofs len + | Ogg.End_of_stream -> 0 + in + Flac.Decoder.create ~read ~write () + + external check_packet : Ogg.Stream.packet -> bool + = "ocaml_flac_decoder_check_ogg" +end + +module Encoder = struct + type priv + type t = { encoder : Flac.Encoder.t; first_pages : Ogg.Page.t list } + + external alloc : + (string * string) array -> + seek:(int64 -> unit) option -> + tell:(unit -> int64) option -> + write:(bytes -> int -> unit) -> + Flac.Encoder.params -> + priv = "ocaml_flac_encoder_alloc" + + external cleanup : priv -> unit = "ocaml_flac_cleanup_encoder" + external init : priv -> nativeint -> unit = "ocaml_flac_encoder_ogg_init" + + let create ?(comments = []) ~serialno ~write params = + if params.Flac.Encoder.channels <= 0 then raise Flac.Encoder.Invalid_data; + let comments = Array.of_list comments in + let first_pages_parsed = ref false in + let first_pages = ref [] in + let header = ref None in + let write_wrap write p = + match !header with + | Some h -> + header := None; + write (h, p) + | None -> header := Some p + in + let write_first_page p = first_pages := p :: !first_pages in + let write = + write_wrap (fun p -> + if !first_pages_parsed then write p else write_first_page p) + in + let write b len = write (Bytes.sub_string b 0 len) in + let enc = alloc comments ~seek:None ~tell:None ~write params in + Gc.finalise cleanup enc; + init enc serialno; + first_pages_parsed := true; + assert (!header = None); + { encoder = Obj.magic (enc, params); first_pages = List.rev !first_pages } +end + +module Skeleton = struct + external fisbone : + Nativeint.t -> Int64.t -> Int64.t -> string -> Ogg.Stream.packet + = "ocaml_flac_skeleton_fisbone" + + let fisbone ?(start_granule = Int64.zero) + ?(headers = [("Content-type", "audio/x-flac")]) ~serialno ~samplerate () = + let concat s (h, v) = Printf.sprintf "%s%s: %s\r\n" s h v in + let s = List.fold_left concat "" headers in + fisbone serialno samplerate start_granule s +end diff --git a/flac/flac_ogg.mli b/flac/flac_ogg.mli new file mode 100644 index 0000000..cb0fd36 --- /dev/null +++ b/flac/flac_ogg.mli @@ -0,0 +1,63 @@ +(* + * Copyright 2003-2010 Savonet team + * + * This file is part of Ocaml-flac. + * + * Ocaml-flac is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-flac 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-flac; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(* Author; Romain Beauxis *) + +(** {1 Ogg/flac encoder/decoder modules for OCaml} *) + +module Decoder : sig + (** Check if an ogg packet is the first + * packet of an ogg/flac stream. *) + val check_packet : Ogg.Stream.packet -> bool + + val create : + fill:(unit -> unit) -> + write:(float array array -> unit) -> + Ogg.Stream.stream -> + Flac.Decoder.t * Flac.Decoder.info * Flac.Decoder.comments option +end + +module Encoder : sig + type t = { encoder : Flac.Encoder.t; first_pages : Ogg.Page.t list } + + val create : + ?comments:(string * string) list -> + serialno:Nativeint.t -> + write:(Ogg.Page.t -> unit) -> + Flac.Encoder.params -> + t +end + +(** Ogg/flac skeleton module *) +module Skeleton : sig + (** Generate a flac fisbone packet with + * these parameters, to use in an ogg skeleton. + * Default value for [start_granule] is [Int64.zero], + * Default value for [headers] is ["Content-type","audio/x-flac"] + * + * See: http://xiph.org/ogg/doc/skeleton.html. *) + val fisbone : + ?start_granule:Int64.t -> + ?headers:(string * string) list -> + serialno:Nativeint.t -> + samplerate:Int64.t -> + unit -> + Ogg.Stream.packet +end diff --git a/flac/flac_ogg_stubs.c b/flac/flac_ogg_stubs.c new file mode 100644 index 0000000..2faa5d1 --- /dev/null +++ b/flac/flac_ogg_stubs.c @@ -0,0 +1,144 @@ +/* This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * 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 General Public License for more details. + * + * You should have received a copy of the GNU 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. + * + * Chunks of this code have been borrowed and influenced + * by flac/decode.c and the flac XMMS plugin. + * + */ + +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +#include + +#include "flac_stubs.h" + +/* C.f. http://flac.sourceforge.net/ogg_mapping.html */ +CAMLprim value ocaml_flac_decoder_check_ogg(value v) { + CAMLparam1(v); + ogg_packet *p = Packet_val(v); + unsigned char *h = p->packet; + if (p->bytes < 9 || + /* FLAC */ + h[0] != 0x7f || h[1] != 'F' || h[2] != 'L' || h[3] != 'A' || h[4] != 'C') + CAMLreturn(Val_false); + + CAMLreturn(Val_true); +} + +CAMLprim value ocaml_flac_decoder_packet_data(value v) { + CAMLparam1(v); + CAMLlocal1(ans); + ogg_packet *p = Packet_val(v); + + ans = caml_alloc_string(p->bytes); + memcpy((char *)String_val(ans), p->packet, p->bytes); + CAMLreturn(ans); +} + +/* Encoder */ + +CAMLprim value ocaml_flac_encoder_ogg_init(value _enc, value _serialno) { + CAMLparam2(_enc, _serialno); + + intnat serialno = Nativeint_val(_serialno); + + ocaml_flac_encoder *enc = Encoder_val(_enc); + + caml_release_runtime_system(); + FLAC__stream_encoder_set_ogg_serial_number(enc->encoder, serialno); + FLAC__stream_encoder_init_ogg_stream(enc->encoder, NULL, enc_write_callback, + NULL, NULL, NULL, + (void *)&enc->callbacks); + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} + +/* Ogg skeleton interface */ + +/* Wrappers */ +static void write32le(unsigned char *ptr, ogg_uint32_t v) { + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; +} + +static void write64le(unsigned char *ptr, ogg_int64_t v) { + ogg_uint32_t hi = v >> 32; + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; + ptr[4] = hi & 0xff; + ptr[5] = (hi >> 8) & 0xff; + ptr[6] = (hi >> 16) & 0xff; + ptr[7] = (hi >> 24) & 0xff; +} + +/* Values from http://xiph.org/ogg/doc/skeleton.html */ +#define FISBONE_IDENTIFIER "fisbone\0" +#define FISBONE_MESSAGE_HEADER_OFFSET 44 +#define FISBONE_SIZE 52 + +/* Code from theorautils.c in ffmpeg2theora */ +CAMLprim value ocaml_flac_skeleton_fisbone(value serial, value samplerate, + value start, value content) { + CAMLparam4(serial, samplerate, start, content); + CAMLlocal1(packet); + ogg_packet op; + int len = FISBONE_SIZE + caml_string_length(content); + + memset(&op, 0, sizeof(op)); + op.packet = malloc(len); + if (op.packet == NULL) + caml_raise_out_of_memory(); + + memset(op.packet, 0, len); + /* it will be the fisbone packet for the vorbis audio */ + memcpy(op.packet, FISBONE_IDENTIFIER, 8); /* identifier */ + write32le( + op.packet + 8, + FISBONE_MESSAGE_HEADER_OFFSET); /* offset of the message header fields */ + write32le(op.packet + 12, + Nativeint_val(serial)); /* serialno of the vorbis stream */ + write32le(op.packet + 16, 2); /* number of header packet, 2 for now. */ + /* granulerate, temporal resolution of the bitstream in Hz */ + write64le(op.packet + 20, + (ogg_int64_t)Int64_val(samplerate)); /* granulerate numerator */ + write64le(op.packet + 28, (ogg_int64_t)1); /* granulerate denominator */ + write64le(op.packet + 36, (ogg_int64_t)Int64_val(start)); /* start granule */ + write32le(op.packet + 44, 2); /* preroll, for flac its 2 ??? */ + *(op.packet + 48) = 0; /* granule shift, always 0 for flac */ + memcpy(op.packet + FISBONE_SIZE, String_val(content), + caml_string_length(content)); + + op.b_o_s = 0; + op.e_o_s = 0; + op.bytes = len; + + packet = value_of_packet(&op); + free(op.packet); + CAMLreturn(packet); +} diff --git a/flac/flac_stubs.c b/flac/flac_stubs.c new file mode 100644 index 0000000..877dc96 --- /dev/null +++ b/flac/flac_stubs.c @@ -0,0 +1,873 @@ +/* This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * 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 General Public License for more details. + * + * You should have received a copy of the GNU 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. + * + * Chunks of this code have been borrowed and influenced + * by flac/decode.c and the flac XMMS plugin. + * + */ + +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +#include "flac_config.h" +#include "flac_stubs.h" + +#ifndef Bytes_val +#define Bytes_val String_val +#endif + +#ifndef INT24_MAX +#define INT24_MAX 0x007fffffL +#endif + +/* Thank you + * http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php#ref_option + */ +value flac_Val_some(value v) { + CAMLparam1(v); + CAMLlocal1(some); + some = caml_alloc(1, 0); + Store_field(some, 0, v); + CAMLreturn(some); +} + +/* Threads management. */ +static pthread_key_t ocaml_c_thread_key; +static pthread_once_t ocaml_c_thread_key_once = PTHREAD_ONCE_INIT; + +static void ocaml_flac_on_thread_exit(void *key) { caml_c_thread_unregister(); } + +static void ocaml_flac_make_key() { + pthread_key_create(&ocaml_c_thread_key, ocaml_flac_on_thread_exit); +} + +void ocaml_flac_register_thread() { + static int initialized = 1; + + pthread_once(&ocaml_c_thread_key_once, ocaml_flac_make_key); + + if (caml_c_thread_register() && !pthread_getspecific(ocaml_c_thread_key)) + pthread_setspecific(ocaml_c_thread_key, (void *)&initialized); +} + +/* Convenience functions */ +#ifdef BIGENDIAN +static inline int16_t bswap_16(int16_t x) { + return ((((x) >> 8) & 0xff) | (((x) & 0xff) << 8)); +} +#endif + +static inline int16_t clip(double s) { + if (s < -1) + return INT16_MIN; + + if (s > 1) + return INT16_MAX; + + return (s * INT16_MAX); +} + +CAMLprim value caml_flac_float_to_s16le(value a) { + CAMLparam1(a); + CAMLlocal1(ans); + int c, i; + int nc = Wosize_val(a); + if (nc == 0) + CAMLreturn(caml_copy_string("")); + int len = Wosize_val(Field(a, 0)) / Double_wosize; + ans = caml_alloc_string(2 * len * nc); + int16_t *dst = (int16_t *)String_val(ans); + + for (c = 0; c < nc; c++) { + for (i = 0; i < len; i++) { + dst[i * nc + c] = clip(Double_field(Field(a, c), i)); +#ifdef BIGENDIAN + dst[i * nc + c] = bswap_16(dst[i * nc + c]); +#endif + } + } + + CAMLreturn(ans); +} + +#define s16tof(x) (((double)x) / INT16_MAX) +#ifdef BIGENDIAN +#define get_s16le(src, nc, c, i) s16tof(bswap_16(((int16_t *)src)[i * nc + c])) +#else +#define get_s16le(src, nc, c, i) s16tof(((int16_t *)src)[i * nc + c]) +#endif + +CAMLprim value caml_flac_s16le_to_float(value _src, value _chans) { + CAMLparam1(_src); + CAMLlocal1(ans); + char *src = (char *)Bytes_val(_src); + int chans = Int_val(_chans); + int samples = caml_string_length(_src) / (2 * chans); + int i, c; + + ans = caml_alloc_tuple(chans); + for (c = 0; c < chans; c++) + Store_field(ans, c, caml_alloc(samples * Double_wosize, Double_array_tag)); + + for (c = 0; c < chans; c++) + for (i = 0; i < samples; i++) + Store_double_field(Field(ans, c), i, get_s16le(src, chans, c, i)); + + CAMLreturn(ans); +} + +/* Decoder */ + +/* polymorphic variant utility macros */ +#define get_var(x) caml_hash_variant(#x) + +static value val_of_state(int s) { + switch (s) { + case FLAC__STREAM_DECODER_SEARCH_FOR_METADATA: + return get_var(Search_for_metadata); + case FLAC__STREAM_DECODER_READ_METADATA: + return get_var(Read_metadata); + case FLAC__STREAM_DECODER_SEARCH_FOR_FRAME_SYNC: + return get_var(Search_for_frame_sync); + case FLAC__STREAM_DECODER_READ_FRAME: + return get_var(Read_frame); + case FLAC__STREAM_DECODER_END_OF_STREAM: + return get_var(End_of_stream); + case FLAC__STREAM_DECODER_OGG_ERROR: + return get_var(Ogg_error); + case FLAC__STREAM_DECODER_SEEK_ERROR: + return get_var(Seek_error); + case FLAC__STREAM_DECODER_ABORTED: + return get_var(Aborted); + case FLAC__STREAM_DECODER_MEMORY_ALLOCATION_ERROR: + return get_var(Memory_allocation_error); + case FLAC__STREAM_DECODER_UNINITIALIZED: + return get_var(Uninitialized); + default: + return get_var(Unknown); + } +} + +static value raise_exn_of_error(FLAC__StreamDecoderErrorStatus e) { + switch (e) { + case FLAC__STREAM_DECODER_ERROR_STATUS_LOST_SYNC: + caml_raise_constant(*caml_named_value("flac_dec_exn_lost_sync")); + case FLAC__STREAM_DECODER_ERROR_STATUS_BAD_HEADER: + caml_raise_constant(*caml_named_value("flac_dec_exn_bad_header")); + case FLAC__STREAM_DECODER_ERROR_STATUS_FRAME_CRC_MISMATCH: + caml_raise_constant(*caml_named_value("flac_dec_exn_crc_mismatch")); + case FLAC__STREAM_DECODER_ERROR_STATUS_UNPARSEABLE_STREAM: + caml_raise_constant(*caml_named_value("flac_dec_exn_unparseable_stream")); + default: + caml_raise_constant(*caml_named_value("flac_exn_internal")); + } +} + +/* Caml abstract value containing the decoder. */ +#define Decoder_val(v) (*((ocaml_flac_decoder **)Data_custom_val(v))) + +CAMLprim value ocaml_flac_cleanup_decoder(value e) { + ocaml_flac_decoder *dec = Decoder_val(e); + + caml_remove_generational_global_root(&dec->callbacks.read_cb); + caml_remove_generational_global_root(&dec->callbacks.seek_cb); + caml_remove_generational_global_root(&dec->callbacks.tell_cb); + caml_remove_generational_global_root(&dec->callbacks.eof_cb); + caml_remove_generational_global_root(&dec->callbacks.length_cb); + caml_remove_generational_global_root(&dec->callbacks.write_cb); + caml_remove_generational_global_root(&dec->callbacks.buffer); + caml_remove_generational_global_root(&dec->callbacks.output); + + return Val_unit; +} + +static void finalize_decoder(value e) { + ocaml_flac_decoder *dec = Decoder_val(e); + + FLAC__stream_decoder_delete(dec->decoder); + if (dec->callbacks.info != NULL) + free(dec->callbacks.info); + if (dec->callbacks.meta != NULL) + FLAC__metadata_object_delete(dec->callbacks.meta); + + free(dec); +} + +static struct custom_operations decoder_ops = { + "ocaml_flac_decoder", finalize_decoder, custom_compare_default, + custom_hash_default, custom_serialize_default, custom_deserialize_default}; + +/* start all the callbacks here. */ +void dec_metadata_callback(const FLAC__StreamDecoder *decoder, + const FLAC__StreamMetadata *metadata, + void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + switch (metadata->type) { + case FLAC__METADATA_TYPE_STREAMINFO: + if (callbacks->info != NULL) { + caml_acquire_runtime_system(); + caml_raise_constant(*caml_named_value("flac_exn_internal")); + } + callbacks->info = malloc(sizeof(FLAC__StreamMetadata_StreamInfo)); + if (callbacks->info == NULL) { + // This callback is run in non-blocking mode + caml_acquire_runtime_system(); + caml_raise_out_of_memory(); + } + memcpy(callbacks->info, &metadata->data.stream_info, + sizeof(FLAC__StreamMetadata_StreamInfo)); + break; + case FLAC__METADATA_TYPE_VORBIS_COMMENT: + if (callbacks->meta != NULL) { + caml_acquire_runtime_system(); + caml_raise_constant(*caml_named_value("flac_exn_internal")); + } + callbacks->meta = FLAC__metadata_object_clone(metadata); + if (callbacks->meta == NULL) { + caml_acquire_runtime_system(); + caml_raise_out_of_memory(); + } + break; + default: + break; + } + return; +} + +void dec_error_callback(const FLAC__StreamDecoder *decoder, + FLAC__StreamDecoderErrorStatus status, + void *client_data) { + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + raise_exn_of_error(status); + return; +} + +static FLAC__StreamDecoderSeekStatus +dec_seek_callback(const FLAC__StreamDecoder *decoder, + FLAC__uint64 absolute_byte_offset, void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + + if (callbacks->seek_cb == Val_none) + return FLAC__STREAM_DECODER_SEEK_STATUS_UNSUPPORTED; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + caml_callback(callbacks->seek_cb, caml_copy_int64(absolute_byte_offset)); + caml_release_runtime_system(); + + return FLAC__STREAM_DECODER_SEEK_STATUS_OK; +} + +static FLAC__StreamDecoderTellStatus +dec_tell_callback(const FLAC__StreamDecoder *decoder, + FLAC__uint64 *absolute_byte_offset, void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + + if (callbacks->tell_cb == Val_none) + return FLAC__STREAM_DECODER_TELL_STATUS_UNSUPPORTED; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + value ret = caml_callback(callbacks->tell_cb, Val_unit); + *absolute_byte_offset = (FLAC__uint64)Int64_val(ret); + caml_release_runtime_system(); + + return FLAC__STREAM_DECODER_TELL_STATUS_OK; +} + +static FLAC__StreamDecoderLengthStatus +dec_length_callback(const FLAC__StreamDecoder *decoder, + FLAC__uint64 *stream_length, void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + + if (callbacks->length_cb == Val_none) + return FLAC__STREAM_DECODER_LENGTH_STATUS_UNSUPPORTED; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + value ret = caml_callback(callbacks->length_cb, Val_unit); + *stream_length = (FLAC__uint64)Int64_val(ret); + caml_release_runtime_system(); + + return FLAC__STREAM_DECODER_LENGTH_STATUS_OK; +} + +static FLAC__bool dec_eof_callback(const FLAC__StreamDecoder *decoder, + void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + + if (callbacks->eof_cb == Val_none) + return false; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + value ret = caml_callback(callbacks->eof_cb, Val_unit); + caml_release_runtime_system(); + + if (ret == Val_true) + return true; + + return false; +} + +FLAC__StreamDecoderReadStatus static dec_read_callback( + const FLAC__StreamDecoder *decoder, FLAC__byte buffer[], size_t *bytes, + void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + + int readlen = *bytes; + if (callbacks->buflen < readlen) + readlen = callbacks->buflen; + + value ret = caml_callback3(callbacks->read_cb, callbacks->buffer, Val_int(0), + Val_int(readlen)); + + memcpy(buffer, String_val(callbacks->buffer), Int_val(ret)); + *bytes = Int_val(ret); + + caml_release_runtime_system(); + + if (*bytes == 0) + return FLAC__STREAM_DECODER_READ_STATUS_END_OF_STREAM; + else + return FLAC__STREAM_DECODER_READ_STATUS_CONTINUE; +} + +static inline double sample_to_double(FLAC__int32 x, unsigned bps) { + switch (bps) { + case 8: + return (((double)x) / INT8_MAX); + case 16: + return (((double)x) / INT16_MAX); + case 24: + return (((double)x) / INT24_MAX); + default: + return (((double)x) / INT32_MAX); + } +} + +FLAC__StreamDecoderWriteStatus +dec_write_callback(const FLAC__StreamDecoder *decoder, const FLAC__Frame *frame, + const FLAC__int32 *const buffer[], void *client_data) { + ocaml_flac_decoder_callbacks *callbacks = + (ocaml_flac_decoder_callbacks *)client_data; + int samples = frame->header.blocksize; + int channels = frame->header.channels; + int bps = frame->header.bits_per_sample; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + + int c, i; + for (c = 0; c < channels; c++) { + Store_field(callbacks->output, c, + caml_alloc(samples * Double_wosize, Double_array_tag)); + for (i = 0; i < samples; i++) + Store_double_field(Field(callbacks->output, c), i, + sample_to_double(buffer[c][i], bps)); + } + + caml_callback(callbacks->write_cb, callbacks->output); + + caml_release_runtime_system(); + + return FLAC__STREAM_DECODER_WRITE_STATUS_CONTINUE; +} + +#define Some_or_none(v) (v == Val_none ? Val_none : Some_val(v)) + +CAMLprim value ocaml_flac_decoder_alloc_native(value seek, value tell, + value length, value eof, + value read, value write, + value u) { + CAMLparam5(seek, tell, length, eof, read); + CAMLxparam1(write); + CAMLlocal1(ans); + + // Initialize things + ocaml_flac_decoder *dec = malloc(sizeof(ocaml_flac_decoder)); + if (dec == NULL) + caml_raise_out_of_memory(); + + dec->decoder = FLAC__stream_decoder_new(); + + dec->callbacks.seek_cb = Some_or_none(seek); + caml_register_generational_global_root(&dec->callbacks.seek_cb); + + dec->callbacks.tell_cb = Some_or_none(tell); + caml_register_generational_global_root(&dec->callbacks.tell_cb); + + dec->callbacks.length_cb = Some_or_none(length); + caml_register_generational_global_root(&dec->callbacks.length_cb); + + dec->callbacks.eof_cb = Some_or_none(eof); + caml_register_generational_global_root(&dec->callbacks.eof_cb); + + dec->callbacks.write_cb = write; + caml_register_generational_global_root(&dec->callbacks.write_cb); + + dec->callbacks.read_cb = read; + caml_register_generational_global_root(&dec->callbacks.read_cb); + + dec->callbacks.buflen = 1024; + dec->callbacks.buffer = caml_alloc_string(dec->callbacks.buflen); + caml_register_generational_global_root(&dec->callbacks.buffer); + + dec->callbacks.output = Val_none; + caml_register_generational_global_root(&dec->callbacks.output); + + dec->callbacks.info = NULL; + dec->callbacks.meta = NULL; + + // Accept vorbis comments + FLAC__stream_decoder_set_metadata_respond(dec->decoder, + FLAC__METADATA_TYPE_VORBIS_COMMENT); + + // Fill custom value + ans = caml_alloc_custom(&decoder_ops, sizeof(ocaml_flac_decoder *), 1, 0); + Decoder_val(ans) = dec; + + CAMLreturn(ans); +} + +CAMLprim value ocaml_flac_decoder_alloc_bytecode(value *argv, int argn) { + return ocaml_flac_decoder_alloc_native(argv[0], argv[1], argv[2], argv[3], + argv[4], argv[5], argv[6]); +} + +CAMLprim value ocaml_flac_decoder_init(value _dec) { + CAMLparam1(_dec); + + ocaml_flac_decoder *dec = Decoder_val(_dec); + + // Intialize decoder + caml_release_runtime_system(); + FLAC__stream_decoder_init_stream( + dec->decoder, dec_read_callback, dec_seek_callback, dec_tell_callback, + dec_length_callback, dec_eof_callback, dec_write_callback, + dec_metadata_callback, dec_error_callback, (void *)&dec->callbacks); + FLAC__stream_decoder_process_until_end_of_metadata(dec->decoder); + caml_acquire_runtime_system(); + + caml_modify_generational_global_root( + &dec->callbacks.output, caml_alloc_tuple(dec->callbacks.info->channels)); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_flac_decoder_state(value d) { + CAMLparam1(d); + + ocaml_flac_decoder *dec = Decoder_val(d); + + int ret = FLAC__stream_decoder_get_state(dec->decoder); + + CAMLreturn(val_of_state(ret)); +} + +CAMLprim value ocaml_flac_decoder_info(value d) { + CAMLparam1(d); + CAMLlocal4(ret, m, i, tmp); + ocaml_flac_decoder *dec = Decoder_val(d); + FLAC__StreamMetadata_StreamInfo *info = dec->callbacks.info; + if (info == NULL) + caml_raise_constant(*caml_named_value("flac_exn_internal")); + + // Info block + i = caml_alloc_tuple(5); + Store_field(i, 0, Val_int(info->sample_rate)); + Store_field(i, 1, Val_int(info->channels)); + Store_field(i, 2, Val_int(info->bits_per_sample)); + Store_field(i, 3, caml_copy_int64(info->total_samples)); + tmp = caml_alloc_string(16); + memcpy(Bytes_val(tmp), info->md5sum, 16); + Store_field(i, 4, tmp); + + // Comments block + if (dec->callbacks.meta != NULL) { + m = caml_alloc_tuple(2); + FLAC__StreamMetadata_VorbisComment coms = + dec->callbacks.meta->data.vorbis_comment; + // First comment is vendor string + if (coms.vendor_string.entry != NULL) + Store_field(m, 0, caml_copy_string((char *)coms.vendor_string.entry)); + else + Store_field(m, 0, caml_copy_string("")); + // Now the other metadata + tmp = caml_alloc_tuple(coms.num_comments); + int i; + for (i = 0; i < coms.num_comments; i++) + Store_field(tmp, i, caml_copy_string((char *)coms.comments[i].entry)); + Store_field(m, 1, tmp); + m = flac_Val_some(m); + } else + m = Val_none; + + ret = caml_alloc_tuple(2); + Store_field(ret, 0, i); + Store_field(ret, 1, m); + + CAMLreturn(ret); +} + +CAMLprim value ocaml_flac_decoder_process(value d) { + CAMLparam1(d); + + ocaml_flac_decoder *dec = Decoder_val(d); + + // Process one frame + caml_release_runtime_system(); + FLAC__stream_decoder_process_single(dec->decoder); + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_flac_decoder_seek(value d, value pos) { + CAMLparam2(d, pos); + + FLAC__uint64 offset = Int64_val(pos); + FLAC_API FLAC__bool ret; + + ocaml_flac_decoder *dec = Decoder_val(d); + + caml_release_runtime_system(); + ret = FLAC__stream_decoder_seek_absolute(dec->decoder, offset); + caml_acquire_runtime_system(); + + if (ret == true) + CAMLreturn(Val_true); + else + CAMLreturn(Val_false); +} + +CAMLprim value ocaml_flac_decoder_reset(value d) { + CAMLparam1(d); + + FLAC_API FLAC__bool ret; + + ocaml_flac_decoder *dec = Decoder_val(d); + + caml_release_runtime_system(); + ret = FLAC__stream_decoder_reset(dec->decoder); + caml_acquire_runtime_system(); + + if (ret == true) + CAMLreturn(Val_true); + else + CAMLreturn(Val_false); +} + +CAMLprim value ocaml_flac_decoder_flush(value d) { + CAMLparam1(d); + + FLAC_API FLAC__bool ret; + + ocaml_flac_decoder *dec = Decoder_val(d); + + caml_release_runtime_system(); + ret = FLAC__stream_decoder_flush(dec->decoder); + caml_acquire_runtime_system(); + + if (ret == true) + CAMLreturn(Val_true); + else + CAMLreturn(Val_false); +} + +/* Encoder */ + +CAMLprim value ocaml_flac_cleanup_encoder(value e) { + ocaml_flac_encoder *enc = Encoder_val(e); + + caml_remove_generational_global_root(&enc->callbacks.write_cb); + caml_remove_generational_global_root(&enc->callbacks.seek_cb); + caml_remove_generational_global_root(&enc->callbacks.tell_cb); + caml_remove_generational_global_root(&enc->callbacks.buffer); + + return Val_unit; +} + +static void finalize_encoder(value e) { + ocaml_flac_encoder *enc = Encoder_val(e); + if (enc->encoder != NULL) + FLAC__stream_encoder_delete(enc->encoder); + if (enc->meta != NULL) + FLAC__metadata_object_delete(enc->meta); + if (enc->buf != NULL) + free(enc->buf); + if (enc->lines != NULL) + free(enc->lines); + + free(enc); +} + +static struct custom_operations encoder_ops = { + "ocaml_flac_encoder", finalize_encoder, custom_compare_default, + custom_hash_default, custom_serialize_default, custom_deserialize_default}; + +FLAC__StreamEncoderWriteStatus +enc_write_callback(const FLAC__StreamEncoder *encoder, + const FLAC__byte buffer[], size_t bytes, unsigned samples, + unsigned current_frame, void *client_data) + +{ + int pos, len; + ocaml_flac_encoder_callbacks *callbacks = + (ocaml_flac_encoder_callbacks *)client_data; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + + pos = 0; + while (pos < bytes) { + len = bytes - pos; + + if (callbacks->buflen < len) + len = callbacks->buflen; + + memcpy(Bytes_val(callbacks->buffer), buffer + pos, len); + caml_callback2(callbacks->write_cb, callbacks->buffer, Val_int(len)); + + pos += len; + } + + caml_release_runtime_system(); + + return FLAC__STREAM_ENCODER_WRITE_STATUS_OK; +} + +FLAC__StreamEncoderSeekStatus +enc_seek_callback(const FLAC__StreamEncoder *encoder, + FLAC__uint64 absolute_byte_offset, void *client_data) { + ocaml_flac_encoder_callbacks *callbacks = + (ocaml_flac_encoder_callbacks *)client_data; + + if (callbacks->seek_cb == Val_none) + return FLAC__STREAM_ENCODER_SEEK_STATUS_UNSUPPORTED; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + caml_callback(callbacks->seek_cb, caml_copy_int64(absolute_byte_offset)); + caml_release_runtime_system(); + + return FLAC__STREAM_ENCODER_SEEK_STATUS_OK; +} + +static FLAC__StreamEncoderTellStatus +enc_tell_callback(const FLAC__StreamEncoder *decoder, + FLAC__uint64 *absolute_byte_offset, void *client_data) { + ocaml_flac_encoder_callbacks *callbacks = + (ocaml_flac_encoder_callbacks *)client_data; + + if (callbacks->tell_cb == Val_none) + return FLAC__STREAM_ENCODER_TELL_STATUS_UNSUPPORTED; + + ocaml_flac_register_thread(); + caml_acquire_runtime_system(); + *absolute_byte_offset = + (FLAC__uint64)Int64_val(caml_callback(callbacks->tell_cb, Val_unit)); + caml_release_runtime_system(); + + return FLAC__STREAM_ENCODER_TELL_STATUS_OK; +} + +CAMLprim value +ocaml_flac_encoder_vorbiscomment_entry_name_is_legal(value name) { + CAMLparam1(name); + CAMLreturn(Val_bool( + FLAC__format_vorbiscomment_entry_name_is_legal(String_val(name)))); +} + +CAMLprim value +ocaml_flac_encoder_vorbiscomment_entry_value_is_legal(value _value) { + CAMLparam1(_value); + CAMLreturn(Val_bool(FLAC__format_vorbiscomment_entry_value_is_legal( + (const FLAC__byte *)String_val(_value), caml_string_length(_value)))); +} + +CAMLprim value ocaml_flac_encoder_alloc(value comments, value seek, value tell, + value write, value params) { + CAMLparam5(comments, seek, tell, write, params); + CAMLlocal1(ret); + + FLAC__StreamEncoder *enc = FLAC__stream_encoder_new(); + if (enc == NULL) + caml_raise_out_of_memory(); + + FLAC__stream_encoder_set_channels(enc, Int_val(Field(params, 0))); + FLAC__stream_encoder_set_bits_per_sample(enc, Int_val(Field(params, 1))); + FLAC__stream_encoder_set_sample_rate(enc, Int_val(Field(params, 2))); + if (Field(params, 3) != Val_none) + FLAC__stream_encoder_set_compression_level( + enc, Int_val(Some_val(Field(params, 3)))); + + if (Field(params, 4) != Val_none) + FLAC__stream_encoder_set_total_samples_estimate( + enc, Int64_val(Some_val(Field(params, 4)))); + + ocaml_flac_encoder *caml_enc = malloc(sizeof(ocaml_flac_encoder)); + if (caml_enc == NULL) { + FLAC__stream_encoder_delete(enc); + caml_raise_out_of_memory(); + } + + caml_enc->encoder = enc; + + caml_enc->callbacks.seek_cb = Some_or_none(seek); + caml_register_generational_global_root(&caml_enc->callbacks.seek_cb); + + caml_enc->callbacks.tell_cb = Some_or_none(tell); + caml_register_generational_global_root(&caml_enc->callbacks.tell_cb); + + caml_enc->callbacks.write_cb = write; + caml_register_generational_global_root(&caml_enc->callbacks.write_cb); + + caml_enc->callbacks.buflen = 1024; + caml_enc->callbacks.buffer = caml_alloc_string(caml_enc->callbacks.buflen); + caml_register_generational_global_root(&caml_enc->callbacks.buffer); + + caml_enc->buf = NULL; + caml_enc->lines = NULL; + + // Fill custom value + ret = caml_alloc_custom(&encoder_ops, sizeof(ocaml_flac_encoder *), 1, 0); + Encoder_val(ret) = caml_enc; + + /* Metadata */ + caml_enc->meta = + FLAC__metadata_object_new(FLAC__METADATA_TYPE_VORBIS_COMMENT); + + if (caml_enc->meta == NULL) { + FLAC__stream_encoder_delete(enc); + caml_raise_out_of_memory(); + } + FLAC__StreamMetadata_VorbisComment_Entry entry; + + /* Vendor string is ignored by libFLAC.. */ + int i; + for (i = 0; i < Wosize_val(comments); i++) { + if (!FLAC__metadata_object_vorbiscomment_entry_from_name_value_pair( + &entry, String_val(Field(Field(comments, i), 0)), + String_val(Field(Field(comments, i), 1)))) + caml_raise_constant(*caml_named_value("flac_enc_exn_invalid_metadata")); + + FLAC__metadata_object_vorbiscomment_append_comment(caml_enc->meta, entry, + true); + } + FLAC__stream_encoder_set_metadata(enc, &caml_enc->meta, 1); + + CAMLreturn(ret); +} + +CAMLprim value ocaml_flac_encoder_init(value _enc) { + CAMLparam1(_enc); + + ocaml_flac_encoder *enc = Encoder_val(_enc); + + caml_release_runtime_system(); + FLAC__stream_encoder_init_stream(enc->encoder, enc_write_callback, + enc_seek_callback, enc_tell_callback, NULL, + (void *)&enc->callbacks); + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} + +static inline FLAC__int32 sample_from_double(double x, unsigned bps) { + if (x < -1) { + x = -1; + } else if (x > 1) { + x = 1; + } + + switch (bps) { + case 8: + return x * INT8_MAX; + case 16: + return x * INT16_MAX; + case 24: + return x * INT24_MAX; + default: + return x * INT32_MAX; + } +} + +CAMLprim value ocaml_flac_encoder_process(value _enc, value data, value bps) { + CAMLparam2(_enc, data); + + ocaml_flac_encoder *enc = Encoder_val(_enc); + + int chans = Wosize_val(data); + int samples = Wosize_val(Field(data, 0)) / Double_wosize; + int i; + int c; + + if (enc->buf != NULL) + free(enc->buf); + if (enc->lines != NULL) + free(enc->lines); + + enc->buf = malloc(chans * sizeof(FLAC__int32 *)); + if (enc->buf == NULL) + caml_raise_out_of_memory(); + enc->lines = malloc(chans * samples * sizeof(FLAC__int32)); + enc->buf[0] = enc->lines; + if (enc->lines == NULL) + caml_raise_out_of_memory(); + for (c = 0; c < chans; c++) { + if (c > 0) + enc->buf[c] = enc->buf[c - 1] + samples; + for (i = 0; i < samples; i++) + enc->buf[c][i] = + sample_from_double(Double_field(Field(data, c), i), Int_val(bps)); + } + + caml_release_runtime_system(); + FLAC__stream_encoder_process(enc->encoder, + (const FLAC__int32 *const *)enc->buf, samples); + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_flac_encoder_finish(value _enc) { + CAMLparam1(_enc); + + ocaml_flac_encoder *enc = Encoder_val(_enc); + + caml_release_runtime_system(); + FLAC__stream_encoder_finish(enc->encoder); + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} diff --git a/flac/flac_stubs.h b/flac/flac_stubs.h new file mode 100644 index 0000000..e3aeb0d --- /dev/null +++ b/flac/flac_stubs.h @@ -0,0 +1,100 @@ +/* This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * 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 General Public License for more details. + * + * You should have received a copy of the GNU 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. + * + * Chunks of this code have been borrowed and influenced + * by flac/decode.c and the flac XMMS plugin. + * + */ + +#include + +#include +#include +#include +#include + +#include + +#define Val_none Val_int(0) +#define Some_val(v) Field(v, 0) +value flac_Val_some(value v); + +/* Decoder */ + +typedef struct ocaml_flac_decoder_callbacks { + /* This is used for callback from caml. */ + value read_cb; + value seek_cb; + value tell_cb; + value length_cb; + value eof_cb; + value write_cb; + value output; + value buffer; + int buflen; + FLAC__StreamMetadata_StreamInfo *info; + FLAC__StreamMetadata *meta; +} ocaml_flac_decoder_callbacks; + +typedef struct ocaml_flac_decoder { + FLAC__StreamDecoder *decoder; + ocaml_flac_decoder_callbacks callbacks; +} ocaml_flac_decoder; + +/* Caml abstract value containing the decoder. */ +#define Decoder_val(v) (*((ocaml_flac_decoder **)Data_custom_val(v))) + +void dec_metadata_callback(const FLAC__StreamDecoder *decoder, + const FLAC__StreamMetadata *metadata, + void *client_data); + +FLAC__StreamDecoderWriteStatus +dec_write_callback(const FLAC__StreamDecoder *decoder, const FLAC__Frame *frame, + const FLAC__int32 *const buffer[], void *client_data); + +void dec_error_callback(const FLAC__StreamDecoder *decoder, + FLAC__StreamDecoderErrorStatus status, + void *client_data); + +/* Encoder */ + +typedef struct ocaml_flac_encoder_callbacks { + value write_cb; + value seek_cb; + value tell_cb; + value buffer; + int buflen; +} ocaml_flac_encoder_callbacks; + +typedef struct ocaml_flac_encoder { + FLAC__StreamEncoder *encoder; + FLAC__StreamMetadata *meta; + FLAC__int32 **buf; + FLAC__int32 *lines; + ocaml_flac_encoder_callbacks callbacks; +} ocaml_flac_encoder; + +/* Caml abstract value containing the decoder. */ +#define Encoder_val(v) (*((ocaml_flac_encoder **)Data_custom_val(v))) + +value ocaml_flac_encoder_alloc(value comments, value seek, value tell, + value write, value params); + +FLAC__StreamEncoderWriteStatus +enc_write_callback(const FLAC__StreamEncoder *encoder, + const FLAC__byte buffer[], size_t bytes, unsigned samples, + unsigned current_frame, void *client_data); + +/* Threads management */ +void ocaml_flac_register_thread(); diff --git a/ogg.opam b/ogg.opam new file mode 100644 index 0000000..9bfdaf0 --- /dev/null +++ b/ogg.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "Bindings to libogg" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/savonet/ocaml-xiph" +bug-reports: "https://github.com/savonet/ocaml-xiph/issues" +depends: [ + "conf-libogg" + "conf-pkg-config" + "ocaml" {>= "4.08.0"} + "dune" {>= "2.8"} + "dune-configurator" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/savonet/ocaml-xiph.git" diff --git a/ogg/config/discover.ml b/ogg/config/discover.ml new file mode 100644 index 0000000..df4fc96 --- /dev/null +++ b/ogg/config/discover.ml @@ -0,0 +1,19 @@ +module C = Configurator.V1 + +let () = + C.main ~name:"ogg-pkg-config" (fun c -> + let default : C.Pkg_config.package_conf = + { libs = ["-logg"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match + C.Pkg_config.query_expr_err pc ~package:"ogg" ~expr:"ogg" + with + | Error msg -> failwith msg + | Ok deps -> deps) + in + C.Flags.write_sexp "c_flags.sexp" conf.cflags; + C.Flags.write_sexp "c_library_flags.sexp" conf.libs) diff --git a/ogg/config/dune b/ogg/config/dune new file mode 100644 index 0000000..21a5f9a --- /dev/null +++ b/ogg/config/dune @@ -0,0 +1,3 @@ +(executable + (name discover) + (libraries dune.configurator)) diff --git a/ogg/dune b/ogg/dune new file mode 100644 index 0000000..e899bd1 --- /dev/null +++ b/ogg/dune @@ -0,0 +1,26 @@ +(library + (name ogg) + (public_name ogg) + (synopsis "OCaml bindings for libogg") + (libraries threads) + (modules ogg) + (install_c_headers ocaml-ogg) + (foreign_stubs + (language c) + (names ogg_stubs) + (flags + (:include c_flags.sexp))) + (c_library_flags + (:include c_library_flags.sexp))) + +(library + (name ogg_decoder) + (public_name ogg.decoder) + (synopsis "Ogg decoding library with pluggable decoders") + (libraries ogg) + (modules ogg_decoder)) + +(rule + (targets c_flags.sexp c_library_flags.sexp) + (action + (run ./config/discover.exe))) diff --git a/ogg/ocaml-ogg.h b/ogg/ocaml-ogg.h new file mode 100644 index 0000000..d132775 --- /dev/null +++ b/ogg/ocaml-ogg.h @@ -0,0 +1,43 @@ +/* + * Copyright 2007 Samuel Mimram + * + * This file is part of ocaml-ogg. + * + * ocaml-ogg is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-ogg 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 General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with ocaml-ogg; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + * As a special exception to the GNU Library General Public License, you may + * link, statically or dynamically, a "work that uses the Library" with a + * publicly distributed version of the Library to produce an executable file + * containing portions of the Library, and distribute that executable file under + * terms of your choice, without any of the additional requirements listed in + * clause 6 of the GNU Library General Public License. By "a publicly + * distributed version of the Library", we mean either the unmodified Library as + * distributed by The Savonet Team, or a modified version of the Library that is + * distributed under the conditions defined in clause 3 of the GNU Library + * General Public License. This exception does not however invalidate any other + * reasons why the executable file might be covered by the GNU Library General + * Public License. + * + */ + +#include + +#define Sync_state_val(v) (*((ogg_sync_state **)Data_custom_val(v))) +#define Stream_state_val(v) (*((ogg_stream_state **)Data_custom_val(v))) +#define Packet_val(v) (*((ogg_packet **)Data_custom_val(v))) + +value value_of_page(ogg_page *op); +value value_of_packet(ogg_packet *op); +ogg_page *page_of_value(value v, ogg_page *op); diff --git a/ogg/ogg.ml b/ogg/ogg.ml new file mode 100644 index 0000000..35b3faa --- /dev/null +++ b/ogg/ogg.ml @@ -0,0 +1,159 @@ +(* + * Copyright 2007-2011 Savonet team + * + * This file is part of ocaml-ogg. + * + * ocaml-ogg is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-ogg 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 General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with ocaml-ogg; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + * As a special exception to the GNU Library General Public License, you may + * link, statically or dynamically, a "work that uses the Library" with a publicly + * distributed version of the Library to produce an executable file containing + * portions of the Library, and distribute that executable file under terms of + * your choice, without any of the additional requirements listed in clause 6 + * of the GNU Library General Public License. + * By "a publicly distributed version of the Library", we mean either the unmodified + * Library as distributed by The Savonet Team, or a modified version of the Library that is + * distributed under the conditions defined in clause 3 of the GNU Library General + * Public License. This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU Library General Public License. + * + *) + +(* + * Functions for manipulating ogg streams files using libogg. + * + * @author Samuel Mimram + *) + +exception Not_enough_data +exception Bad_data +exception Out_of_sync +exception End_of_stream +exception Internal_error + +let () = + Callback.register_exception "ogg_exn_not_enough_data" Not_enough_data; + Callback.register_exception "ogg_exn_bad_data" Bad_data; + Callback.register_exception "ogg_exn_out_of_sync" Out_of_sync; + Callback.register_exception "ogg_exn_eos" End_of_stream; + Callback.register_exception "ogg_exn_internal_error" Internal_error + +module Page = struct + type t = string * string + + external serialno : t -> nativeint = "ocaml_ogg_page_serialno" + external eos : t -> bool = "ocaml_ogg_page_eos" + external bos : t -> bool = "ocaml_ogg_page_bos" + external packets : t -> int = "ocaml_ogg_page_packets" + external continued : t -> bool = "ocaml_ogg_page_continued" + external version : t -> int = "ocaml_ogg_page_version" + external granulepos : t -> Int64.t = "ocaml_ogg_page_granulepos" + external pageno : t -> nativeint = "ocaml_ogg_page_pageno" + external set_checksum : t -> unit = "ocaml_ogg_page_checksum_set" +end + +module Stream = struct + type stream + type packet + + external packet_granulepos : packet -> Int64.t + = "ocaml_ogg_stream_packet_granulepos" + + external create : nativeint -> stream = "ocaml_ogg_stream_init" + + let create ?(serial = Random.nativeint (Nativeint.of_int 0x3FFFFFFF)) () = + create serial + + external serialno : stream -> nativeint = "ocaml_ogg_stream_serialno" + external eos : stream -> bool = "ocaml_ogg_stream_eos" + external terminate : stream -> Page.t = "ocaml_ogg_stream_terminate" + external get_page : stream -> unit -> Page.t = "ocaml_ogg_stream_pageout" + external get_page_fill : stream -> int -> Page.t = "ocaml_ogg_stream_pageout" + + let get_page ?fill os = + match fill with + | Some bytes -> get_page_fill os bytes + | None -> get_page os () + + external get_packet : stream -> packet = "ocaml_ogg_stream_packetout" + external peek_packet : stream -> packet = "ocaml_ogg_stream_packetpeek" + + external peek_granulepos : stream -> Int64.t + = "ocaml_ogg_stream_granulepospeek" + + external skip_packet : stream -> unit = "ocaml_ogg_stream_packet_advance" + external put_packet : stream -> packet -> unit = "ocaml_ogg_stream_packetin" + external put_page : stream -> Page.t -> unit = "ocaml_ogg_stream_pagein" + external flush_page : stream -> Page.t = "ocaml_ogg_flush_stream" + + let terminate os = + let rec f pages = + try f (flush_page os :: pages) with Not_enough_data -> pages + in + let pages = f [] in + List.rev (terminate os :: pages) +end + +module Sync = struct + (** Internal type for sync state *) + type sync + + type read = bytes -> int -> int -> int + + (** External type for sync state. References the C sync structure, and the read function *) + type t = (read * sync) ref + + external create : unit -> sync = "ocaml_ogg_sync_init" + + let create f = ref (f, create ()) + + let create_from_file f = + let fd = Unix.openfile f [Unix.O_RDONLY] 0o400 in + (create (Unix.read fd), fd) + + external read : read -> sync -> Page.t = "ocaml_ogg_sync_read" + + let read s = + let f, s = !s in + read f s + + external reset : sync -> unit = "ocaml_ogg_sync_reset" + + let reset ?read_func x = + let f, s = !x in + reset s; + match read_func with None -> x := (f, s) | Some v -> x := (v, s) + + external seek : read -> sync -> Page.t = "ocaml_ogg_sync_pageseek" + + let seek x = + let f, s = !x in + seek f s +end + +module Skeleton = struct + external fishead : + Int64.t -> Int64.t -> Int64.t -> Int64.t -> Int32.t -> Stream.packet + = "ocaml_ogg_skeleton_fishead" + + let fishead ?(presentation_numerator = Int64.zero) + ?(presentation_denominator = Int64.of_int 1000) + ?(basetime_numerator = Int64.zero) + ?(basetime_denominator = Int64.of_int 1000) ?(utc = Int32.zero) () = + fishead presentation_numerator presentation_denominator basetime_numerator + basetime_denominator utc + + external eos : unit -> Stream.packet = "ocaml_ogg_skeleton_eos" +end diff --git a/ogg/ogg.mli b/ogg/ogg.mli new file mode 100644 index 0000000..6c81d56 --- /dev/null +++ b/ogg/ogg.mli @@ -0,0 +1,309 @@ +(* + * Copyright 2007-2011 Savonet team + * + * This file is part of ocaml-ogg. + * + * ocaml-ogg is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-ogg 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 General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with ocaml-ogg; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + * As a special exception to the GNU Library General Public License, you may + * link, statically or dynamically, a "work that uses the Library" with a publicly + * distributed version of the Library to produce an executable file containing + * portions of the Library, and distribute that executable file under terms of + * your choice, without any of the additional requirements listed in clause 6 + * of the GNU Library General Public License. + * By "a publicly distributed version of the Library", we mean either the unmodified + * Library as distributed by The Savonet Team, or a modified version of the Library that is + * distributed under the conditions defined in clause 3 of the GNU Library General + * Public License. This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU Library General Public License. + * + *) + +(** + * Functions for manipulating ogg streams files using libogg. + * + * @author Samuel Mimram, Romain Beauxis + *) + +exception Not_enough_data +exception Bad_data +exception Out_of_sync +exception End_of_stream +exception Internal_error + +(** + * The [page] struct encapsulates the data for an Ogg page. + * + * Ogg pages are the fundamental unit of framing and interleave in an ogg + * bitstream. They are made up of packet segments of 255 bytes each. There can + * be as many as 255 packet segments per page, for a maximum page size of a + * little under 64 kB. This is not a practical limitation as the segments can be + * joined across page boundaries allowing packets of arbitrary size. In practice + * pages are usually around 4 kB. + *) +module Page : sig + (** A page is a header and a body *) + type t = string * string + + (** + * Returns the unique serial number for the logical bitstream of this page. + * Each page contains the serial number for the logical bitstream that it belongs to.*) + val serialno : t -> nativeint + + (** + * Indicates whether this page is at the end of the logical bitstream. *) + val eos : t -> bool + + (** + * Indicates whether this page is at the begining of the logical bitstream. *) + val bos : t -> bool + + (** + * Indicates whether this page contains packet data which has been + * continued from the previous page. *) + val continued : t -> bool + + (** + * Returns the number of packets that are completed on this page. + * If the leading packet is begun on a previous page, but ends on this page, it's counted. + * + * If a page consists of a packet begun on a previous page, and a new packet begun + * (but not completed) on this page, the return will be: + * + * [packets page] will return [1], + * [continued paged] will return [true] + * + * If a page happens to be a single packet that was begun on a previous page, + * and spans to the next page (in the case of a three or more page packet), the return will be: + * + * [packets page] will return 0, + * [continued page] will return [true].*) + val packets : t -> int + + (** + * This function returns the version of ogg_page used in this page. + * In current versions of libogg, all ogg_page structs have the same version, + * so [0] should always be returned. *) + val version : t -> int + + (** + * Returns the exact granular position of the packet data contained at the end of this page. + * + * This is useful for tracking location when seeking or decoding. + * + * For example, in audio codecs this position is the pcm sample number and + * in video this is the frame number.*) + val granulepos : t -> Int64.t + + (** + * Returns the sequential page number. + * + * This is useful for ordering pages or determining when pages have been lost. *) + val pageno : t -> nativeint + + (** + * Checksums an ogg_page. *) + val set_checksum : t -> unit +end + +module Sync : sig + type t + + (** Type for read functions. *) + type read = bytes -> int -> int -> int + + (** + * This function is used to initialize a [Sync.t] to a known initial value + * in preparation for manipulation of an Ogg bitstream. + * + * The function passed is used to fill the stream with new data. *) + val create : read -> t + + (** + * Wrapper around [create] to open a file as the ogg stream. *) + val create_from_file : string -> t * Unix.file_descr + + (** + * Read a page from [Sync.t] + * + * Raises [End_of_stream] if the reading function returned an empty string. + * Raises [Out_of_sync] if data is not synced and some byte where skiped. *) + val read : t -> Page.t + + (** + * This function is used to reset the internal counters of the + * [Sync.t] to initial values. + * + * [read_func] is optional and is a new function to read new data. *) + val reset : ?read_func:read -> t -> unit + + (** + * This function synchronizes the ogg_sync_state struct to the next ogg_page. + * + * This is useful when seeking within a bitstream. page_seek will synchronize + * to the next page in the bitstream and return information about how many bytes + * we advanced or skipped in order to do so. *) + val seek : t -> Page.t +end + +module Stream : sig + (** + * The [stream] values track the current encode/decode state of the + * current logical bitstream. + *) + type stream + + (** + * A data packet to pass to the decoder *) + type packet + + (** + * Create a [stream]. + *) + val create : ?serial:nativeint -> unit -> stream + + (** + * Get a stream's serial number. + *) + val serialno : stream -> nativeint + + (** Returns true if the end of stream has been reached. *) + val eos : stream -> bool + + (** Terminate the stream and return its final pages. *) + val terminate : stream -> Page.t list + + (** + * This function forms packets into pages. Internally, + * it assembles the accumulated packet bodies into an Ogg page + * suitable for writing to a stream. + * + * If no [fill] argument is passed, this function will only return + * a page when a "reasonable" amount of packet data is available. + * Normally this is appropriate since it limits the overhead of the + * Ogg page headers in the bitstream. + * + * If a [fill] argument is passed, this function will return a page when at + * least four packets have been accumulated and accumulated packet data meets + * or exceeds the specified number of bytes, and/or when the accumulated + * packet data meets/exceeds the maximum page size regardless of accumulated + * packet count. + * + * The exception [Not_enough_data] is raised if not enough data is available + * to generate the page. + * + * Call [flush_page] if immediate page generation is desired. This + * may be occasionally necessary, for example, to limit the temporal + * latency of a variable bitrate stream. + *) + val get_page : ?fill:int -> stream -> Page.t + + (** + * This function adds a complete page to the bitstream. + * + * In a typical decoding situation, this function would be called after + * using [Sync.read] to create a valid [Page.t] + * + * Raises [Bad_data] if the serial number of the page did not match the + * serial number of the bitstream, or the page version was incorrect. *) + val put_page : stream -> Page.t -> unit + + (** + * This function assembles a data packet for output + * to the codec decoding engine. + * + * Each successive call returns the next complete packet built from those segments. + * In a typical decoding situation, this should be used after calling + * [put_page] to submit a page of data to the bitstream. + * + * This function should *not* be used. Because of ocaml's paradigm, it is necessary + * to copy each packet since they are only valid until this function is called again. + * When dealing with many packets, this will lead to multiple unecessary memory allocation + * and desallocation. + * + * Raises [Not_enough_data] if more data is needed and another page should be submitted. + * + * Raises [Out_of_sync] if we are out of sync and there is a gap in the data. *) + val get_packet : stream -> packet + + (** + * This function assembles a data packet for output + * to the codec decoding engine without advancing the stream. + * + * Raises [Not_enough_data] if more data is needed and another page should be submitted. + * + * Raises [Out_of_sync] if we are out of sync and there is a gap in the data *) + val peek_packet : stream -> packet + + (** This function picks up the granule position + * of the next packet in the stream without advancing it. + * + * Raises [Not_enough_data] if more data is needed and another page should be submitted. + * + * Raises [Out_of_sync] if we are out of sync and there is a gap in the data *) + val peek_granulepos : stream -> Int64.t + + (** This function discards the next packet in the stream. + * + * Raises [Not_enough_data] if more data is needed and another page should be submitted. + * + * Raises [Out_of_sync] if we are out of sync and there is a gap in the data *) + val skip_packet : stream -> unit + + (** + * This function submits a packet to the bitstream for page encapsulation. + * After this is called, more packets can be submitted, or pages can be written out. + * + * This function is provided to ease ogg strea multiplexing, where packet submission + * order is important. It should not be used to encoder further data. *) + val put_packet : stream -> packet -> unit + + (** + * This function checks for remaining packets inside the stream and forces + * remaining packets into a page, regardless of the size of the page. + * + * This should only be used when you want to flush an undersized page from the + * middle of the stream. Otherwise, [get_page] should always be used. + * + * This function can be used to verify that all packets have been flushed. + * + * Raises [Not_enough_data] if all packet data has already been flushed into pages, + * and there are no packets to put into the page. + *) + val flush_page : stream -> Page.t + + (** Returns a packet's granule position. *) + val packet_granulepos : packet -> Int64.t +end + +module Skeleton : sig + (** + * Create an initial ogg skeleton packet ('fishead'), + * to complete with data packet from the various codecs + * in the stream ('fishbone'). + * See: http://xiph.org/ogg/doc/skeleton.html. *) + val fishead : + ?presentation_numerator:Int64.t -> + ?presentation_denominator:Int64.t -> + ?basetime_numerator:Int64.t -> + ?basetime_denominator:Int64.t -> + ?utc:Int32.t -> + unit -> + Stream.packet + + (** Create an end-of-stream packet for + * an ogg skeleton logical stream *) + val eos : unit -> Stream.packet +end diff --git a/ogg/ogg_decoder.ml b/ogg/ogg_decoder.ml new file mode 100644 index 0000000..56689f1 --- /dev/null +++ b/ogg/ogg_decoder.ml @@ -0,0 +1,734 @@ +(* + * Copyright 2007-2011 Savonet team + * + * This file is part of ocaml-ogg. + * + * ocaml-ogg is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-ogg 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 General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with ocaml-ogg; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + * As a special exception to the GNU Library General Public License, you may + * link, statically or dynamically, a "work that uses the Library" with + * a publicly distributed version of the Library to produce an executable file + * containing portions of the Library, and distribute that executable file + * under terms of your choice, without any of the additional requirements + * listed in clause 6 of the GNU Library General Public License. + * By "a publicly distributed version of the Library", we mean either + * the unmodified Library as distributed by INRIA, or a modified version of + * the Library that is distributed under the conditions defined in clause 3 + * of the GNU Library General Public License. This exception does not however + * invalidate any other reasons why the executable file might be covered by + * the GNU Library General Public License. + * + *) + +(** 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 + (* Planar YCbCr 4:2:0. Each component is an uint8_t, + * luma and chroma values are full range (0x00 .. 0xff) *) + | Yuvj_422 + (* Planar YCbCr 4:2:2. Each component is an uint8_t, + * luma and chroma values are full range (0x00 .. 0xff) *) + | Yuvj_444 + +(* Planar YCbCr 4:4:4. Each component is an uint8_t, + * luma and chroma values are full range (0x00 .. 0xff) *) + +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 + +(* This exception has a different semantics than [Ogg.End_of_stream]. + * [Ogg.End_of_stream] is raised when end of data has been reached, + * while this exception is raised when end of a logical stream has + * been reached.. *) +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 + +(* End of stream is declared only when + * all logical stream have ended (dec.streams = 0) + * _and_ all their data has been consumed (dec.finished_streams = 0) *) +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 + (* Moving finished stream to decoder.finished_streams *) + 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; + (* Get first packet *) + 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 + (* Get First page *) + let position, page = get_page dec in + (* Check wether this is a b_o_s *) + if not (Ogg.Page.bos page) then raise (Internal (page, position)); + let serial, os, decoder = test dec page in + (* Should not happen *) + 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 + (* First check active streams *) + Hashtbl.iter (test false) dec.streams; + (* Now check finished 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 = + (* Remove all track of this type *) + 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; +} + +(* Function to seek at a given point. *) +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 + (* Resolve each sync_point. *) + List.iter (find_seek_pos dec time) sync_points; + (* Move all finished streams back to + * streams. *) + let f x y = Hashtbl.add dec.streams x y in + Hashtbl.iter f dec.finished_streams; + Hashtbl.clear dec.finished_streams; + (* Now finally resync. *) + 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 + (* First, reinitiate all ogg streams. *) + 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; + (* Get to the next sync point for + * each streams. *) + 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 + (* In very rare cases (e.g. with a track that + * does not have any data to decode), [Ogg.Not_enough_data] + * may be raised at the end of the track instead of + * [End_of_stream]. Thus, we also catch it here + * but re-raise it if the track has not ended yet. *) + | 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 + (* Reraise [Ogg.Not_enough_data] to feed the + * decoder. *) + 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 + (* Reraise [Ogg.Not_enough_data] to feed the + * decoder. *) + 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 diff --git a/ogg/ogg_decoder.mli b/ogg/ogg_decoder.mli new file mode 100644 index 0000000..718fb7d --- /dev/null +++ b/ogg/ogg_decoder.mli @@ -0,0 +1,291 @@ +(***************************************************************************** + + Liquidsoap, a programmable audio stream generator. + Copyright 2003-2011 Savonet team + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + 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 General Public License for more details, fully stated in the COPYING + file at the root of the liquidsoap distribution. + + You should have received a copy of the GNU 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 + + *****************************************************************************) + +(** Ogg stream demuxer *) + +(** This module provides a functional abstract API to + * decode and seek in Ogg streams. + * + * Decoders are also provided in ocaml-vorbis, + * ocaml-speex, ocaml-schroedinger, ocaml-flac and + * ocaml-theora. + * + * Functions in this module are not thread safe! *) + +(** {2 Decoding} *) + +(** {3 Types} *) + +(** Type of an ogg stream decoder. *) +type t + +(** Type for callbacks used to acess encoded data. *) +type callbacks = { + read : bytes -> int -> int -> int; + seek : (int -> int) option; + tell : (unit -> int) option; +} + +(** Type for a decodable track. + * First element is a string describing + * the decoder used to decode the track. + * Second element is the serial number + * associated to the [Ogg.Stream.stream] logical + * stream used to pull data packets for that + * track. *) +type track = + | Audio_track of (string * nativeint) + | Video_track of (string * nativeint) + +(** Type for standard tracks (see [get_standard_tracks] below). *) +type standard_tracks = { + mutable audio_track : track option; + mutable video_track : track option; +} + +(** Type for metadata. First element + * is a string describing the vendor, second + * element is a list of metadata of the form: + * [(label,value)]. *) +type metadata = string * (string * string) list + +(** Type for audio information. *) +type audio_info = { channels : int; sample_rate : int } + +(** Type for audio data. *) +type audio_data = float array array + +type audio_ba_data = + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array + +(** Type of a video plane. *) +type video_plane = + (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +(** Supported video formats. *) +type video_format = + (* Planar YCbCr 4:2:0. Each component is an uint8_t, + * luma and chroma values are full range (0x00 .. 0xff) *) + | Yuvj_420 + (* Planar YCbCr 4:2:2. Each component is an uint8_t, + * luma and chroma values are full range (0x00 .. 0xff) *) + | Yuvj_422 + (* Planar YCbCr 4:4:4. Each component is an uint8_t, + * luma and chroma values are full range (0x00 .. 0xff) *) + | Yuvj_444 + +(* Type for video information. *) +type video_info = { + fps_numerator : int; + fps_denominator : int; + (* Width of the Y' luminance plane *) + width : int; + (* Height of the luminance plane *) + height : int; +} + +(** Type for video data. *) +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 *) +} + +(** {3 Exceptions } *) + +exception Invalid_stream +exception Not_available + +(* This exception has a different semantics than [Ogg.End_of_stream]. + * [Ogg.End_of_stream] is raised when end of data has been reached, + * while this exception is raised when end of a logical stream has + * been reached.. *) +exception End_of_stream + +(** {3 Initialization functions } *) + +(** Initiate a decoder with the given callbacks. + * [log] is an optional functioned used to + * return logged messages during the deocding + * process. *) +val init : ?log:(string -> unit) -> callbacks -> t + +(** Initiate a decoder from a given file name. *) +val init_from_file : ?log:(string -> unit) -> string -> t * Unix.file_descr + +(** Initate a decoder from a given [Unix.file_descriptor] *) +val init_from_fd : ?log:(string -> unit) -> Unix.file_descr -> t + +(** Get the Ogg.Sync handler associated to + * the decoder. Use only if know what you are doing. *) +val get_ogg_sync : t -> Ogg.Sync.t + +(** Reset encoder, try to parse a new sequentialized stream. + * To use when end_of_stream has been reached. *) +val reset : t -> unit + +(** Consume all remaining pages of the current + * stream. This function may be called to skip + * a sequentialized stream but it may be quite + * CPU intensive if there are many pages remaining.. + * + * [eos dec] is [true] after this call. *) +val abort : t -> unit + +(** [true] if the decoder has reached the end of each + * logical streams and all data has been decoded. + * + * If you do not plan on decoding some data, + * you should use [drop_track] to indicate it + * to the decoder. Otherwise, [eos] will return + * [false] until you have decoded all data. *) +val eos : t -> bool + +(** Get all decodable tracks available. *) +val get_tracks : t -> track list + +(** Get the first available audio and + * video tracks and drop the other one. *) +val get_standard_tracks : t -> standard_tracks + +(** Update a given record of standard tracks. You should + * use this after a [reset] to update the standard tracks + * with the newly created tracks. *) +val update_standard_tracks : t -> standard_tracks -> unit + +(** Remove all tracks of the given type. *) +val drop_track : t -> track -> unit + +(** {3 Information functions} *) + +(** Get informations about the + * audio track. *) +val audio_info : t -> track -> audio_info * metadata + +(** [true] if the decoder can decoder to bigarray data. *) +val can_decode_ba : t -> track -> bool + +(** Get informations about the + * video track. *) +val video_info : t -> track -> video_info * metadata + +(** Get the sample_rate of the track + * of that type. Returns a pair [(numerator,denominator)]. *) +val sample_rate : t -> track -> int * int + +(** Get track absolute position. *) +val get_track_position : t -> track -> float + +(** Get absolute position in the stream. *) +val get_position : t -> float + +(** {3 Seeking functions} *) + +(** Returns [true] if the decoder + * can be used with the [seek] function. *) +val can_seek : t -> bool + +(** Seek to an absolute or relative position in seconds. + * + * Raises [Not_available] if seeking is + * not possible. + * + * Raises [End_of_stream] if the end of + * current stream has been reached while + * seeking. You may call [reset] in this + * situation to see if there is a new seqentialized + * stream available. + * + * Returns the time actually reached, either in + * relative time or absolute time. *) +val seek : ?relative:bool -> t -> float -> float + +(** {3 Decoding functions} *) + +(** Decode audio data, if possible. + * Decoded data is passed to the second argument. + * + * Raises [End_of_stream] if all stream have ended. + * In this case, you can try [reset] to see if there is a + * new sequentialized stream. *) +val decode_audio : t -> track -> (audio_data -> unit) -> unit + +(** Decode audio data, if possible. + * Decoded data is passed to the second argument. + * + * Raises [End_of_stream] if all stream have ended. + * In this case, you can try [reset] to see if there is a + * new sequentialized stream. *) +val decode_audio_ba : t -> track -> (audio_ba_data -> unit) -> unit + +(** Decode video data, if possible. + * Decoded data is passed to the second argument. + * + * Raises [End_of_stream] if all streams have ended. + * In this case, you can try [reset] to see if there is a + * new sequentialized stream. *) +val decode_video : t -> track -> (video_data -> unit) -> unit + +(** {2 Implementing decoders} *) + +(** {3 Types } *) + +(** Generic type for a decoder. *) +type ('a, 'b) decoder = { + name : string; + info : unit -> 'a * metadata; + decode : ('b -> unit) -> unit; + restart : fill:(unit -> unit) -> Ogg.Stream.stream -> unit; + (* This function is called after seeking + * to notify the decoder of the new [Ogg.Stream.stream] + * that is should use to pull data packets. *) + samples_of_granulepos : Int64.t -> Int64.t; +} + +(** Type for a generic logical stream decoder. *) +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 used to register a new decoder. First + * element is a function used to check if the initial [Ogg.Stream.packet] + * of an [Ogg.Stream.stream] matches the format decodable by this decoder. + * Second element is a function that instanciates the actual decoder + * using the initial [Ogg.Stream.stream] used to pull data packets for the + * decoder. *) +type register_decoder = + (Ogg.Stream.packet -> bool) + * (fill:(unit -> unit) -> Ogg.Stream.stream -> decoders) + +(** {3 Functions} *) + +(** Register a new decoder. *) +val ogg_decoders : (string, register_decoder) Hashtbl.t diff --git a/ogg/ogg_stubs.c b/ogg/ogg_stubs.c new file mode 100644 index 0000000..098442e --- /dev/null +++ b/ogg/ogg_stubs.c @@ -0,0 +1,523 @@ +/* + * Copyright 2007 Samuel Mimram + * + * This file is part of ocaml-ogg. + * + * ocaml-ogg is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-ogg 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 General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with ocaml-ogg; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + * As a special exception to the GNU Library General Public License, you may + * link, statically or dynamically, a "work that uses the Library" with a + * publicly distributed version of the Library to produce an executable file + * containing portions of the Library, and distribute that executable file under + * terms of your choice, without any of the additional requirements listed in + * clause 6 of the GNU Library General Public License. By "a publicly + * distributed version of the Library", we mean either the unmodified Library as + * distributed by The Savonet Team, or a modified version of the Library that is + * distributed under the conditions defined in clause 3 of the GNU Library + * General Public License. This exception does not however invalidate any other + * reasons why the executable file might be covered by the GNU Library General + * Public License. + * + */ + +#include +#include +#include +#include +#include +#include + +#include + +#include + +#include +#include +#include + +#include "ocaml-ogg.h" + +#ifndef Bytes_val +#define Bytes_val String_val +#endif + +/** Page manipulation **/ + +value value_of_page(ogg_page *op) { + CAMLparam0(); + CAMLlocal3(v, header, body); + header = caml_alloc_string(op->header_len); + memcpy(Bytes_val(header), op->header, op->header_len); + + body = caml_alloc_string(op->body_len); + memcpy(Bytes_val(body), op->body, op->body_len); + + v = caml_alloc_tuple(2); + Store_field(v, 0, header); + Store_field(v, 1, body); + + CAMLreturn(v); +} + +ogg_page *page_of_value(value v, ogg_page *page) { + page->header = (unsigned char *)String_val(Field(v, 0)); + page->header_len = caml_string_length(Field(v, 0)); + + page->body = (unsigned char *)String_val(Field(v, 1)); + page->body_len = caml_string_length(Field(v, 1)); + + return page; +} + +CAMLprim value ocaml_ogg_page_serialno(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(caml_copy_nativeint(ogg_page_serialno(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_eos(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(Val_bool(ogg_page_eos(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_bos(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(Val_bool(ogg_page_bos(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_packets(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(Val_int(ogg_page_packets(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_continued(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(Val_bool(ogg_page_continued(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_version(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(Val_int(ogg_page_version(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_granulepos(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(caml_copy_int64(ogg_page_granulepos(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_pageno(value page) { + CAMLparam1(page); + ogg_page op; + CAMLreturn(caml_copy_nativeint(ogg_page_pageno(page_of_value(page, &op)))); +} + +CAMLprim value ocaml_ogg_page_checksum_set(value page) { + CAMLparam1(page); + ogg_page op; + ogg_page_checksum_set(page_of_value(page, &op)); + CAMLreturn(Val_unit); +} + +/***** Sync state *****/ + +static void finalize_sync_state(value s) { + ogg_sync_destroy(Sync_state_val(s)); +} + +static struct custom_operations sync_state_ops = { + "ocaml_ogg_sync_state", finalize_sync_state, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +CAMLprim value ocaml_ogg_sync_init() { + CAMLparam0(); + CAMLlocal1(sync); + ogg_sync_state *oy = malloc(sizeof(ogg_sync_state)); + + ogg_sync_init(oy); + sync = caml_alloc_custom(&sync_state_ops, sizeof(ogg_sync_state *), 1, 0); + Sync_state_val(sync) = oy; + + CAMLreturn(sync); +} + +CAMLprim value ocaml_ogg_sync_reset(value oy) { + CAMLparam1(oy); + ogg_sync_reset(Sync_state_val(oy)); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_ogg_sync_pageseek(value cb, value oy) { + CAMLparam2(cb, oy); + CAMLlocal1(bytes); + ogg_sync_state *sync = Sync_state_val(oy); + int read; + int len = 4096; + ogg_page page; + int err = ogg_sync_pageseek(sync, &page); + + bytes = caml_alloc_string(len); + + while (err <= 0) { + read = Int_val(caml_callback3(cb, bytes, Val_int(0), Val_int(len))); + if (read == 0) + caml_raise_constant(*caml_named_value("ogg_exn_eos")); + + char *buffer = ogg_sync_buffer(sync, read); + memcpy(buffer, String_val(bytes), read); + ogg_sync_wrote(sync, read); + err = ogg_sync_pageseek(sync, &page); + } + + CAMLreturn(value_of_page(&page)); +} + +CAMLprim value ocaml_ogg_sync_read(value cb, value oy) { + CAMLparam2(cb, oy); + CAMLlocal2(ret, bytes); + ogg_sync_state *sync = Sync_state_val(oy); + int read; + int len = 4096; + ogg_page page; + int ans = ogg_sync_pageout(sync, &page); + + bytes = caml_alloc_string(len); + + while (ans != 1) { + if (ans == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + read = Int_val(caml_callback3(cb, bytes, Val_int(0), Val_int(len))); + if (read == 0) + caml_raise_constant(*caml_named_value("ogg_exn_eos")); + + char *buffer = ogg_sync_buffer(sync, read); + memcpy(buffer, String_val(bytes), read); + ogg_sync_wrote(sync, read); + ans = ogg_sync_pageout(sync, &page); + } + + CAMLreturn(value_of_page(&page)); +} + +/***** Stream state ******/ + +static void finalize_stream_state(value s) { + // This also free the argument + ogg_stream_destroy(Stream_state_val(s)); +} + +static struct custom_operations stream_state_ops = { + "ocaml_ogg_stream_state", finalize_stream_state, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +static void finalize_packet(value s) { + ogg_packet *op = Packet_val(s); + free(op->packet); + free(op); +} + +static inline ogg_packet *copy_packet(ogg_packet *op) { + ogg_packet *nop = malloc(sizeof(ogg_packet)); + if (nop == NULL) + caml_raise_out_of_memory(); + nop->packet = malloc(op->bytes); + memcpy(nop->packet, op->packet, op->bytes); + nop->bytes = op->bytes; + nop->b_o_s = op->b_o_s; + nop->e_o_s = op->e_o_s; + nop->granulepos = op->granulepos; + nop->packetno = op->packetno; + + return nop; +} + +static struct custom_operations packet_ops = { + "ocaml_ogg_packet", finalize_packet, custom_compare_default, + custom_hash_default, custom_serialize_default, custom_deserialize_default}; + +value value_of_packet(ogg_packet *op) { + CAMLparam0(); + CAMLlocal1(packet); + packet = caml_alloc_custom_mem(&packet_ops, sizeof(ogg_packet *), op->bytes); + Packet_val(packet) = copy_packet(op); + CAMLreturn(packet); +} + +CAMLprim value ocaml_ogg_stream_init(value serial) { + CAMLparam0(); + CAMLlocal1(ans); + ogg_stream_state *os = malloc(sizeof(ogg_stream_state)); + + ogg_stream_init(os, Nativeint_val(serial)); + ans = caml_alloc_custom(&stream_state_ops, sizeof(ogg_stream_state *), 1, 0); + Stream_state_val(ans) = os; + + CAMLreturn(ans); +} + +CAMLprim value ocaml_ogg_stream_eos(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + CAMLreturn(Val_bool(ogg_stream_eos(os))); +} + +// libogg does not offer any API to generate a final, empty page. +// However, some (most!) codecs need a synchronous way to end their +// logical bitstream without having to submit an empty packet so we +// hack it away.. +CAMLprim value ocaml_ogg_stream_terminate(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_page page; + + ogg_packet op; + op.packet = (unsigned char *)NULL; + op.bytes = 0; + op.b_o_s = 0; + op.e_o_s = 1; + op.granulepos = os->granulepos + 1; + op.packetno = os->packetno + 1; + ogg_stream_packetin(os, &op); + + if (!ogg_stream_pageout(os, &page)) + caml_raise_constant(*caml_named_value("ogg_exn_bad_data")); + + page.header[26] = 0; + page.header_len = 27; + page.body = NULL; + page.body_len = 0; + + ogg_page_checksum_set(&page); + CAMLreturn(value_of_page(&page)); +} + +CAMLprim value ocaml_ogg_stream_pageout(value o_stream_state, value fill) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_page og; + int ret; + +#ifdef HAVE_PAGEOUT_FILL + if (fill != Val_unit) + ret = ogg_stream_pageout_fill(os, &og, Int_val(fill)); + else +#endif + ret = ogg_stream_pageout(os, &og); + + if (!ret) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + + CAMLreturn(value_of_page(&og)); +} + +CAMLprim value ocaml_ogg_stream_pagein(value o_stream_state, value page) { + CAMLparam2(o_stream_state, page); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_page op; + + if (ogg_stream_pagein(os, page_of_value(page, &op)) != 0) + caml_raise_constant(*caml_named_value("ogg_exn_bad_data")); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_ogg_stream_packetin(value o_stream_state, value packet) { + CAMLparam2(o_stream_state, packet); + ogg_stream_state *os = Stream_state_val(o_stream_state); + + if (ogg_stream_packetin(os, Packet_val(packet)) != 0) + caml_raise_constant(*caml_named_value("ogg_exn_bad_data")); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_ogg_stream_packetout(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_packet op; + int ret = ogg_stream_packetout(os, &op); + + if (ret == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + CAMLreturn(value_of_packet(&op)); +} + +CAMLprim value ocaml_ogg_stream_packet_advance(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_packet op; + int ret = ogg_stream_packetout(os, &op); + + if (ret == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_ogg_stream_packetpeek(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_packet op; + int ret = ogg_stream_packetpeek(os, &op); + + if (ret == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + CAMLreturn(value_of_packet(&op)); +} + +CAMLprim value ocaml_ogg_stream_granulepospeek(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_packet op; + int ret = ogg_stream_packetpeek(os, &op); + + if (ret == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + CAMLreturn(caml_copy_int64(op.granulepos)); +} + +CAMLprim value ocaml_ogg_stream_packet_granulepos(value _op) { + CAMLparam1(_op); + ogg_packet *op = Packet_val(_op); + + CAMLreturn(caml_copy_int64(op->granulepos)); +} + +CAMLprim value ocaml_ogg_flush_stream(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_page og; + + if (!ogg_stream_flush(os, &og)) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + + CAMLreturn(value_of_page(&og)); +} + +CAMLprim value ocaml_ogg_stream_serialno(value o_stream_state) { + CAMLparam1(o_stream_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + + CAMLreturn(caml_copy_nativeint((intnat)os->serialno)); +} + +/* Ogg skeleton helpers */ + +/* Values from http://xiph.org/ogg/doc/skeleton.html */ +#define SKELETON_VERSION_MAJOR 3 +#define SKELETON_VERSION_MINOR 0 +#define FISHEAD_IDENTIFIER "fishead\0" + +/* Wrappers */ +static void write16le(unsigned char *ptr, ogg_uint16_t v) { + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; +} + +static void write32le(unsigned char *ptr, ogg_uint32_t v) { + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; +} + +static void write64le(unsigned char *ptr, ogg_int64_t v) { + ogg_uint32_t hi = v >> 32; + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; + ptr[4] = hi & 0xff; + ptr[5] = (hi >> 8) & 0xff; + ptr[6] = (hi >> 16) & 0xff; + ptr[7] = (hi >> 24) & 0xff; +} + +/* Code from theorautils.c in ffmpeg2theora */ +CAMLprim value ocaml_ogg_skeleton_fishead(value pres_num, value pres_den, + value base_num, value base_den, + value time) { + CAMLparam0(); + CAMLlocal1(packet); + ogg_packet op; + + memset(&op, 0, sizeof(op)); + + op.packet = malloc(64); + if (op.packet == NULL) + caml_raise_out_of_memory(); + + memset(op.packet, 0, 64); + memcpy(op.packet, FISHEAD_IDENTIFIER, 8); /* identifier */ + write16le(op.packet + 8, SKELETON_VERSION_MAJOR); /* version major */ + write16le(op.packet + 10, SKELETON_VERSION_MINOR); /* version minor */ + write64le(op.packet + 12, + (ogg_int64_t)Int64_val(pres_num)); /* presentationtime numerator */ + write64le(op.packet + 20, (ogg_int64_t)Int64_val( + pres_den)); /* presentationtime denominator */ + write64le(op.packet + 28, + (ogg_int64_t)Int64_val(base_num)); /* basetime numerator */ + write64le(op.packet + 36, + (ogg_int64_t)Int64_val(base_den)); /* basetime denominator */ + /* both the numerator are zero hence handled by the memset */ + write32le(op.packet + 44, + Int32_val(time)); /* UTC time, set to zero for now */ + + op.b_o_s = 1; /* its the first packet of the stream */ + op.e_o_s = 0; /* its not the last packet of the stream */ + op.bytes = 64; /* length of the packet in bytes */ + + packet = value_of_packet(&op); + free(op.packet); + CAMLreturn(packet); +} + +/* Code from theorautils.c from ffmpeg2theora */ +CAMLprim value ocaml_ogg_skeleton_eos(value v) { + CAMLparam0(); + ogg_packet op; + + /* build the e_o_s packet */ + memset(&op, 0, sizeof(op)); + op.b_o_s = 0; + op.e_o_s = 1; /* its the e_o_s packet */ + op.granulepos = 0; + op.bytes = 0; /* e_o_s packet is an empty packet */ + + CAMLreturn(value_of_packet(&op)); +} diff --git a/opus.opam b/opus.opam new file mode 100644 index 0000000..8af4af4 --- /dev/null +++ b/opus.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "Bindings to libopus" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/savonet/ocaml-xiph" +bug-reports: "https://github.com/savonet/ocaml-xiph/issues" +depends: [ + "conf-libogg" + "conf-libopus" + "conf-pkg-config" + "ocaml" {>= "4.08.0"} + "dune" {>= "2.8"} + "dune-configurator" + "ogg" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/savonet/ocaml-xiph.git" diff --git a/opus/config/discover.ml b/opus/config/discover.ml new file mode 100644 index 0000000..2846a95 --- /dev/null +++ b/opus/config/discover.ml @@ -0,0 +1,22 @@ +module C = Configurator.V1 + +external is_big_endian : unit -> bool = "ocaml_mm_is_big_endian" + +let () = + C.main ~name:"opus-pkg-config" (fun c -> + C.C_define.gen_header_file c ~fname:"config.h" + [("BIGENDIAN", Switch (is_big_endian ()))]; + + let default : C.Pkg_config.package_conf = + { libs = ["-lopus"; "-logg"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match C.Pkg_config.query pc ~package:"opus ogg" with + | None -> default + | Some deps -> deps) + in + C.Flags.write_sexp "c_flags.sexp" conf.cflags; + C.Flags.write_sexp "c_library_flags.sexp" conf.libs) diff --git a/opus/config/dune b/opus/config/dune new file mode 100644 index 0000000..5c0a90b --- /dev/null +++ b/opus/config/dune @@ -0,0 +1,6 @@ +(executable + (name discover) + (foreign_stubs + (language c) + (names endianess)) + (libraries dune.configurator)) diff --git a/opus/config/endianess.c b/opus/config/endianess.c new file mode 100644 index 0000000..458070f --- /dev/null +++ b/opus/config/endianess.c @@ -0,0 +1,20 @@ +#include +#include + +enum +{ + OCAML_MM_LITTLE_ENDIAN = 0x0100, + OCAML_MM_BIG_ENDIAN = 0x0001, +}; + +static const union { unsigned char bytes[2]; uint16_t value; } host_order = + { { 0, 1 } }; + +CAMLprim value ocaml_mm_is_big_endian(value unit) { + CAMLparam0(); + + if (host_order.value == OCAML_MM_BIG_ENDIAN) + CAMLreturn(Val_bool(1)); + + CAMLreturn(Val_bool(0)); +} diff --git a/opus/dune b/opus/dune new file mode 100644 index 0000000..a757e99 --- /dev/null +++ b/opus/dune @@ -0,0 +1,26 @@ +(library + (name opus) + (public_name opus) + (synopsis "OCaml bindings for libopus") + (libraries bigarray ogg) + (modules opus) + (foreign_stubs + (language c) + (names opus_stubs) + (extra_deps "config.h") + (flags + (:include c_flags.sexp))) + (c_library_flags + (:include c_library_flags.sexp))) + +(library + (name opus_decoder) + (public_name opus.decoder) + (synopsis "Opus decoder for the ogg-decoder library") + (libraries ogg.decoder opus) + (modules opus_decoder)) + +(rule + (targets config.h c_flags.sexp c_library_flags.sexp) + (action + (run ./config/discover.exe))) diff --git a/opus/opus.ml b/opus/opus.ml new file mode 100644 index 0000000..1e39fd6 --- /dev/null +++ b/opus/opus.ml @@ -0,0 +1,211 @@ +exception Buffer_too_small +exception Internal_error +exception Invalid_packet +exception Unimplemented +exception Invalid_state +exception Alloc_fail + +let () = + Callback.register_exception "opus_exn_buffer_too_small" Buffer_too_small; + Callback.register_exception "opus_exn_internal_error" Internal_error; + Callback.register_exception "opus_exn_invalid_packet" Invalid_packet; + Callback.register_exception "opus_exn_unimplemented" Unimplemented; + Callback.register_exception "opus_exn_invalid_state" Invalid_state; + Callback.register_exception "opus_exn_alloc_fail" Alloc_fail + +let recommended_frame_size = 960 * 6 + +external version_string : unit -> string = "ocaml_opus_version_string" + +let version_string = version_string () + +type max_bandwidth = + [ `Narrow_band | `Medium_band | `Wide_band | `Super_wide_band | `Full_band ] + +type bandwidth = [ `Auto | max_bandwidth ] + +type generic_control = + [ `Reset_state + | `Get_final_range of int ref + | `Get_pitch of int ref + | `Get_bandwidth of bandwidth ref + | `Set_lsb_depth of int + | `Get_lsb_depth of int ref + | `Set_phase_inversion_disabled of bool ] + +module Decoder = struct + type control = [ generic_control | `Set_gain of int | `Get_gain of int ref ] + + external check_packet : Ogg.Stream.packet -> bool + = "ocaml_opus_packet_check_header" + + external channels : Ogg.Stream.packet -> int = "ocaml_opus_decoder_channels" + + external comments : Ogg.Stream.packet -> string * string array + = "ocaml_opus_comments" + + let comments p = + let vendor, comments = comments p in + let comments = + Array.map + (fun s -> + let n = String.index s '=' in + (String.sub s 0 n, String.sub s (n + 1) (String.length s - n - 1))) + comments + in + let comments = Array.to_list comments in + (vendor, comments) + + type decoder + + type t = { + header : Ogg.Stream.packet; + comments : Ogg.Stream.packet; + decoder : decoder; + } + + external create : samplerate:int -> channels:int -> decoder + = "ocaml_opus_decoder_create" + + let create ?(samplerate = 48000) p1 p2 = + if not (check_packet p1) then raise Invalid_packet; + let decoder = create ~samplerate ~channels:(channels p1) in + { header = p1; comments = p2; decoder } + + external apply_control : control -> decoder -> unit = "ocaml_opus_decoder_ctl" + + let apply_control control t = apply_control control t.decoder + + external decode_float : + decoder -> + Ogg.Stream.stream -> + float array array -> + int -> + int -> + bool -> + int + = "ocaml_opus_decoder_decode_float_byte" "ocaml_opus_decoder_decode_float" + + let decode_float ?(decode_fec = false) t os buf ofs len = + decode_float t.decoder os buf ofs len decode_fec + + external decode_float_ba : + decoder -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + bool -> + int + = "ocaml_opus_decoder_decode_float_ba_byte" + "ocaml_opus_decoder_decode_float_ba" + + let decode_float_ba ?(decode_fec = false) t os buf ofs len = + decode_float_ba t.decoder os buf ofs len decode_fec + + let comments t = comments t.comments + let channels t = channels t.header +end + +module Encoder = struct + type application = [ `Voip | `Audio | `Restricted_lowdelay ] + type signal = [ `Auto | `Voice | `Music ] + type bitrate = [ `Auto | `Bitrate_max | `Bitrate of int ] + + type control = + [ generic_control + | `Set_complexity of int + | `Get_complexity of int ref + | `Set_bitrate of bitrate + | `Get_bitrate of bitrate ref + | `Set_vbr of bool + | `Get_vbr of bool ref + | `Set_vbr_constraint of bool + | `Get_vbr_constraint of bool ref + | `Set_force_channels of bool + | `Get_force_channels of bool ref + | `Set_max_bandwidth of max_bandwidth + | `Get_max_bandwidth of max_bandwidth + | `Set_bandwidth of bandwidth + | `Set_signal of signal + | `Get_signal of signal ref + | `Set_application of application + | `Get_application of application + | `Get_samplerate of int + | `Get_lookhead of int + | `Set_inband_fec of bool + | `Get_inband_fec of bool ref + | `Set_packet_loss_perc of int + | `Get_packet_loss_perc of int ref + | `Set_dtx of bool + | `Get_dtx of bool ref ] + + type encoder + + type t = { + header : Ogg.Stream.packet; + comments : Ogg.Stream.packet; + os : Ogg.Stream.stream; + samplerate : int; + enc : encoder; + } + + external create : + pre_skip:int -> + comments:string array -> + gain:int -> + samplerate:int -> + channels:int -> + application:application -> + encoder * Ogg.Stream.packet * Ogg.Stream.packet + = "ocaml_opus_encoder_create_byte" "ocaml_opus_encoder_create" + + let create ?(pre_skip = 3840) ?(comments = []) ?(gain = 0) ~samplerate + ~channels ~application os = + let comments = + List.map + (fun (label, value) -> Printf.sprintf "%s=%s" label value) + comments + in + let comments = Array.of_list comments in + let enc, p1, p2 = + create ~pre_skip ~comments ~gain ~samplerate ~channels ~application + in + { os; header = p1; comments = p2; samplerate; enc } + + let header enc = enc.header + let comments enc = enc.comments + + external apply_control : control -> encoder -> unit = "ocaml_opus_encoder_ctl" + + let apply_control control enc = apply_control control enc.enc + + external encode_float : + frame_size:int -> + encoder -> + Ogg.Stream.stream -> + float array array -> + int -> + int -> + int = "ocaml_opus_encode_float_byte" "ocaml_opus_encode_float" + + external encode_float_ba : + frame_size:int -> + encoder -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int = "ocaml_opus_encode_float_ba_byte" "ocaml_opus_encode_float_ba" + + let mk_encode_float fn ?(frame_size = 20.) t = + let frame_size = frame_size *. float t.samplerate /. 1000. in + fn ~frame_size:(int_of_float frame_size) t.enc t.os + + let encode_float = mk_encode_float encode_float + let encode_float_ba = mk_encode_float encode_float_ba + + external eos : Ogg.Stream.stream -> encoder -> unit = "ocaml_opus_encode_eos" + + let eos t = eos t.os t.enc +end diff --git a/opus/opus.mli b/opus/opus.mli new file mode 100644 index 0000000..58aaa92 --- /dev/null +++ b/opus/opus.mli @@ -0,0 +1,125 @@ +exception Buffer_too_small +exception Internal_error +exception Invalid_packet +exception Unimplemented +exception Invalid_state +exception Alloc_fail + +(** Recommended size of a frame in sample. Buffers for decoding are typically of + this size. *) +val recommended_frame_size : int + +val version_string : string + +type max_bandwidth = + [ `Narrow_band | `Medium_band | `Wide_band | `Super_wide_band | `Full_band ] + +type bandwidth = [ `Auto | max_bandwidth ] + +type generic_control = + [ `Reset_state + | `Get_final_range of int ref + | `Get_pitch of int ref + | `Get_bandwidth of bandwidth ref + | `Set_lsb_depth of int + | `Get_lsb_depth of int ref + | `Set_phase_inversion_disabled of bool ] + +module Decoder : sig + type control = [ generic_control | `Set_gain of int | `Get_gain of int ref ] + type t + + val check_packet : Ogg.Stream.packet -> bool + + (** Create a decoder with given samplerate an number of channels. *) + val create : ?samplerate:int -> Ogg.Stream.packet -> Ogg.Stream.packet -> t + + val comments : t -> string * (string * string) list + val channels : t -> int + val apply_control : control -> t -> unit + + val decode_float : + ?decode_fec:bool -> + t -> + Ogg.Stream.stream -> + float array array -> + int -> + int -> + int + + val decode_float_ba : + ?decode_fec:bool -> + t -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int +end + +module Encoder : sig + type application = [ `Voip | `Audio | `Restricted_lowdelay ] + type signal = [ `Auto | `Voice | `Music ] + type bitrate = [ `Auto | `Bitrate_max | `Bitrate of int ] + + type control = + [ generic_control + | `Set_complexity of int + | `Get_complexity of int ref + | `Set_bitrate of bitrate + | `Get_bitrate of bitrate ref + | `Set_vbr of bool + | `Get_vbr of bool ref + | `Set_vbr_constraint of bool + | `Get_vbr_constraint of bool ref + | `Set_force_channels of bool + | `Get_force_channels of bool ref + | `Set_max_bandwidth of max_bandwidth + | `Get_max_bandwidth of max_bandwidth + | `Set_bandwidth of bandwidth + | `Set_signal of signal + | `Get_signal of signal ref + | `Set_application of application + | `Get_application of application + | `Get_samplerate of int + | `Get_lookhead of int + | `Set_inband_fec of bool + | `Get_inband_fec of bool ref + | `Set_packet_loss_perc of int + | `Get_packet_loss_perc of int ref + | `Set_dtx of bool + | `Get_dtx of bool ref ] + + type t + + val create : + ?pre_skip:int -> + ?comments:(string * string) list -> + ?gain:int -> + samplerate:int -> + channels:int -> + application:application -> + Ogg.Stream.stream -> + t + + val header : t -> Ogg.Stream.packet + val comments : t -> Ogg.Stream.packet + val apply_control : control -> t -> unit + + val encode_float : + ?frame_size:float -> t -> float array array -> int -> int -> int + + val encode_float_ba : + ?frame_size:float -> + t -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int + + val eos : t -> unit + [@@alert + deprecated + "This function generates invalid bitstream. Please use \ + Ogg.Stream.terminate instead!"] +end diff --git a/opus/opus_decoder.ml b/opus/opus_decoder.ml new file mode 100644 index 0000000..271a604 --- /dev/null +++ b/opus/opus_decoder.ml @@ -0,0 +1,92 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of ocaml-opus. + * + * ocaml-opus is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-opus 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with ocaml-opus; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + *) + +let check = Opus.Decoder.check_packet +let buflen = Opus.recommended_frame_size +let decoder_samplerate = ref 48000 + +let decoder ~fill:_ os = + let decoder = ref None in + let packet1 = ref None in + let packet2 = ref None in + let os = ref os in + let init () = + match !decoder with + | None -> + let packet1 = + match !packet1 with + | None -> + let p = Ogg.Stream.get_packet !os in + packet1 := Some p; + p + | Some p -> p + in + let packet2 = + match !packet2 with + | None -> + let p = Ogg.Stream.get_packet !os in + packet2 := Some p; + p + | Some p -> p + in + let dec = + Opus.Decoder.create ~samplerate:!decoder_samplerate packet1 packet2 + in + let chans = Opus.Decoder.channels dec in + let meta = Opus.Decoder.comments dec in + decoder := Some (dec, chans, meta); + (dec, chans, meta) + | Some dec -> dec + in + let info () = + let _, chans, meta = init () in + ({ Ogg_decoder.channels = chans; sample_rate = !decoder_samplerate }, meta) + in + let restart ~fill:_ new_os = + os := new_os; + decoder := None; + ignore (init ()) + in + let decode ~decode_float ~make_float ~sub_float feed = + let dec, chans, _ = init () in + let chan _ = make_float buflen in + let buf = Array.init chans chan in + let ret = decode_float dec !os buf 0 buflen in + feed (Array.map (fun x -> sub_float x 0 ret) buf) + in + let decoder ~decode_float ~make_float ~sub_float = + { + Ogg_decoder.name = "opus"; + info; + decode = decode ~decode_float ~make_float ~sub_float; + restart; + samples_of_granulepos = (fun x -> x); + } + in + Ogg_decoder.Audio_both + ( decoder ~decode_float:Opus.Decoder.decode_float + ~make_float:(fun len -> Array.make len 0.) + ~sub_float:Array.sub, + decoder ~decode_float:Opus.Decoder.decode_float_ba + ~make_float:(Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout) + ~sub_float:Bigarray.Array1.sub ) + +let register () = Hashtbl.add Ogg_decoder.ogg_decoders "opus" (check, decoder) diff --git a/opus/opus_decoder.mli b/opus/opus_decoder.mli new file mode 100644 index 0000000..0e5d98c --- /dev/null +++ b/opus/opus_decoder.mli @@ -0,0 +1,27 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-opus. + * + * Ocaml-opus is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-opus 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-opus; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** This module provides a opus decoder for + * the [Ogg_demuxer] module. *) + +val decoder_samplerate : int ref + +(** Register the opus decoder *) +val register : unit -> unit diff --git a/opus/opus_stubs.c b/opus/opus_stubs.c new file mode 100644 index 0000000..19bb949 --- /dev/null +++ b/opus/opus_stubs.c @@ -0,0 +1,922 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#define caml_acquire_runtime_system caml_leave_blocking_section +#define caml_release_runtime_system caml_enter_blocking_section + +#include +#include +#include + +#include +#include +#include +#include + +#include "config.h" + +#ifndef Bytes_val +#define Bytes_val String_val +#endif + +#ifdef BIGENDIAN +// code from bits/byteswap.h (C) 1997, 1998 Free Software Foundation, Inc. +#define int32le_to_native(x) \ + ((((x)&0xff000000) >> 24) | (((x)&0x00ff0000) >> 8) | \ + (((x)&0x0000ff00) << 8) | (((x)&0x000000ff) << 24)) +#define int16le_to_native(x) ((((x) >> 8) & 0xff) | (((x)&0xff) << 8)) +#else +#define int32le_to_native(x) x +#define int16le_to_native(x) x +#endif + +static inline double clip(double s) { + // NaN + if (s != s) + return 0; + + if (s < -1) { + return -1; + } else if (s > 1) { + return 1; + } else + return s; +} + +/* polymorphic variant utility macro */ +#define get_var(x) caml_hash_variant(#x) + +/* Macros to convert variants to controls. */ +#define set_ctl(tag, variant, handle, fn, name, v) \ + if (tag == get_var(variant)) { \ + check(fn(handle, name(Int_val(v)))); \ + CAMLreturn(Val_unit); \ + } + +#define set_value_ctl(tag, variant, handle, fn, name, v, convert) \ + if (tag == get_var(variant)) { \ + check(fn(handle, name(convert(v)))); \ + CAMLreturn(Val_unit); \ + } + +#define get_ctl(tag, variant, handle, fn, name, v, type) \ + if (tag == get_var(variant)) { \ + type name = (type)Int_val(Field(v, 0)); \ + check(fn(handle, name(&name))); \ + Store_field(v, 0, Val_int(name)); \ + CAMLreturn(Val_unit); \ + } + +#define get_value_ctl(tag, variant, handle, fn, name, v, type, convert) \ + if (tag == get_var(variant)) { \ + type name = (type)Int_val(Field(v, 0)); \ + check(fn(handle, name(&name))); \ + Store_field(v, 0, convert(name)); \ + CAMLreturn(Val_unit); \ + } + +static void check(int ret) { + if (ret < 0) + switch (ret) { + case OPUS_BAD_ARG: + caml_invalid_argument("opus"); + + case OPUS_BUFFER_TOO_SMALL: + caml_raise_constant(*caml_named_value("opus_exn_buffer_too_small")); + + case OPUS_INTERNAL_ERROR: + caml_raise_constant(*caml_named_value("opus_exn_internal_error")); + + case OPUS_INVALID_PACKET: + caml_raise_constant(*caml_named_value("opus_exn_invalid_packet")); + + case OPUS_UNIMPLEMENTED: + caml_raise_constant(*caml_named_value("opus_exn_unimplemented")); + + case OPUS_INVALID_STATE: + caml_raise_constant(*caml_named_value("opus_exn_invalid_state")); + + case OPUS_ALLOC_FAIL: + caml_raise_constant(*caml_named_value("opus_exn_alloc_fail")); + + default: + caml_failwith("Unknown opus error"); + } +} + +CAMLprim value ocaml_opus_version_string(value unit) { + CAMLparam0(); + CAMLreturn(caml_copy_string(opus_get_version_string())); +} + +/***** Decoder ******/ + +#define Dec_val(v) (*(OpusDecoder **)Data_custom_val(v)) + +static void finalize_dec(value v) { + OpusDecoder *dec = Dec_val(v); + opus_decoder_destroy(dec); +} + +static struct custom_operations dec_ops = { + "ocaml_opus_dec", finalize_dec, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +CAMLprim value ocaml_opus_decoder_create(value _sr, value _chans) { + CAMLparam0(); + CAMLlocal1(ans); + opus_int32 sr = Int_val(_sr); + int chans = Int_val(_chans); + int ret = 0; + OpusDecoder *dec; + + dec = opus_decoder_create(sr, chans, &ret); + + check(ret); + ans = caml_alloc_custom(&dec_ops, sizeof(OpusDecoder *), 0, 1); + Dec_val(ans) = dec; + CAMLreturn(ans); +} + +CAMLprim value ocaml_opus_packet_check_header(value packet) { + CAMLparam1(packet); + ogg_packet *op = Packet_val(packet); + int ans = 0; + + if (op->bytes >= 8 && !memcmp(op->packet, "OpusHead", 8)) + ans = 1; + + CAMLreturn(Val_bool(ans)); +} + +CAMLprim value ocaml_opus_decoder_channels(value packet) { + CAMLparam1(packet); + ogg_packet *op = Packet_val(packet); + uint8_t *data = op->packet; + uint8_t version = *(data + 8); + + if (op->bytes <= 10 || memcmp(op->packet, "OpusHead", 8)) + caml_invalid_argument("Wrong header data."); + + if (version != 1) + caml_invalid_argument("Wrong header version."); + + uint8_t ret = *(data + 9); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_opus_comments(value packet) { + CAMLparam1(packet); + CAMLlocal2(ans, comments); + ogg_packet *op = Packet_val(packet); + if (!(op->bytes >= 8 && !memcmp(op->packet, "OpusTags", 8))) + check(OPUS_INVALID_PACKET); + ans = caml_alloc_tuple(2); + + int off = 8; + /* Vendor */ + + if (off + 4 > op->bytes) + check(OPUS_INVALID_PACKET); + + opus_int32 vendor_length = + int32le_to_native(*((opus_int32 *)(op->packet + off))); + off += 4; + + if (off + vendor_length > op->bytes) + check(OPUS_INVALID_PACKET); + + Store_field(ans, 0, caml_alloc_string(vendor_length)); + memcpy(Bytes_val(Field(ans, 0)), op->packet + off, vendor_length); + + off += vendor_length; + + /* Comments */ + + if (off + 4 > op->bytes) + check(OPUS_INVALID_PACKET); + + opus_int32 comments_length = + int32le_to_native(*((opus_int32 *)(op->packet + off))); + off += 4; + + comments = caml_alloc_tuple(comments_length); + Store_field(ans, 1, comments); + opus_int32 i, len; + for (i = 0; i < comments_length; i++) { + if (off + 4 > op->bytes) + check(OPUS_INVALID_PACKET); + + len = int32le_to_native(*((opus_int32 *)(op->packet + off))); + off += 4; + + if (off + len > op->bytes) + check(OPUS_INVALID_PACKET); + + Store_field(comments, i, caml_alloc_string(len)); + memcpy(Bytes_val(Field(comments, i)), op->packet + off, len); + off += len; + } + + CAMLreturn(ans); +} + +static opus_int32 bandwidth_of_value(value v) { + if (v == get_var(Auto)) + return OPUS_AUTO; + if (v == get_var(Narrow_band)) + return OPUS_BANDWIDTH_NARROWBAND; + if (v == get_var(Medium_band)) + return OPUS_BANDWIDTH_MEDIUMBAND; + if (v == get_var(Wide_band)) + return OPUS_BANDWIDTH_WIDEBAND; + if (v == get_var(Super_wide_band)) + return OPUS_BANDWIDTH_SUPERWIDEBAND; + if (v == get_var(Full_band)) + return OPUS_BANDWIDTH_FULLBAND; + + caml_failwith("Unknown opus error"); +} + +static value value_of_bandwidth(opus_int32 a) { + switch (a) { + case OPUS_AUTO: + return get_var(Auto); + case OPUS_BANDWIDTH_NARROWBAND: + return get_var(Narrow_band); + case OPUS_BANDWIDTH_MEDIUMBAND: + return get_var(Medium_band); + case OPUS_BANDWIDTH_WIDEBAND: + return get_var(Wide_band); + case OPUS_BANDWIDTH_SUPERWIDEBAND: + return get_var(Super_wide_band); + case OPUS_BANDWIDTH_FULLBAND: + return get_var(Full_band); + default: + caml_failwith("Unknown opus error"); + } +} + +CAMLprim value ocaml_opus_decoder_ctl(value ctl, value _dec) { + CAMLparam2(_dec, ctl); + CAMLlocal2(tag, v); + OpusDecoder *dec = Dec_val(_dec); + if (Is_long(ctl)) { + // Only ctl without argument here is reset state.. + opus_decoder_ctl(dec, OPUS_RESET_STATE); + CAMLreturn(Val_unit); + } else { + v = Field(ctl, 1); + tag = Field(ctl, 0); + + /* Generic controls. */ + get_ctl(tag, Get_final_range, dec, opus_decoder_ctl, OPUS_GET_FINAL_RANGE, + v, opus_uint32); + get_ctl(tag, Get_pitch, dec, opus_decoder_ctl, OPUS_GET_PITCH, v, + opus_int32); + get_value_ctl(tag, Get_bandwidth, dec, opus_decoder_ctl, OPUS_GET_BANDWIDTH, + v, opus_int32, value_of_bandwidth); + set_ctl(tag, Set_lsb_depth, dec, opus_decoder_ctl, OPUS_SET_LSB_DEPTH, v); + get_ctl(tag, Get_lsb_depth, dec, opus_decoder_ctl, OPUS_GET_LSB_DEPTH, v, + opus_int32); +#ifdef OPUS_SET_PHASE_INVERSION_DISABLED + set_ctl(tag, Set_phase_inversion_disabled, dec, opus_decoder_ctl, + OPUS_SET_PHASE_INVERSION_DISABLED, v); +#endif + + /* Decoder controls. */ + get_ctl(tag, Get_gain, dec, opus_decoder_ctl, OPUS_GET_GAIN, v, opus_int32); + set_ctl(tag, Set_gain, dec, opus_decoder_ctl, OPUS_SET_GAIN, v); + } + + caml_failwith("Unknown opus error"); +} + +CAMLprim value ocaml_opus_decoder_decode_float(value _dec, value _os, value buf, + value _ofs, value _len, + value _fec) { + CAMLparam3(_dec, _os, buf); + CAMLlocal1(chan); + ogg_stream_state *os = Stream_state_val(_os); + ogg_packet op; + OpusDecoder *dec = Dec_val(_dec); + int decode_fec = Int_val(_fec); + + int ofs = Int_val(_ofs); + int len = Int_val(_len); + int total_samples = 0; + int ret; + + int chans = Wosize_val(buf); + float *pcm = malloc(chans * len * sizeof(float)); + if (pcm == NULL) + caml_raise_out_of_memory(); + + int i, c; + + while (total_samples < len) { + ret = ogg_stream_packetout(os, &op); + /* returned values are: + * 1: ok + * 0: not enough data. in this case + * we return the number of samples + * decoded if > 0 and raise + * Ogg_not_enough_data otherwise + * -1: out of sync */ + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + if (ret == 0) { + free(pcm); + if (total_samples > 0) { + CAMLreturn(Val_int(total_samples)); + } else { + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + } + } + + if (chans != opus_packet_get_nb_channels(op.packet)) + caml_invalid_argument("Wrong number of channels."); + + caml_release_runtime_system(); + ret = opus_decode_float(dec, op.packet, op.bytes, pcm, len, decode_fec); + caml_acquire_runtime_system(); + + if (ret < 0) { + free(pcm); + check(ret); + } + for (c = 0; c < chans; c++) { + chan = Field(buf, c); + for (i = 0; i < ret; i++) + Store_double_field(chan, ofs + total_samples + i, + clip(pcm[i * chans + c])); + } + total_samples += ret; + len -= ret; + } + + free(pcm); + CAMLreturn(Val_int(total_samples)); +} + +CAMLprim value ocaml_opus_decoder_decode_float_byte(value *argv, int argn) { + return ocaml_opus_decoder_decode_float(argv[0], argv[1], argv[2], argv[3], + argv[4], argv[5]); +} + +CAMLprim value ocaml_opus_decoder_decode_float_ba(value _dec, value _os, + value buf, value _ofs, + value _len, value _fec) { + CAMLparam3(_dec, _os, buf); + CAMLlocal1(chan); + ogg_stream_state *os = Stream_state_val(_os); + ogg_packet op; + OpusDecoder *dec = Dec_val(_dec); + int decode_fec = Int_val(_fec); + + int ofs = Int_val(_ofs); + int len = Int_val(_len); + int total_samples = 0; + int ret; + + int chans = Wosize_val(buf); + float *pcm = malloc(chans * len * sizeof(float)); + if (pcm == NULL) + caml_raise_out_of_memory(); + + int i, c; + + while (total_samples < len) { + ret = ogg_stream_packetout(os, &op); + /* returned values are: + * 1: ok + * 0: not enough data. in this case + * we return the number of samples + * decoded if > 0 and raise + * Ogg_not_enough_data otherwise + * -1: out of sync */ + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + if (ret == 0) { + free(pcm); + if (total_samples > 0) { + CAMLreturn(Val_int(total_samples)); + } else { + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + } + } + + if (chans != opus_packet_get_nb_channels(op.packet)) + caml_invalid_argument("Wrong number of channels."); + + caml_release_runtime_system(); + ret = opus_decode_float(dec, op.packet, op.bytes, pcm, len, decode_fec); + caml_acquire_runtime_system(); + + if (ret < 0) { + free(pcm); + check(ret); + } + for (c = 0; c < chans; c++) { + chan = Field(buf, c); + for (i = 0; i < ret; i++) + ((float *)Caml_ba_data_val(chan))[ofs + total_samples + i] = + pcm[i * chans + c]; + } + total_samples += ret; + len -= ret; + } + + free(pcm); + CAMLreturn(Val_int(total_samples)); +} + +CAMLprim value ocaml_opus_decoder_decode_float_ba_byte(value *argv, int argn) { + return ocaml_opus_decoder_decode_float_ba(argv[0], argv[1], argv[2], argv[3], + argv[4], argv[5]); +} + +/***** Encoder *****/ + +typedef struct encoder_t { + OpusEncoder *encoder; + int samplerate_ratio; + ogg_int64_t granulepos; + ogg_int64_t packetno; +} encoder_t; + +#define Enc_val(v) (*(encoder_t **)Data_custom_val(v)) + +static void finalize_enc(value v) { + encoder_t *enc = Enc_val(v); + opus_encoder_destroy(enc->encoder); + free(enc); +} + +static struct custom_operations enc_ops = { + "ocaml_opus_enc", finalize_enc, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +static opus_int32 application_of_value(value v) { + if (v == get_var(Voip)) + return OPUS_APPLICATION_VOIP; + if (v == get_var(Audio)) + return OPUS_APPLICATION_AUDIO; + if (v == get_var(Restricted_lowdelay)) + return OPUS_APPLICATION_RESTRICTED_LOWDELAY; + + caml_failwith("Unknown opus error"); +} + +static value value_of_application(opus_int32 a) { + switch (a) { + case OPUS_APPLICATION_VOIP: + return get_var(Voip); + case OPUS_APPLICATION_AUDIO: + return get_var(Audio); + case OPUS_APPLICATION_RESTRICTED_LOWDELAY: + return get_var(Restricted_lowdelay); + default: + caml_failwith("Unknown opus error"); + } +} + +static unsigned char header_packet[19] = { + /* Identifier. */ + 'O', 'p', 'u', 's', 'H', 'e', 'a', 'd', + /* version, channels count, pre-skip (16 bits, unsigned, + * little endian) */ + 1, 2, 0, 0, + /* Samperate (32 bits, unsigned, little endian) */ + 0, 0, 0, 0, + /* output gain (16 bits, signed, little endian), channels mapping familly, + * stream count (always 0 in this implementation) */ + 0, 0, 0}; + +static void pack_header(ogg_packet *op, opus_int32 sr, int channels, + opus_int16 pre_skip, opus_int16 gain) { + op->bytes = sizeof(header_packet); + op->packet = header_packet; + + /* Now fill data. */ + op->packet[9] = channels; + opus_int16 pre_skip_native = int16le_to_native(pre_skip); + memcpy(op->packet + 10, &pre_skip_native, sizeof(opus_int16)); + opus_int32 sr_native = int32le_to_native(sr); + memcpy(op->packet + 12, &sr_native, sizeof(opus_int32)); + opus_int16 gain_native = int16le_to_native(gain); + memcpy(op->packet + 16, &gain_native, sizeof(opus_int16)); + + op->b_o_s = 1; + op->e_o_s = op->granulepos = op->packetno = 0; +} + +static void pack_comments(ogg_packet *op, char *vendor, value comments) { + int i; + long pos = 0; + opus_int32 vendor_length = strlen(vendor); + char *comment; + opus_int32 comments_len = Wosize_val(comments); + opus_int32 comment_length; + + op->bytes = 8 + 4 + vendor_length + 4; + + for (i = 0; i < Wosize_val(comments); i++) + op->bytes += 4 + caml_string_length(Field(comments, i)); + + op->packet = malloc(op->bytes); + if (op->packet == NULL) + caml_raise_out_of_memory(); + + /* Identifier. */ + memcpy(op->packet, "OpusTags", 8); + pos += 8; + + /* Vendor. */ + opus_int32 vendor_length_native = int32le_to_native(vendor_length); + memcpy(op->packet + 8, &vendor_length_native, sizeof(opus_int32)); + memcpy(op->packet + 12, vendor, vendor_length); + pos += 4 + vendor_length; + + /* Comments length. */ + memcpy(op->packet + pos, &comments_len, sizeof(opus_int32)); + pos += 4; + + /* Comments. */ + for (i = 0; i < comments_len; i++) { + comment = (char *)Bytes_val(Field(comments, i)); + comment_length = caml_string_length(Field(comments, i)); + opus_int32 comment_length_native = int32le_to_native(comment_length); + memcpy(op->packet + pos, &comment_length_native, sizeof(opus_int32)); + memcpy(op->packet + pos + 4, comment, comment_length); + pos += 4 + comment_length; + } + + op->e_o_s = op->b_o_s = op->granulepos = 0; + op->packetno = 1; +} + +CAMLprim value ocaml_opus_encoder_create(value _skip, value _comments, + value _gain, value _sr, value _chans, + value _application) { + CAMLparam0(); + CAMLlocal2(_enc, ans); + opus_int32 sr = Int_val(_sr); + int chans = Int_val(_chans); + int ret = 0; + int app = application_of_value(_application); + encoder_t *enc = malloc(sizeof(encoder_t)); + if (enc == NULL) + caml_raise_out_of_memory(); + /* First encoded packet is the third one. */ + enc->packetno = 1; + enc->granulepos = 0; + /* Value samplerates are: 48000, 24000, 16000, 12000, 8000 + * so this value is always an integer. */ + enc->samplerate_ratio = 48000 / sr; + + ogg_packet header; + pack_header(&header, sr, chans, Int_val(_skip), Int_val(_gain)); + + ogg_packet comments; + pack_comments(&comments, "ocaml-opus by the Savonet Team.", _comments); + + enc->encoder = opus_encoder_create(sr, chans, app, &ret); + + check(ret); + _enc = caml_alloc_custom(&enc_ops, sizeof(encoder_t *), 0, 1); + Enc_val(_enc) = enc; + + ans = caml_alloc_tuple(3); + + Store_field(ans, 0, _enc); + Store_field(ans, 1, value_of_packet(&header)); + Store_field(ans, 2, value_of_packet(&comments)); + + free(comments.packet); + + CAMLreturn(ans); +} + +CAMLprim value ocaml_opus_encoder_create_byte(value *argv, int argn) { + return ocaml_opus_encoder_create(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); +} + +static opus_int32 bitrate_of_value(value v) { + if (Is_long(v)) { + if (v == get_var(Auto)) + return OPUS_AUTO; + if (v == get_var(Bitrate_max)) + return OPUS_BITRATE_MAX; + } else { + if (Field(v, 0) == get_var(Bitrate)) + return Int_val(Field(v, 1)); + } + + caml_failwith("Unknown opus error"); +} + +CAMLprim value value_of_bitrate(opus_int32 a) { + CAMLparam0(); + CAMLlocal1(ret); + switch (a) { + case OPUS_AUTO: + CAMLreturn(get_var(Auto)); + case OPUS_BITRATE_MAX: + CAMLreturn(get_var(Voice)); + default: + ret = caml_alloc_tuple(2); + Store_field(ret, 0, get_var(Bitrate)); + Store_field(ret, 1, Val_int(a)); + CAMLreturn(ret); + } +} + +static opus_int32 signal_of_value(value v) { + if (v == get_var(Auto)) + return OPUS_AUTO; + if (v == get_var(Voice)) + return OPUS_SIGNAL_VOICE; + if (v == get_var(Music)) + return OPUS_SIGNAL_MUSIC; + + caml_failwith("Unknown opus error"); +} + +static value value_of_signal(opus_int32 a) { + switch (a) { + case OPUS_AUTO: + return get_var(Auto); + case OPUS_SIGNAL_VOICE: + return get_var(Voice); + case OPUS_SIGNAL_MUSIC: + return get_var(Music); + default: + caml_failwith("Unknown opus error"); + } +} + +CAMLprim value ocaml_opus_encoder_ctl(value ctl, value _enc) { + CAMLparam2(_enc, ctl); + CAMLlocal2(tag, v); + encoder_t *handler = Enc_val(_enc); + OpusEncoder *enc = handler->encoder; + if (Is_long(ctl)) { + // Only ctl without argument here is reset state.. + opus_encoder_ctl(enc, OPUS_RESET_STATE); + CAMLreturn(Val_unit); + } else { + v = Field(ctl, 1); + tag = Field(ctl, 0); + + /* Generic controls. */ + get_ctl(tag, Get_final_range, enc, opus_encoder_ctl, OPUS_GET_FINAL_RANGE, + v, opus_uint32); + get_ctl(tag, Get_pitch, enc, opus_encoder_ctl, OPUS_GET_PITCH, v, + opus_int32); + get_value_ctl(tag, Get_bandwidth, enc, opus_encoder_ctl, OPUS_GET_BANDWIDTH, + v, opus_int32, value_of_bandwidth); + set_ctl(tag, Set_lsb_depth, enc, opus_encoder_ctl, OPUS_SET_LSB_DEPTH, v); + get_ctl(tag, Get_lsb_depth, enc, opus_encoder_ctl, OPUS_GET_LSB_DEPTH, v, + opus_int32); +#ifdef OPUS_SET_PHASE_INVERSION_DISABLED + set_ctl(tag, Set_phase_inversion_disabled, enc, opus_encoder_ctl, + OPUS_SET_PHASE_INVERSION_DISABLED, v); +#endif + + /* Encoder controls. */ + set_ctl(tag, Set_complexity, enc, opus_encoder_ctl, OPUS_SET_COMPLEXITY, v); + get_ctl(tag, Get_complexity, enc, opus_encoder_ctl, OPUS_GET_COMPLEXITY, v, + opus_int32); + set_ctl(tag, Set_vbr, enc, opus_encoder_ctl, OPUS_SET_VBR, v); + get_ctl(tag, Get_vbr, enc, opus_encoder_ctl, OPUS_GET_VBR, v, opus_int32); + set_ctl(tag, Set_vbr_constraint, enc, opus_encoder_ctl, + OPUS_SET_VBR_CONSTRAINT, v); + get_ctl(tag, Get_vbr_constraint, enc, opus_encoder_ctl, + OPUS_GET_VBR_CONSTRAINT, v, opus_int32); + set_ctl(tag, Set_force_channels, enc, opus_encoder_ctl, + OPUS_SET_FORCE_CHANNELS, v); + get_ctl(tag, Get_force_channels, enc, opus_encoder_ctl, + OPUS_GET_FORCE_CHANNELS, v, opus_int32); + get_ctl(tag, Get_samplerate, enc, opus_encoder_ctl, OPUS_GET_SAMPLE_RATE, v, + opus_int32); + get_ctl(tag, Get_lookhead, enc, opus_encoder_ctl, OPUS_GET_LOOKAHEAD, v, + opus_int32); + set_ctl(tag, Set_inband_fec, enc, opus_encoder_ctl, OPUS_SET_INBAND_FEC, v); + get_ctl(tag, Get_inband_fec, enc, opus_encoder_ctl, OPUS_GET_INBAND_FEC, v, + opus_int32); + set_ctl(tag, Set_packet_loss_perc, enc, opus_encoder_ctl, + OPUS_SET_PACKET_LOSS_PERC, v); + get_ctl(tag, Get_packet_loss_perc, enc, opus_encoder_ctl, + OPUS_GET_PACKET_LOSS_PERC, v, opus_int32); + set_ctl(tag, Set_dtx, enc, opus_encoder_ctl, OPUS_SET_DTX, v); + get_ctl(tag, Get_dtx, enc, opus_encoder_ctl, OPUS_GET_DTX, v, opus_int32); + + /* These guys have polynmorphic variant as argument.. */ + set_value_ctl(tag, Set_bitrate, enc, opus_encoder_ctl, OPUS_SET_BITRATE, v, + bitrate_of_value); + get_value_ctl(tag, Get_bitrate, enc, opus_encoder_ctl, OPUS_GET_BITRATE, v, + opus_int32, value_of_bitrate); + set_value_ctl(tag, Set_max_bandwidth, enc, opus_encoder_ctl, + OPUS_SET_MAX_BANDWIDTH, v, bandwidth_of_value); + get_value_ctl(tag, Get_max_bandwidth, enc, opus_encoder_ctl, + OPUS_GET_MAX_BANDWIDTH, v, opus_int32, value_of_bandwidth); + set_value_ctl(tag, Set_bandwidth, enc, opus_encoder_ctl, OPUS_SET_BANDWIDTH, + v, bandwidth_of_value); + set_value_ctl(tag, Set_signal, enc, opus_encoder_ctl, OPUS_SET_SIGNAL, v, + signal_of_value); + get_value_ctl(tag, Get_signal, enc, opus_encoder_ctl, OPUS_GET_SIGNAL, v, + opus_int32, value_of_signal); + set_value_ctl(tag, Set_application, enc, opus_encoder_ctl, + OPUS_SET_APPLICATION, v, application_of_value); + get_value_ctl(tag, Get_application, enc, opus_encoder_ctl, + OPUS_GET_APPLICATION, v, opus_int32, value_of_application); + } + + caml_failwith("Unknown opus error"); +} + +CAMLprim value ocaml_opus_encode_float(value _frame_size, value _enc, value _os, + value buf, value _off, value _len) { + CAMLparam3(_enc, buf, _os); + encoder_t *handler = Enc_val(_enc); + OpusEncoder *enc = handler->encoder; + ogg_stream_state *os = Stream_state_val(_os); + ogg_packet op; + int off = Int_val(_off); + int len = Int_val(_len); + int frame_size = Int_val(_frame_size); + + if (len < frame_size) + caml_raise_constant(*caml_named_value("opus_exn_buffer_too_small")); + + int chans = Wosize_val(buf); + /* This is the recommended value */ + int max_data_bytes = 4000; + unsigned char *data = malloc(max_data_bytes); + if (data == NULL) + caml_raise_out_of_memory(); + float *pcm = malloc(chans * frame_size * sizeof(float)); + if (pcm == NULL) + caml_raise_out_of_memory(); + int i, j, c; + int ret; + int loops = len / frame_size; + for (i = 0; i < loops; i++) { + for (j = 0; j < frame_size; j++) + for (c = 0; c < chans; c++) + pcm[chans * j + c] = + clip(Double_field(Field(buf, c), off + j + i * frame_size)); + + caml_release_runtime_system(); + ret = opus_encode_float(enc, pcm, frame_size, data, max_data_bytes); + caml_acquire_runtime_system(); + + if (ret < 0) { + free(pcm); + free(data); + check(ret); + } + + /* From the documentation: If the return value is 1 byte, + * then the packet does not need to be transmitted (DTX). */ + if (ret < 2) + continue; + + handler->granulepos += frame_size * handler->samplerate_ratio; + handler->packetno++; + + op.bytes = ret; + op.packet = data; + op.b_o_s = op.e_o_s = 0; + op.packetno = handler->packetno; + op.granulepos = handler->granulepos; + + if (ogg_stream_packetin(os, &op) != 0) { + free(pcm); + free(data); + caml_raise_constant(*caml_named_value("ogg_exn_internal_error")); + } + } + free(pcm); + free(data); + + CAMLreturn(Val_int(loops * frame_size)); +} + +CAMLprim value ocaml_opus_encode_float_byte(value *argv, int argn) { + return ocaml_opus_encode_float(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); +} + +CAMLprim value ocaml_opus_encode_float_ba(value _frame_size, value _enc, + value _os, value buf, value _ofs, + value _len) { + CAMLparam3(_enc, buf, _os); + encoder_t *handler = Enc_val(_enc); + OpusEncoder *enc = handler->encoder; + ogg_stream_state *os = Stream_state_val(_os); + ogg_packet op; + int len = Int_val(_len); + int ofs = Int_val(_ofs); + int chans = Wosize_val(buf); + int frame_size = Int_val(_frame_size); + + if (chans == 0) + CAMLreturn(Val_int(0)); + + if (Caml_ba_array_val(Field(buf, 0))->dim[0] < ofs + len) + caml_failwith("Invalid length or offset!"); + + if (len < frame_size) + caml_raise_constant(*caml_named_value("opus_exn_buffer_too_small")); + + /* This is the recommended value */ + int max_data_bytes = 4000; + unsigned char *data = malloc(max_data_bytes); + if (data == NULL) + caml_raise_out_of_memory(); + float *pcm = malloc(chans * frame_size * sizeof(float)); + if (pcm == NULL) + caml_raise_out_of_memory(); + int i, j, c; + int ret; + int loops = len / frame_size; + for (i = 0; i < loops; i++) { + for (j = 0; j < frame_size; j++) + for (c = 0; c < chans; c++) + pcm[chans * j + c] = ((float *)Caml_ba_data_val( + Field(buf, c)))[j + i * frame_size + ofs]; + + caml_release_runtime_system(); + ret = opus_encode_float(enc, pcm, frame_size, data, max_data_bytes); + caml_acquire_runtime_system(); + + if (ret < 0) { + free(pcm); + free(data); + check(ret); + } + + /* From the documentation: If the return value is 1 byte, + * then the packet does not need to be transmitted (DTX). */ + if (ret < 2) + continue; + + handler->granulepos += frame_size * handler->samplerate_ratio; + handler->packetno++; + + op.bytes = ret; + op.packet = data; + op.b_o_s = op.e_o_s = 0; + op.packetno = handler->packetno; + op.granulepos = handler->granulepos; + + if (ogg_stream_packetin(os, &op) != 0) { + free(pcm); + free(data); + caml_raise_constant(*caml_named_value("ogg_exn_internal_error")); + } + } + free(pcm); + free(data); + + CAMLreturn(Val_int(loops * frame_size)); +} + +CAMLprim value ocaml_opus_encode_float_ba_byte(value *argv, int argn) { + return ocaml_opus_encode_float_ba(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); +} + +CAMLprim value ocaml_opus_encode_eos(value _os, value _enc) { + CAMLparam2(_os, _enc); + ogg_stream_state *os = Stream_state_val(_os); + ogg_packet op; + encoder_t *handler = Enc_val(_enc); + handler->packetno++; + + op.bytes = 0; + op.packet = NULL; + op.b_o_s = 0; + op.e_o_s = 1; + op.packetno = handler->packetno; + op.granulepos = handler->granulepos; + + if (ogg_stream_packetin(os, &op) != 0) + caml_raise_constant(*caml_named_value("ogg_exn_internal_error")); + ; + + CAMLreturn(Val_unit); +} diff --git a/speex.opam b/speex.opam new file mode 100644 index 0000000..3c826a5 --- /dev/null +++ b/speex.opam @@ -0,0 +1,34 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "Bindings to libspeex" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/savonet/ocaml-xiph" +bug-reports: "https://github.com/savonet/ocaml-xiph/issues" +depends: [ + "conf-libogg" + "conf-libspeex" + "conf-pkg-config" + "dune" {>= "2.8"} + "dune-configurator" + "ocaml" {>= "4.07"} + "ogg" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/savonet/ocaml-xiph.git" diff --git a/speex/config/discover.ml b/speex/config/discover.ml new file mode 100644 index 0000000..28b6061 --- /dev/null +++ b/speex/config/discover.ml @@ -0,0 +1,17 @@ +module C = Configurator.V1 + +let () = + C.main ~name:"speex-pkg-config" (fun c -> + let default : C.Pkg_config.package_conf = + { libs = ["-lspeex"; "-logg"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match C.Pkg_config.query pc ~package:"speex ogg" with + | None -> default + | Some deps -> deps) + in + C.Flags.write_sexp "c_flags.sexp" conf.cflags; + C.Flags.write_sexp "c_library_flags.sexp" conf.libs) diff --git a/speex/config/dune b/speex/config/dune new file mode 100644 index 0000000..5c0a90b --- /dev/null +++ b/speex/config/dune @@ -0,0 +1,6 @@ +(executable + (name discover) + (foreign_stubs + (language c) + (names endianess)) + (libraries dune.configurator)) diff --git a/speex/config/endianess.c b/speex/config/endianess.c new file mode 100644 index 0000000..458070f --- /dev/null +++ b/speex/config/endianess.c @@ -0,0 +1,20 @@ +#include +#include + +enum +{ + OCAML_MM_LITTLE_ENDIAN = 0x0100, + OCAML_MM_BIG_ENDIAN = 0x0001, +}; + +static const union { unsigned char bytes[2]; uint16_t value; } host_order = + { { 0, 1 } }; + +CAMLprim value ocaml_mm_is_big_endian(value unit) { + CAMLparam0(); + + if (host_order.value == OCAML_MM_BIG_ENDIAN) + CAMLreturn(Val_bool(1)); + + CAMLreturn(Val_bool(0)); +} diff --git a/speex/dune b/speex/dune new file mode 100644 index 0000000..6046dd7 --- /dev/null +++ b/speex/dune @@ -0,0 +1,25 @@ +(library + (name speex) + (public_name speex) + (synopsis "OCaml bindings for libspeex") + (libraries ogg) + (modules speex) + (foreign_stubs + (language c) + (names speex_stubs) + (flags + (:include c_flags.sexp))) + (c_library_flags + (:include c_library_flags.sexp))) + +(library + (name speex_decoder) + (public_name speex.decoder) + (synopsis "Speex decoder for the ogg-decoder library") + (libraries ogg.decoder speex) + (modules speex_decoder)) + +(rule + (targets c_flags.sexp c_library_flags.sexp) + (action + (run ./config/discover.exe))) diff --git a/speex/speex.ml b/speex/speex.ml new file mode 100644 index 0000000..4d158da --- /dev/null +++ b/speex/speex.ml @@ -0,0 +1,461 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-speex. + * + * Ocaml-speex is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-speex 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-speex; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** + * Functions for decoding speex files using libspeex. + * + * @author Romain Beauxis + *) + +exception Invalid_frame_size + +type mode = Narrowband | Wideband | Ultra_wideband + +(* Internal use only *) +type internal_mode + +external internal_mode_of_int : int -> internal_mode = "caml_speex_get_mode" + +(* Values from speex.h *) +let mode_of_int x = + match x with + | 0 -> Narrowband + | 1 -> Wideband + | 2 -> Ultra_wideband + | _ -> failwith "unknown mode" + +let int_of_mode x = + match x with Narrowband -> 0 | Wideband -> 1 | Ultra_wideband -> 2 + +let internal_mode_of_mode x = internal_mode_of_int (int_of_mode x) + +(* Generated by control_define *) + +(** TODO: better implementation.. *) +type control = + | SPEEX_RESET_STATE + | SPEEX_SET_ENH + | SPEEX_GET_ENH + | SPEEX_GET_FRAME_SIZE + | SPEEX_SET_QUALITY + | SPEEX_SET_MODE + | SPEEX_GET_MODE + | SPEEX_SET_LOW_MODE + | SPEEX_GET_LOW_MODE + | SPEEX_SET_HIGH_MODE + | SPEEX_GET_HIGH_MODE + | SPEEX_SET_VBR + | SPEEX_GET_VBR + | SPEEX_SET_VBR_QUALITY + | SPEEX_GET_VBR_QUALITY + | SPEEX_SET_COMPLEXITY + | SPEEX_GET_COMPLEXITY + | SPEEX_SET_BITRATE + | SPEEX_GET_BITRATE + | SPEEX_SET_SAMPLING_RATE + | SPEEX_GET_SAMPLING_RATE + | SPEEX_SET_VAD + | SPEEX_GET_VAD + | SPEEX_SET_ABR + | SPEEX_GET_ABR + | SPEEX_SET_DTX + | SPEEX_GET_DTX + | SPEEX_SET_SUBMODE_ENCODING + | SPEEX_GET_SUBMODE_ENCODING + | SPEEX_SET_PLC_TUNING + | SPEEX_GET_PLC_TUNING + | SPEEX_SET_VBR_MAX_BITRATE + | SPEEX_GET_VBR_MAX_BITRATE + | SPEEX_SET_HIGHPASS + | SPEEX_GET_HIGHPASS + | SPEEX_GET_ACTIVITY + +let int_of_control x = + match x with + | SPEEX_SET_ENH -> 0 + | SPEEX_GET_ENH -> 1 + | SPEEX_GET_FRAME_SIZE -> 3 + | SPEEX_SET_QUALITY -> 4 + | SPEEX_SET_MODE -> 6 + | SPEEX_GET_MODE -> 7 + | SPEEX_SET_LOW_MODE -> 8 + | SPEEX_GET_LOW_MODE -> 9 + | SPEEX_SET_HIGH_MODE -> 10 + | SPEEX_GET_HIGH_MODE -> 11 + | SPEEX_SET_VBR -> 12 + | SPEEX_GET_VBR -> 13 + | SPEEX_SET_VBR_QUALITY -> 14 + | SPEEX_GET_VBR_QUALITY -> 15 + | SPEEX_SET_COMPLEXITY -> 16 + | SPEEX_GET_COMPLEXITY -> 17 + | SPEEX_SET_BITRATE -> 18 + | SPEEX_GET_BITRATE -> 19 + | SPEEX_SET_SAMPLING_RATE -> 24 + | SPEEX_GET_SAMPLING_RATE -> 25 + | SPEEX_RESET_STATE -> 26 + | SPEEX_SET_VAD -> 30 + | SPEEX_GET_VAD -> 31 + | SPEEX_SET_ABR -> 32 + | SPEEX_GET_ABR -> 33 + | SPEEX_SET_DTX -> 34 + | SPEEX_GET_DTX -> 35 + | SPEEX_SET_SUBMODE_ENCODING -> 36 + | SPEEX_GET_SUBMODE_ENCODING -> 37 + | SPEEX_SET_PLC_TUNING -> 40 + | SPEEX_GET_PLC_TUNING -> 41 + | SPEEX_SET_VBR_MAX_BITRATE -> 42 + | SPEEX_GET_VBR_MAX_BITRATE -> 43 + | SPEEX_SET_HIGHPASS -> 44 + | SPEEX_GET_HIGHPASS -> 45 + | SPEEX_GET_ACTIVITY -> 47 + +let _ = + Callback.register "caml_speex_mode_of_int" mode_of_int; + Callback.register "caml_speex_int_of_mode" int_of_mode; + Callback.register_exception "ocaml_speex_invfrlen_exn" Invalid_frame_size; + Callback.register_exception "ocaml_speex_eos_exn" Ogg.End_of_stream + +module Header = struct + type t = { + id : string; + version : string; + version_id : int; + header_size : int; + rate : int; + mode : mode; + mode_bitstream_version : int; + nb_channels : int; + bitrate : int; + frame_size : int; + vbr : bool; + frames_per_packet : int; + extra_headers : int; + } + + (* Defined in speex_header.h *) + let header_string_length = 8 + let header_version_length = 20 + + external init : int -> int -> internal_mode -> int -> bool -> t + = "caml_speex_init_header" + + let init ?(frames_per_packet = 1) ?(mode = Wideband) ?(vbr = true) + ~nb_channels ~rate () = + init rate nb_channels (internal_mode_of_mode mode) frames_per_packet vbr + + external encode_header_packetout : + t -> string array -> Ogg.Stream.packet * Ogg.Stream.packet + = "caml_speex_encode_header" + + let encode_header_packetout e l = + let l = List.map (fun (x, y) -> Printf.sprintf "%s=%s" x y) l in + encode_header_packetout e (Array.of_list l) + + let encode_header e l s = + let p1, p2 = encode_header_packetout e l in + Ogg.Stream.put_packet s p1; + Ogg.Stream.put_packet s p2 + + external header_of_packet : Ogg.Stream.packet -> t + = "caml_speex_header_of_packet" + + external comments_of_packet : Ogg.Stream.packet -> string array + = "caml_speex_comments_of_packet" + + let comments_of_packet p = + let x = comments_of_packet p in + let vendor = x.(0) in + let x = Array.sub x 1 (Array.length x - 1) in + let c_k = ref 0 in + let c_v = ref 0 in + let split s = + try + let i = String.index s '=' in + try (String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)) + with Invalid_argument _ -> + c_v := !c_v + 1; + (String.sub s 0 i, Printf.sprintf "unknown_value_%i" !c_k) + with Not_found -> + c_k := !c_k + 1; + (Printf.sprintf "unkown_key_%i" !c_k, s) + in + (vendor, Array.to_list (Array.map split x)) +end + +module Encoder = struct + type t + + external init : internal_mode -> int -> t = "ocaml_speex_enc_init" + + let init m x = init (internal_mode_of_mode m) x + + external get : t -> int -> int = "ocaml_speex_encoder_ctl_get" + + let get x q = get x (int_of_control q) + + external set : t -> int -> int -> unit = "ocaml_speex_encoder_ctl_set" + + let set x q v = set x (int_of_control q) v + + external encode_page_main : + t -> int -> Ogg.Stream.stream -> (unit -> float array) -> Ogg.Page.t + = "ocaml_speex_encode_page" + + let encode_page e s f = encode_page_main e 1 s f + + let merge frame = + let ret = + Array.init (2 * Array.length frame.(0)) (fun _ -> frame.(0).(0)) + in + Array.iteri + (fun i _ -> + ret.(2 * i) <- frame.(0).(i); + ret.((2 * i) + 1) <- frame.(1).(i)) + frame.(0); + ret + + let encode_page_stereo e s f = + let f () = merge (f ()) in + encode_page_main e 2 s f + + external encode_page_int_main : + t -> int -> Ogg.Stream.stream -> (unit -> int array) -> Ogg.Page.t + = "ocaml_speex_encode_page_int" + + let encode_page_int e s f = encode_page_int_main e 1 s f + + let encode_page_int_stereo e s f = + let f () = merge (f ()) in + encode_page_int_main e 2 s f + + external eos : t -> Ogg.Stream.stream -> unit = "ocaml_speex_encoder_eos" +end + +module Decoder = struct + type t + + external init : internal_mode -> t = "ocaml_speex_dec_init" + + let init m = init (internal_mode_of_mode m) + + external get : t -> int -> int = "ocaml_speex_decoder_ctl_get" + + let get x q = get x (int_of_control q) + + external set : t -> int -> int -> unit = "ocaml_speex_decoder_ctl_set" + + let set x q v = set x (int_of_control q) v + + let split frame = + let ret = Array.make 2 (Array.make (Array.length frame / 2) frame.(0)) in + for i = 0 to (Array.length frame / 2) - 1 do + ret.(0).(i) <- frame.(2 * i); + ret.(1).(i) <- frame.((2 * i) + 1) + done; + ret + + external decode_feed : + t -> int -> Ogg.Stream.stream -> (float array -> unit) -> unit + = "ocaml_speex_decoder_decode" + + let decode_gen e s chan func split = + let l = ref [] in + let feed x = l := split x :: !l in + begin + try func e chan s feed + with Ogg.Not_enough_data -> + if List.length !l = 0 then raise Ogg.Not_enough_data + end; + List.rev !l + + let decode e s = decode_gen e s 1 decode_feed (fun x -> x) + let decode_stereo e s = decode_gen e s 2 decode_feed split + + let decode_feed_stereo e s feed = + let feed x = feed (split x) in + decode_feed e 2 s feed + + let decode_feed e s feed = decode_feed e 1 s feed + + external decode_int_feed : + t -> int -> Ogg.Stream.stream -> (int array -> unit) -> unit + = "ocaml_speex_decoder_decode_int" + + let decode_int e s = decode_gen e s 2 decode_int_feed (fun x -> x) + let decode_int_stereo e s = decode_gen e s 2 decode_int_feed split + + let decode_int_feed_stereo e s feed = + let feed x = feed (split x) in + decode_int_feed e 2 s feed + + let decode_int_feed e s feed = decode_int_feed e 1 s feed +end + +module Wrapper = struct + module Decoder = struct + exception Not_speex + exception Internal + + type t = + (Decoder.t + * Ogg.Stream.stream + * Ogg.Sync.t + * nativeint + * int + * (string * (string * string) list) + * Header.t) + ref + + type read = bytes -> int -> int -> int + + let open_sync sync = + (* Test wether the stream contains speex data *) + let test_speex () = + (* Get First page *) + let page = Ogg.Sync.read sync in + (* Check wether this is a b_o_s *) + if not (Ogg.Page.bos page) then raise Not_found; + (* Create a stream with this ID *) + let serial = Ogg.Page.serialno page in + let os = Ogg.Stream.create ~serial () in + Ogg.Stream.put_page os page; + (* Test header. Do not catch anything, first page should be sufficient *) + let packet = Ogg.Stream.get_packet os in + try + let header = Header.header_of_packet packet in + (* Get comments *) + let page = ref (Ogg.Sync.read sync) in + while Ogg.Page.serialno !page <> serial do + page := Ogg.Sync.read sync + done; + Ogg.Stream.put_page os !page; + let comments = Ogg.Stream.get_packet os in + let comments = Header.comments_of_packet comments in + (serial, os, header, comments) + with _ -> + Printf.printf "Not a speex stream..\n"; + raise Internal + in + let rec init () = + try test_speex () with + (* Not_found is not catched: ogg stream always start + with all b_o_s and we don't care about sequenced streams here *) + | Internal -> init () + | Ogg.Not_enough_data -> raise Not_speex + in + let serial, os, header, comments = init () in + let chans = header.Header.nb_channels in + let rate = header.Header.rate in + let mode = header.Header.mode in + let dec = Decoder.init mode in + Decoder.set dec SPEEX_SET_SAMPLING_RATE rate; + ref (dec, os, sync, serial, chans, comments, header) + + let open_file file = + let sync, fd = Ogg.Sync.create_from_file file in + (open_sync sync, fd) + + let open_feed feed = + let sync = Ogg.Sync.create feed in + open_sync sync + + let serial x = + let _, _, _, serial, _, _, _ = !x in + serial + + let comments x = + let _, _, _, _, _, (_, l), _ = !x in + l + + let header x = + let _, _, _, _, _, _, h = !x in + h + + let decode_gen f x = + let dec, os, sync, serial, _, _, _ = !x in + let dec = ref dec in + let serial = ref serial in + let os = ref os in + let eos = ref false in + let rec put () = + try + if !eos then ( + try + (* Try to open a new stream *) + let y = open_sync sync in + let ndec, nos, _, nserial, _, _, _ = !y in + x := !y; + dec := ndec; + serial := nserial; + os := nos; + eos := false + with Not_found -> raise Internal); + let page = Ogg.Sync.read sync in + if Ogg.Stream.eos !os then eos := true; + if Ogg.Page.serialno page = !serial then Ogg.Stream.put_page !os page + with + | Internal | Ogg.Not_enough_data -> raise Ogg.End_of_stream + | Ogg.End_of_stream -> + eos := true; + put () + in + let rec get () = + try f !dec !os with + | Ogg.End_of_stream -> + eos := true; + put (); + get () + | Ogg.Not_enough_data -> + put (); + get () + in + get () + + let decode v = decode_gen Decoder.decode v + let decode_stereo v = decode_gen Decoder.decode_stereo v + + let decode_feed v feed = + decode_gen (fun x y -> Decoder.decode_feed x y feed) v + + let decode_feed_stereo v feed = + decode_gen (fun x y -> Decoder.decode_feed_stereo x y feed) v + + let decode_int v = decode_gen Decoder.decode_int v + let decode_int_stereo v = decode_gen Decoder.decode_int_stereo v + + let decode_int_feed v feed = + decode_gen (fun x y -> Decoder.decode_int_feed x y feed) v + + let decode_int_feed_stereo v feed = + decode_gen (fun x y -> Decoder.decode_int_feed_stereo x y feed) v + end +end + +module Skeleton = struct + external fisbone : + nativeint -> Header.t -> Int64.t -> string -> Ogg.Stream.packet + = "ocaml_speex_skeleton_fisbone" + + let fisbone ?(start_granule = Int64.zero) + ?(headers = [("Content-type", "audio/speex")]) ~serialno ~header () = + let concat s (h, v) = Printf.sprintf "%s%s: %s\r\n" s h v in + let s = List.fold_left concat "" headers in + fisbone serialno header start_granule s +end diff --git a/speex/speex.mli b/speex/speex.mli new file mode 100644 index 0000000..4a67c8b --- /dev/null +++ b/speex/speex.mli @@ -0,0 +1,295 @@ +(* + * Copyright 2003-2006 Savonet team + * + * This file is part of Ocaml-speex. + * + * Ocaml-speex is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-speex 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-speex; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** + * Functions for manipulating speex audio data using libspeex. + * + * @author Romain Beauxis + *) + +exception Invalid_frame_size + +type mode = Narrowband | Wideband | Ultra_wideband + +(* Generated by control_define *) +type control = + | (* Reset the encoder/decoder memories to zero *) + SPEEX_RESET_STATE + | (* Set/get enhancement on/off (decoder only) *) + SPEEX_SET_ENH + | SPEEX_GET_ENH + | (* Obtain frame size used by encoder/decoder *) + SPEEX_GET_FRAME_SIZE + | (* Set/get quality value *) + SPEEX_SET_QUALITY + | (* Set/get sub-mode to use *) + SPEEX_SET_MODE + | SPEEX_GET_MODE + | (* Set/get low-band sub-mode to use (wideband only)*) + SPEEX_SET_LOW_MODE + | SPEEX_GET_LOW_MODE + | (* Set/get high-band sub-mode to use (wideband only)*) + SPEEX_SET_HIGH_MODE + | SPEEX_GET_HIGH_MODE + | (* Set/get VBR on (1) or off (0) *) + SPEEX_SET_VBR + | SPEEX_GET_VBR + | (* Set/get quality value for VBR encoding (0-10) *) + SPEEX_SET_VBR_QUALITY + | SPEEX_GET_VBR_QUALITY + | (* Set/get complexity of the encoder (0-10) *) + SPEEX_SET_COMPLEXITY + | SPEEX_GET_COMPLEXITY + | (* Set/get bitrate *) + SPEEX_SET_BITRATE + | SPEEX_GET_BITRATE + | (* Set/get sampling rate *) + SPEEX_SET_SAMPLING_RATE + | SPEEX_GET_SAMPLING_RATE + | (* Set/get VAD status (1 for on, 0 for off) *) + SPEEX_SET_VAD + | SPEEX_GET_VAD + | (* Set/get Average Bit-Rate (ABR) to n bits per seconds *) + SPEEX_SET_ABR + | SPEEX_GET_ABR + | (* Set/get DTX status (1 for on, 0 for off) *) + SPEEX_SET_DTX + | SPEEX_GET_DTX + | (* Set/get submode encoding in each frame (1 for yes, 0 for no, setting to no breaks the standard) *) + SPEEX_SET_SUBMODE_ENCODING + | SPEEX_GET_SUBMODE_ENCODING + | (* Set/get tuning for packet-loss concealment (expected loss rate) *) + SPEEX_SET_PLC_TUNING + | SPEEX_GET_PLC_TUNING + | (* Set/get the max bit-rate allowed in VBR mode *) + SPEEX_SET_VBR_MAX_BITRATE + | SPEEX_GET_VBR_MAX_BITRATE + | (* Turn on/off input/output high-pass filtering *) + SPEEX_SET_HIGHPASS + | SPEEX_GET_HIGHPASS + | (* Get "activity level" of the last decoded frame, i.e. + how much damage we cause if we remove the frame *) + SPEEX_GET_ACTIVITY + +module Header : sig + (** Type for speex header. *) + type t = { + id : string; + version : string; + version_id : int; + header_size : int; + rate : int; + mode : mode; + mode_bitstream_version : int; + nb_channels : int; + bitrate : int; + frame_size : int; + vbr : bool; + frames_per_packet : int; + extra_headers : int; + } + + (* Defined in speex_header.h *) + val header_string_length : int + val header_version_length : int + + (** Initiate a new speex header. *) + val init : + ?frames_per_packet:int -> + ?mode:mode -> + ?vbr:bool -> + nb_channels:int -> + rate:int -> + unit -> + t + + (** [encode_header_packetout header metadata]: output ogg packets containing the header. + * First packet contains speex audio codec settings, second the metadata. *) + val encode_header_packetout : + t -> (string * string) list -> Ogg.Stream.packet * Ogg.Stream.packet + + (** Output ogg packets containing the header and put them into the given stream. *) + val encode_header : t -> (string * string) list -> Ogg.Stream.stream -> unit + + (** Decode the speex header contained in the given packet. + * + * Raises [Invalid_argument] if the packet does not contain speex audio codec data. *) + val header_of_packet : Ogg.Stream.packet -> t + + (** Decode the metadata contained in the given packet. + * + * Raises [Invalid_argument] if the packet does not contain speex metadata. *) + val comments_of_packet : Ogg.Stream.packet -> string * (string * string) list +end + +module Encoder : sig + (** Opaque type for the speex encoder. *) + type t + + (** Initiate a new encoder. *) + val init : mode -> int -> t + + (** Get a parameter. *) + val get : t -> control -> int + + (** Set a parameter. *) + val set : t -> control -> int -> unit + + (** [encode_page encoder stream f]: calls [f] to get audio data and encode it until a page is ready. + * + * Known issue: float expected values seem not to be in [-1..1] but in + * [-32768..32767] which does not seem to be correct. *) + val encode_page : + t -> Ogg.Stream.stream -> (unit -> float array) -> Ogg.Page.t + + (** Same as [encode_page] except that it encodes stereo data into mono. *) + val encode_page_stereo : + t -> Ogg.Stream.stream -> (unit -> float array array) -> Ogg.Page.t + + (** Same as [encode_page] but using integers. *) + val encode_page_int : + t -> Ogg.Stream.stream -> (unit -> int array) -> Ogg.Page.t + + (** Same as [encode_page_stereo] but using integers. *) + val encode_page_int_stereo : + t -> Ogg.Stream.stream -> (unit -> int array array) -> Ogg.Page.t + + (** Set the end of stream for this stream. *) + val eos : t -> Ogg.Stream.stream -> unit + [@@alert + deprecated + "This function generates invalid bitstream. Please use \ + Ogg.Stream.terminate instead!"] +end + +module Decoder : sig + (** Opaque type for the speex decoder. *) + type t + + (** Initiate a new decoder. *) + val init : mode -> t + + (** Get a setting. *) + val get : t -> control -> int + + (** Set a setting. *) + val set : t -> control -> int -> unit + + (** Decode data. *) + val decode : t -> Ogg.Stream.stream -> float array list + + (** Decode stereo data. *) + val decode_stereo : t -> Ogg.Stream.stream -> float array array list + + (** Decode data, passing them to the given feed. *) + val decode_feed : t -> Ogg.Stream.stream -> (float array -> unit) -> unit + + (** Decode stereo data, passing them to the given feed. *) + val decode_feed_stereo : + t -> Ogg.Stream.stream -> (float array array -> unit) -> unit + + (** Same as [decode] but with integers. *) + val decode_int : t -> Ogg.Stream.stream -> int array list + + (** Same as [decode_stereo] but with integers. *) + val decode_int_stereo : t -> Ogg.Stream.stream -> int array array list + + (** Same as [decode_feed] but with integers. *) + val decode_int_feed : t -> Ogg.Stream.stream -> (int array -> unit) -> unit + + (** Same as [decode_feed_stereo] but with integers. *) + val decode_int_feed_stereo : + t -> Ogg.Stream.stream -> (int array array -> unit) -> unit +end + +module Wrapper : sig + (** High level wrappers for speex. *) + + module Decoder : sig + (** High level wrapper to easily decode speex files. *) + + exception Not_speex + + (** Opaque type for the decoder. *) + type t + + (** Type for data read. Same signature as [Unix.read]. *) + type read = bytes -> int -> int -> int + + (** Open the passed [Ogg.Sync] as a new speex stream. *) + val open_sync : Ogg.Sync.t -> t + + (** Open the passed file name as a new speex stream. *) + val open_file : string -> t * Unix.file_descr + + (** Open the passed feed as a new speex stream. *) + val open_feed : read -> t + + (** Get the serial of the stream currently being decoded. + * This value may change if the stream contains sequentialized ogg streams. *) + val serial : t -> nativeint + + (** Get current comments. *) + val comments : t -> (string * string) list + + (** Get current header. *) + val header : t -> Header.t + + (** Decode audio data. *) + val decode : t -> float array list + + (** Decode stereo audio data. *) + val decode_stereo : t -> float array array list + + (** Decode audio data, passing it to a feed. *) + val decode_feed : t -> (float array -> unit) -> unit + + (** Same as [decode_feed] but with stereo data. *) + val decode_feed_stereo : t -> (float array array -> unit) -> unit + + (** Same as [decode] but with integers. *) + val decode_int : t -> int array list + + (** Same as [decode_stereo] but with integers. *) + val decode_int_stereo : t -> int array array list + + (** Same as [decode_feed] but with integers. *) + val decode_int_feed : t -> (int array -> unit) -> unit + + (** Same as [decode_int_feed_stereo] but with integers. *) + val decode_int_feed_stereo : t -> (int array array -> unit) -> unit + end +end + +module Skeleton : sig + (** Generate a vorbis fisbone packet with + * these parameters, to use in an ogg skeleton. + * Default value for [start_granule] is [Int64.zero], + * Default value for [headers] is ["Content-type","audio/speex"] + * + * See: http://xiph.org/ogg/doc/skeleton.html. *) + val fisbone : + ?start_granule:Int64.t -> + ?headers:(string * string) list -> + serialno:nativeint -> + header:Header.t -> + unit -> + Ogg.Stream.packet +end diff --git a/speex/speex_decoder.ml b/speex/speex_decoder.ml new file mode 100644 index 0000000..f8b3e0d --- /dev/null +++ b/speex/speex_decoder.ml @@ -0,0 +1,98 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-speex. + * + * Ocaml-speex is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-speex 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-speex; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +let check p = + try + let _ = Speex.Header.header_of_packet p in + true + with _ -> false + +let decoder ~fill:_ os = + let dec_p = ref None in + let decoder = ref None in + let com_p = ref None in + let os = ref os in + let init () = + match !decoder with + | None -> + let dec_p = + match !dec_p with + | None -> + let packet = Ogg.Stream.get_packet !os in + dec_p := Some packet; + packet + | Some p -> p + in + let com_p = + match !com_p with + | None -> + let packet = Ogg.Stream.get_packet !os in + com_p := Some packet; + packet + | Some p -> p + in + let header = Speex.Header.header_of_packet dec_p in + let meta = Speex.Header.comments_of_packet com_p in + let mode = header.Speex.Header.mode in + let dec = Speex.Decoder.init mode in + let sample_freq = header.Speex.Header.rate in + let chans = header.Speex.Header.nb_channels in + Speex.Decoder.set dec Speex.SPEEX_SET_SAMPLING_RATE sample_freq; + decoder := Some (dec, sample_freq, chans, meta); + (dec, sample_freq, chans, meta) + | Some d -> d + in + let info () = + let _, rate, chans, meta = init () in + ({ Ogg_decoder.channels = chans; sample_rate = rate }, meta) + in + let decode feed = + let dec, _, chans, _ = init () in + let len = ref 0 in + let feed buf = + let buf = Array.map (Array.map (fun x -> float x /. 32768.)) buf in + len := !len + Array.length buf.(0); + feed buf + in + try + let decode dec os feed = + if chans = 2 then Speex.Decoder.decode_int_feed_stereo dec os feed + else ( + let feed x = feed [| x |] in + Speex.Decoder.decode_int_feed dec os feed) + in + decode dec !os feed + with Ogg.Not_enough_data -> if !len = 0 then raise Ogg.Not_enough_data + in + let restart ~fill:_ new_os = + os := new_os; + let d, _, _, _ = init () in + Speex.Decoder.set d Speex.SPEEX_RESET_STATE 0 + in + Ogg_decoder.Audio + { + Ogg_decoder.name = "speex"; + info; + restart; + decode; + samples_of_granulepos = (fun x -> x); + } + +let register () = Hashtbl.add Ogg_decoder.ogg_decoders "speex" (check, decoder) diff --git a/speex/speex_decoder.mli b/speex/speex_decoder.mli new file mode 100644 index 0000000..e966bd4 --- /dev/null +++ b/speex/speex_decoder.mli @@ -0,0 +1,24 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-speex. + * + * Ocaml-speex is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-speex 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-speex; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** Speex decoder for the [Ogg_demuxer] module. *) + +(** Register the decoder. *) +val register : unit -> unit diff --git a/speex/speex_stubs.c b/speex/speex_stubs.c new file mode 100644 index 0000000..d010abf --- /dev/null +++ b/speex/speex_stubs.c @@ -0,0 +1,819 @@ +/* + Copyright 2003-2008 Savonet team + + This file is part of Ocaml-speex. + + Ocaml-speex is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + Ocaml-speex 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 General Public License for more details. + + You should have received a copy of the GNU General Public License + along with Ocaml-speex; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +*/ + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include +#include + +#include +#include + +#include +#include +#include +#include +#include + +#include + +#ifndef Bytes_val +#define Bytes_val String_val +#endif + +/* Comment API */ + +/* This is stolen from speexenc.c + * It should definitely be part of the library.. */ + +/* + Comments will be stored in the Vorbis style. + It is describled in the "Structure" section of + http://www.xiph.org/ogg/vorbis/doc/v-comment.html + +The comment header is decoded as follows: + 1) [vendor_length] = read an unsigned integer of 32 bits + 2) [vendor_string] = read a UTF-8 vector as [vendor_length] octets + 3) [user_comment_list_length] = read an unsigned integer of 32 bits + 4) iterate [user_comment_list_length] times { + 5) [length] = read an unsigned integer of 32 bits + 6) this iteration's user comment = read a UTF-8 vector as [length] octets + } + 7) [framing_bit] = read a single bit as boolean + 8) if ( [framing_bit] unset or end of packet ) then ERROR + 9) done. + + If you have troubles, please write to ymnk@jcraft.com. + */ + +#define readint(buf, base) \ + (((buf[base + 3] << 24) & 0xff000000) | ((buf[base + 2] << 16) & 0xff0000) | \ + ((buf[base + 1] << 8) & 0xff00) | (buf[base] & 0xff)) +#define writeint(buf, base, val) \ + do { \ + buf[base + 3] = ((val) >> 24) & 0xff; \ + buf[base + 2] = ((val) >> 16) & 0xff; \ + buf[base + 1] = ((val) >> 8) & 0xff; \ + buf[base] = (val)&0xff; \ + } while (0) + +void comment_init(char **comments, int *length, char *vendor_string) { + int vendor_length = strlen(vendor_string); + int user_comment_list_length = 0; + int len = 4 + vendor_length + 4; + char *p = (char *)malloc(len); + if (p == NULL) + caml_raise_out_of_memory(); + writeint(p, 0, vendor_length); + memcpy(p + 4, vendor_string, vendor_length); + writeint(p, 4 + vendor_length, user_comment_list_length); + *length = len; + *comments = p; +} +void comment_add(char **comments, int *length, char *val) { + char *p = *comments; + int vendor_length = readint(p, 0); + int user_comment_list_length = readint(p, 4 + vendor_length); + int val_len = strlen(val); + int len = (*length) + 4 + val_len; + + p = (char *)realloc(p, len); + if (p == NULL) { + caml_failwith("realloc"); + } + + writeint(p, *length, val_len); /* length of comment */ + memcpy(p + *length + 4, val, val_len); /* comment */ + writeint(p, 4 + vendor_length, user_comment_list_length + 1); + + *comments = p; + *length = len; +} + +CAMLprim value caml_speex_comments_of_packet(value o_packet) { + CAMLparam1(o_packet); + CAMLlocal2(ret, tmp); + ogg_packet *op = Packet_val(o_packet); + char *c = (char *)op->packet; + int length = op->bytes; + int len, i, nb_fields; + char *end; + + if (length < 8) + caml_failwith("Invalid comments raw length"); + + end = c + length; + len = readint(c, 0); + c += 4; + if (len < 0 || c + len > end) + caml_failwith("Invalid comments raw data"); + tmp = caml_alloc_string(len); + memcpy(Bytes_val(tmp), c, len); + c += len; + if (c + 4 > end) + caml_failwith("Invalid comments raw data"); + nb_fields = readint(c, 0); + ret = caml_alloc_tuple(nb_fields + 1); + Store_field(ret, 0, tmp); + c += 4; + for (i = 0; i < nb_fields; i++) { + if (c + 4 > end) + caml_failwith("Invalid comments raw data"); + len = readint(c, 0); + c += 4; + if (len < 0 || c + len > end) + caml_failwith("Invalid comments raw data"); + tmp = caml_alloc_string(len); + memcpy(Bytes_val(tmp), c, len); + Store_field(ret, i + 1, tmp); + c += len; + } + + CAMLreturn(ret); +} + +#undef readint +#undef writeint + +/* Mode API */ + +#define Mode_val(v) (*((SpeexMode **)Data_abstract_val(v))) + +static inline value value_of_speex_mode(value v, const SpeexMode *s) { + v = caml_alloc(1, Abstract_tag); + *((const SpeexMode **)Data_abstract_val(v)) = s; + return v; +} + +CAMLprim value caml_speex_get_mode(value i) { + CAMLparam0(); + CAMLlocal1(ret); + CAMLreturn(value_of_speex_mode(ret, speex_lib_get_mode(Int_val(i)))); +} + +/* Header API */ + +static SpeexHeader *header_of_value(value v, SpeexHeader *header) { + int i = 0; + value tmp; + tmp = Field(v, i++); + if (caml_string_length(tmp) > SPEEX_HEADER_STRING_LENGTH) + caml_invalid_argument("wrong argument: speex_string too long"); + memcpy(header->speex_string, String_val(tmp), caml_string_length(tmp)); + tmp = Field(v, i++); + if (caml_string_length(tmp) > SPEEX_HEADER_VERSION_LENGTH) + caml_invalid_argument("wrong argument: speex_version too long"); + memcpy(header->speex_version, String_val(tmp), caml_string_length(tmp)); +#define shv(x) header->x = Int_val(Field(v, i++)) + shv(speex_version_id); + shv(header_size); + shv(rate); + header->mode = Int_val(caml_callback( + *caml_named_value("caml_speex_int_of_mode"), Field(v, i++))); + shv(mode_bitstream_version); + shv(nb_channels); + shv(bitrate); + shv(frame_size); + Store_field(v, i++, Val_bool(header->vbr)); + shv(frames_per_packet); + shv(extra_headers); + + return header; +} + +CAMLprim value value_of_header(SpeexHeader *header) { + CAMLparam0(); + CAMLlocal2(ret, tmp); + ret = caml_alloc_tuple(13); + int i = 0; + tmp = caml_alloc_string(SPEEX_HEADER_STRING_LENGTH); + memcpy(Bytes_val(tmp), header->speex_string, SPEEX_HEADER_STRING_LENGTH); + Store_field(ret, i++, tmp); + tmp = caml_alloc_string(SPEEX_HEADER_VERSION_LENGTH); + memcpy(Bytes_val(tmp), header->speex_version, SPEEX_HEADER_VERSION_LENGTH); + Store_field(ret, i++, tmp); +#define svh(v) Store_field(ret, i++, Val_int(header->v)); + svh(speex_version_id); + svh(header_size); + svh(rate); + Store_field(ret, i++, + caml_callback(*caml_named_value("caml_speex_mode_of_int"), + Val_int(header->mode))); + svh(mode_bitstream_version); + svh(nb_channels); + svh(bitrate); + svh(frame_size); + Store_field(ret, i++, Val_bool(header->vbr)); + svh(frames_per_packet); + svh(extra_headers); + + CAMLreturn(ret); +} + +CAMLprim value caml_speex_init_header(value rate, value chans, value mode, + value fpp, value vbr) { + CAMLparam1(mode); + struct SpeexMode *m = Mode_val(mode); + SpeexHeader header; + speex_init_header(&header, Int_val(rate), 1, m); + header.frames_per_packet = Int_val(fpp); + header.vbr = Int_val(vbr); + header.nb_channels = Int_val(chans); + CAMLreturn(value_of_header(&header)); +} + +CAMLprim value caml_speex_encode_header(value v, value o_comments) { + CAMLparam2(v, o_comments); + CAMLlocal1(ret); + ogg_packet op; + int packet_size; + SpeexHeader header; + char *vendor_string = + "ocaml-speex by the savonet team (http://savonet.sf.net/)"; + char *comments; + int comments_length; + int i; + ret = caml_alloc_tuple(2); + + unsigned char *data = (unsigned char *)speex_header_to_packet( + header_of_value(v, &header), &packet_size); + op.packet = data; + op.bytes = packet_size; + op.b_o_s = 1; + op.e_o_s = 0; + op.granulepos = 0; + op.packetno = 0; + Store_field(ret, 0, value_of_packet(&op)); + free(data); + + /* Comment Packet */ + comment_init(&comments, &comments_length, vendor_string); + for (i = 0; i < Wosize_val(o_comments); i++) + comment_add(&comments, &comments_length, + (char *)Bytes_val(Field(o_comments, i))); + + op.packet = (unsigned char *)comments; + op.bytes = comments_length; + op.b_o_s = 0; + op.e_o_s = 0; + op.granulepos = 0; + op.packetno = 1; + Store_field(ret, 1, value_of_packet(&op)); + + free(comments); + CAMLreturn(ret); +} + +CAMLprim value caml_speex_header_of_packet(value packet) { + CAMLparam1(packet); + CAMLlocal1(ret); + ogg_packet *op = Packet_val(packet); + + if (op->bytes < sizeof(SpeexHeader)) + caml_invalid_argument("not a speex header"); + + caml_enter_blocking_section(); + SpeexHeader *header = speex_packet_to_header((char *)op->packet, op->bytes); + caml_leave_blocking_section(); + + if (header == NULL) + caml_invalid_argument("not a speex header"); + ret = value_of_header(header); + speex_header_free(header); + CAMLreturn(ret); +} + +/* Encoder API */ + +typedef struct cenc_t { + int position; + SpeexBits bits; + void *enc; + int fpp; +} cenc_t; + +#define Enc_val(v) (*((cenc_t **)Data_custom_val(v))) + +static void finalize_speex_enc(value v) { + cenc_t *enc = Enc_val(v); + speex_bits_destroy(&enc->bits); + speex_encoder_destroy(enc->enc); + free(enc); +} + +static struct custom_operations speex_enc_ops = { + "ocaml_speex_enc", finalize_speex_enc, custom_compare_default, + custom_hash_default, custom_serialize_default, custom_deserialize_default}; + +CAMLprim value ocaml_speex_enc_init(value m, value fpp) { + CAMLparam1(m); + CAMLlocal1(ret); + cenc_t *cen = malloc(sizeof(cenc_t)); + if (cen == NULL) + caml_raise_out_of_memory(); + SpeexMode *mode = Mode_val(m); + void *enc = speex_encoder_init(mode); + if (enc == NULL) + caml_raise_out_of_memory(); + speex_bits_init(&cen->bits); + cen->enc = enc; + cen->position = 0; + cen->fpp = Int_val(fpp); + ret = caml_alloc_custom(&speex_enc_ops, sizeof(cenc_t *), 1, 0); + Enc_val(ret) = cen; + + CAMLreturn(ret); +} + +CAMLprim value ocaml_speex_encoder_ctl_get(value e, value n) { + CAMLparam1(e); + cenc_t *cenc = Enc_val(e); + void *enc = cenc->enc; + int ret; + if (speex_encoder_ctl(enc, Int_val(n), &ret) == -2) + caml_invalid_argument("wrong argument in speex_encoder_ctl"); + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_speex_encoder_ctl_set(value e, value n, value x) { + CAMLparam1(e); + cenc_t *cenc = Enc_val(e); + void *enc = cenc->enc; + int arg = Int_val(x); + if (speex_encoder_ctl(enc, Int_val(n), &arg) == -2) + caml_invalid_argument("wrong argument in speex_encoder_ctl"); + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_speex_encode_page(value e_state, value o_chans, + value o_stream_state, value feed) { + CAMLparam3(e_state, feed, o_stream_state); + CAMLlocal2(v, ret); + ogg_stream_state *os = Stream_state_val(o_stream_state); + cenc_t *cenc = Enc_val(e_state); + void *enc = cenc->enc; + ogg_page og; + ogg_packet op; + int state = cenc->position - 1; + int len; + int frame_size; + int fpp = cenc->fpp; + int chans = Int_val(o_chans); + speex_encoder_ctl(enc, SPEEX_GET_FRAME_SIZE, &frame_size); + int i; + float *data = malloc(sizeof(float) * frame_size * chans); + if (data == NULL) + caml_raise_out_of_memory(); + char *cbits = malloc(sizeof(char) * frame_size * chans); + if (cbits == NULL) { + free(data); + caml_raise_out_of_memory(); + } + int nbBytes; + + /* Is there an audio page flushed? If not, work until there is. */ + do { + + if (ogg_stream_eos(os)) { + free(data); + free(cbits); + caml_raise_constant(*caml_named_value("ocaml_speex_eos_exn")); + } + + /* Read and process more audio. */ + v = caml_callback_exn(feed, Val_unit); + if Is_exception_result (v) { + free(data); + free(cbits); + cenc->position = state + 1; + caml_raise(Extract_exception(v)); + } + + len = Wosize_val(v) / Double_wosize; + if (len != frame_size * chans) { + free(data); + free(cbits); + cenc->position = state + 1; + caml_raise_constant(*caml_named_value("ocaml_speex_invfrlen_exn")); + } + for (i = 0; i < len; i++) + data[i] = Double_field(v, i); + + caml_enter_blocking_section(); + if (chans == 2) + speex_encode_stereo(data, frame_size, &cenc->bits); + speex_encode(enc, data, &cenc->bits); + caml_leave_blocking_section(); + + state++; + + if ((state + 1) % fpp != 0) + continue; + + speex_bits_insert_terminator(&cenc->bits); + nbBytes = speex_bits_write(&cenc->bits, cbits, frame_size * fpp); + speex_bits_reset(&cenc->bits); + op.packet = (unsigned char *)cbits; + op.bytes = nbBytes; + op.b_o_s = 0; + op.e_o_s = 0; + op.granulepos = (state + 1) * frame_size; + op.packetno = 2 + state / fpp; + + /* Put the packet in the ogg stream. */ + ogg_stream_packetin(os, &op); + } while (ogg_stream_pageout(os, &og) <= 0); + + cenc->position = state + 1; + ret = value_of_page(&og); + free(data); + free(cbits); + CAMLreturn(ret); +} + +CAMLprim value ocaml_speex_encode_page_int(value e_state, value o_chans, + value o_stream_state, value feed) { + CAMLparam3(e_state, feed, o_stream_state); + CAMLlocal2(v, ret); + ogg_stream_state *os = Stream_state_val(o_stream_state); + cenc_t *cenc = Enc_val(e_state); + void *enc = cenc->enc; + ogg_page og; + ogg_packet op; + int state = cenc->position - 1; + int len; + int chans = Int_val(o_chans); + int frame_size; + int fpp = cenc->fpp; + speex_encoder_ctl(enc, SPEEX_GET_FRAME_SIZE, &frame_size); + int i; + spx_int16_t *data = malloc(sizeof(spx_int16_t) * frame_size * chans); + if (data == NULL) + caml_raise_out_of_memory(); + char *cbits = malloc(sizeof(char) * frame_size * chans); + if (cbits == NULL) { + free(data); + caml_raise_out_of_memory(); + } + int nbBytes; + + /* Is there an audio page flushed? If not, work until there is. */ + do { + if (ogg_stream_eos(os)) { + free(data); + free(cbits); + caml_raise_constant(*caml_named_value("ocaml_speex_eos_exn")); + } + + /* Read and process more audio. */ + v = caml_callback_exn(feed, Val_unit); + if Is_exception_result (v) { + free(data); + free(cbits); + cenc->position = state + 1; + caml_raise(Extract_exception(v)); + } + + len = Wosize_val(v); + if (len != frame_size * chans) { + free(data); + free(cbits); + cenc->position = state + 1; + caml_raise_constant(*caml_named_value("ocaml_speex_invfrlen_exn")); + } + + for (i = 0; i < len; i++) + data[i] = Int_val(Field(v, i)); + + caml_enter_blocking_section(); + if (chans == 2) + speex_encode_stereo_int(data, frame_size, &cenc->bits); + speex_encode_int(enc, data, &cenc->bits); + caml_leave_blocking_section(); + + state++; + + if ((state + 1) % fpp != 0) + continue; + + speex_bits_insert_terminator(&cenc->bits); + nbBytes = speex_bits_write(&cenc->bits, cbits, frame_size); + speex_bits_reset(&cenc->bits); + op.packet = (unsigned char *)cbits; + op.bytes = nbBytes; + op.b_o_s = 0; + op.e_o_s = 0; + op.granulepos = (state + 1) * frame_size; + op.packetno = 2 + state / fpp; + + /* Put the packet in the ogg stream. */ + ogg_stream_packetin(os, &op); + } while (ogg_stream_pageout(os, &og) <= 0); + + cenc->position = state + 1; + ret = value_of_page(&og); + free(data); + free(cbits); + CAMLreturn(ret); +} + +CAMLprim value ocaml_speex_encoder_eos(value v, value o_stream_state) { + CAMLparam2(v, o_stream_state); + ogg_packet op; + ogg_stream_state *os = Stream_state_val(o_stream_state); + cenc_t *cenc = Enc_val(v); + int state = cenc->position - 1; + void *enc = cenc->enc; + int frame_size; + speex_encoder_ctl(enc, SPEEX_GET_FRAME_SIZE, &frame_size); + + op.packet = (unsigned char *)NULL; + op.bytes = 0; + op.b_o_s = 0; + op.e_o_s = 1; + op.granulepos = (state + 1) * frame_size; + op.packetno = 2 + state; + ogg_stream_packetin(os, &op); + + CAMLreturn(Val_unit); +} + +/* Decoder API */ + +typedef struct cdec_t { + SpeexStereoState *stereo; + SpeexBits bits; + void *dec; +} cdec_t; + +#define Dec_val(v) (*((cdec_t **)Data_custom_val(v))) + +static void finalize_speex_dec(value v) { + cdec_t *cdec = Dec_val(v); + speex_stereo_state_destroy(cdec->stereo); + speex_bits_destroy(&cdec->bits); + speex_decoder_destroy(cdec->dec); + free(cdec); +} + +static struct custom_operations speex_dec_ops = { + "ocaml_speex_dec", finalize_speex_dec, custom_compare_default, + custom_hash_default, custom_serialize_default, custom_deserialize_default}; + +CAMLprim value ocaml_speex_dec_init(value m) { + CAMLparam1(m); + CAMLlocal1(ret); + SpeexMode *mode = Mode_val(m); + void *dec = speex_decoder_init(mode); + if (dec == NULL) + caml_raise_out_of_memory(); + SpeexStereoState *stereo = speex_stereo_state_init(); + if (stereo == NULL) + caml_raise_out_of_memory(); + cdec_t *cdec = malloc(sizeof(cdec_t)); + if (cdec == NULL) + caml_raise_out_of_memory(); + cdec->dec = dec; + speex_bits_init(&cdec->bits); + cdec->stereo = stereo; + + SpeexCallback callback; + + callback.callback_id = SPEEX_INBAND_STEREO; + callback.func = speex_std_stereo_request_handler; + callback.data = stereo; + speex_decoder_ctl(dec, SPEEX_SET_HANDLER, &callback); + + ret = caml_alloc_custom(&speex_dec_ops, sizeof(cdec_t *), 1, 0); + Dec_val(ret) = cdec; + + CAMLreturn(ret); +} + +CAMLprim value ocaml_speex_decoder_ctl_get(value e, value n) { + CAMLparam1(e); + cdec_t *cdec = Dec_val(e); + void *dec = cdec->dec; + int ret; + if (speex_decoder_ctl(dec, Int_val(n), &ret) == -2) + caml_invalid_argument("wrong argument in speex_decoder_ctl"); + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_speex_decoder_ctl_set(value e, value n, value x) { + CAMLparam1(e); + cdec_t *cdec = Dec_val(e); + void *dec = cdec->dec; + int arg = Int_val(x); + if (speex_decoder_ctl(dec, Int_val(n), &arg) == -2) + caml_invalid_argument("wrong argument in speex_decoder_ctl"); + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_speex_decoder_decode(value e, value o_chans, value s, + value add) { + CAMLparam3(e, s, add); + CAMLlocal2(ret, v); + ogg_stream_state *os = Stream_state_val(s); + cdec_t *cdec = Dec_val(e); + void *dec = cdec->dec; + SpeexStereoState *stereo = cdec->stereo; + int chans = Int_val(o_chans); + int err; + ogg_packet op; + int frame_size; + speex_decoder_ctl(dec, SPEEX_GET_FRAME_SIZE, &frame_size); + float *out = malloc(sizeof(float) * frame_size * chans); + if (out == NULL) + caml_raise_out_of_memory(); + int i; + int n; + + while (1) { + err = ogg_stream_packetout(os, &op); + if (err <= 0) { + free(out); + if (err == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + else + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + } + + /* Copy Ogg packet to Speex bitstream */ + caml_enter_blocking_section(); + speex_bits_read_from(&cdec->bits, (char *)op.packet, op.bytes); + caml_leave_blocking_section(); + + while (1) { + caml_enter_blocking_section(); + n = speex_decode(dec, &cdec->bits, out); + caml_leave_blocking_section(); + + if (n == -1) + break; + + if (chans == 2) + speex_decode_stereo(out, frame_size, stereo); + ret = caml_alloc(frame_size * chans * Double_wosize, Double_array_tag); + for (i = 0; i < frame_size * chans; i++) + Store_double_field(ret, i, out[i]); + v = caml_callback_exn(add, ret); + if Is_exception_result (v) { + free(out); + caml_raise(Extract_exception(v)); + } + }; + } + + free(out); + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_speex_decoder_decode_int(value e, value o_chans, value s, + value add) { + CAMLparam3(e, s, add); + CAMLlocal2(ret, v); + ogg_stream_state *os = Stream_state_val(s); + cdec_t *cdec = Dec_val(e); + void *dec = cdec->dec; + SpeexStereoState *stereo = cdec->stereo; + int chans = Int_val(o_chans); + int err; + ogg_packet op; + int frame_size; + speex_decoder_ctl(dec, SPEEX_GET_FRAME_SIZE, &frame_size); + spx_int16_t *out = malloc(sizeof(spx_int16_t) * frame_size * chans); + if (out == NULL) + caml_raise_out_of_memory(); + int i; + int n; + + while (1) { + err = ogg_stream_packetout(os, &op); + if (err <= 0) { + free(out); + if (err == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + else + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + } + + /* Copy Ogg packet to Speex bitstream */ + speex_bits_read_from(&cdec->bits, (char *)op.packet, op.bytes); + + while (1) { + caml_enter_blocking_section(); + n = speex_decode_int(dec, &cdec->bits, out); + caml_leave_blocking_section(); + + if (n == -1) + break; + + if (chans == 2) + speex_decode_stereo_int(out, frame_size, stereo); + ret = caml_alloc_tuple(frame_size * chans); + for (i = 0; i < frame_size * chans; i++) + Store_field(ret, i, Int_val(out[i])); + v = caml_callback_exn(add, ret); + if Is_exception_result (v) { + free(out); + caml_raise(Extract_exception(v)); + } + }; + } + + free(out); + CAMLreturn(Val_unit); +} + +/* Ogg skeleton support */ + +/* Wrappers */ +static void write32le(unsigned char *ptr, ogg_uint32_t v) { + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; +} + +static void write64le(unsigned char *ptr, ogg_int64_t v) { + ogg_uint32_t hi = v >> 32; + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; + ptr[4] = hi & 0xff; + ptr[5] = (hi >> 8) & 0xff; + ptr[6] = (hi >> 16) & 0xff; + ptr[7] = (hi >> 24) & 0xff; +} + +/* Values from http://xiph.org/ogg/doc/skeleton.html */ +#define FISBONE_IDENTIFIER "fisbone\0" +#define FISBONE_MESSAGE_HEADER_OFFSET 44 +#define FISBONE_SIZE 52 + +/* Values from speexenc.c in speexenc */ +CAMLprim value ocaml_speex_skeleton_fisbone(value serial, value _header, + value start, value content) { + CAMLparam4(serial, _header, start, content); + CAMLlocal1(packet); + ogg_packet op; + SpeexHeader header; + header_of_value(_header, &header); + int len = FISBONE_SIZE + caml_string_length(content); + + memset(&op, 0, sizeof(op)); + op.packet = malloc(len); + if (op.packet == NULL) + caml_raise_out_of_memory(); + + memset(op.packet, 0, len); + /* it will be the fisbone packet for the speex audio */ + memcpy(op.packet, FISBONE_IDENTIFIER, 8); /* identifier */ + write32le( + op.packet + 8, + FISBONE_MESSAGE_HEADER_OFFSET); /* offset of the message header fields */ + write32le(op.packet + 12, + Nativeint_val(serial)); /* serialno of the vorbis stream */ + write32le(op.packet + 16, + 2 + header.extra_headers); /* number of header packet */ + /* granulerate, temporal resolution of the bitstream in Hz */ + write64le(op.packet + 20, + (ogg_int64_t)header.rate); /* granulerate numerator */ + write64le(op.packet + 28, (ogg_int64_t)1); /* granulerate denominator */ + write64le(op.packet + 36, (ogg_int64_t)Int64_val(start)); /* start granule */ + write32le(op.packet + 44, 3); /* preroll, for speex its 3 */ + *(op.packet + 48) = 0; /* granule shift, always 0 for speex */ + memcpy(op.packet + FISBONE_SIZE, String_val(content), + caml_string_length(content)); + + op.b_o_s = 0; + op.e_o_s = 0; + op.bytes = len; + + packet = value_of_packet(&op); + free(op.packet); + CAMLreturn(packet); +} diff --git a/theora.opam b/theora.opam new file mode 100644 index 0000000..67d8de0 --- /dev/null +++ b/theora.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "Bindings to libtheora" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/savonet/ocaml-xiph" +bug-reports: "https://github.com/savonet/ocaml-xiph/issues" +depends: [ + "conf-libtheora" + "conf-pkg-config" + "dune" {>= "2.8"} + "dune-configurator" + "ogg" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/savonet/ocaml-xiph.git" diff --git a/theora/config/discover.ml b/theora/config/discover.ml new file mode 100644 index 0000000..470dff8 --- /dev/null +++ b/theora/config/discover.ml @@ -0,0 +1,17 @@ +module C = Configurator.V1 + +let () = + C.main ~name:"theora-pkg-config" (fun c -> + let default : C.Pkg_config.package_conf = + { libs = ["-ltheoraenc"; "-ltheoradec"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match C.Pkg_config.query pc ~package:"theoradec theoraenc" with + | None -> default + | Some deps -> deps) + in + C.Flags.write_sexp "c_flags.sexp" ("-fPIC" :: conf.cflags); + C.Flags.write_sexp "c_library_flags.sexp" conf.libs) diff --git a/theora/config/dune b/theora/config/dune new file mode 100644 index 0000000..21a5f9a --- /dev/null +++ b/theora/config/dune @@ -0,0 +1,3 @@ +(executable + (name discover) + (libraries dune.configurator)) diff --git a/theora/dune b/theora/dune new file mode 100644 index 0000000..67f160f --- /dev/null +++ b/theora/dune @@ -0,0 +1,25 @@ +(library + (name theora) + (public_name theora) + (synopsis "OCaml bindings for libtheora") + (libraries ogg) + (modules theora) + (foreign_stubs + (language c) + (names theora_stubs) + (flags + (:include c_flags.sexp))) + (c_library_flags + (:include c_library_flags.sexp))) + +(library + (name theora_decoder) + (public_name theora.decoder) + (synopsis "Theora decoder for the ogg-decoder library") + (libraries ogg.decoder theora) + (modules theora_decoder)) + +(rule + (targets c_flags.sexp c_library_flags.sexp) + (action + (run ./config/discover.exe))) diff --git a/theora/theora.ml b/theora/theora.ml new file mode 100644 index 0000000..fdbe5c5 --- /dev/null +++ b/theora/theora.ml @@ -0,0 +1,208 @@ +(* + * Copyright 2007-2011 Savonet team + * + * This file is part of ocaml-theora. + * + * ocaml-theora is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-theora 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with ocaml-theora; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** + * Functions for encoding theora files using libtheora. + * + * @author Samuel Mimram + * @author Romain Beauxis + *) + +exception Internal_error +exception Invalid_data +exception Bad_packet +exception Header_not_theora +exception Bad_header +exception Not_implemented +exception Bitstream_version_too_high +exception Unknown_error of int +exception Duplicate_frame +exception Done +exception Not_initialized + +let () = + Callback.register_exception "theora_exn_fault" Internal_error; + Callback.register_exception "theora_exn_version" Bitstream_version_too_high; + Callback.register_exception "theora_exn_bad_packet" Bad_packet; + Callback.register_exception "theora_exn_notformat" Header_not_theora; + Callback.register_exception "theora_exn_bad_header" Bad_header; + Callback.register_exception "theora_exn_not_implemented" Not_implemented; + Callback.register_exception "theora_exn_inval" Invalid_data; + Callback.register_exception "theora_exn_unknown" (Unknown_error 0); + Callback.register_exception "theora_exn_dup_frame" Duplicate_frame; + Callback.register_exception "theora_exn_not_enough_data" Ogg.Not_enough_data; + Callback.register_exception "theora_exn_end_of_file" End_of_file + +external version_string : unit -> string = "ocaml_theora_version_string" + +let version_string = version_string () + +external version_number : unit -> int = "ocaml_theora_version_number" + +let version_number = + let n = version_number () in + (n lsr 16, (n lsr 8) land 0xff, n land 0xff) + +type colorspace = + | CS_unspecified + | CS_ITU_REC_470M + | CS_ITU_REC_470BG + | CS_NSPACES + +type pixelformat = PF_420 | PF_reserved | PF_422 | PF_444 + +type info = { + frame_width : int; (** The encoded frame width. *) + frame_height : int; (** The encoded frame height. *) + picture_width : int; (** The displayed picture width. *) + picture_height : int; (** The displayed picture height. *) + picture_x : int; (** The X offset of the displayed picture. *) + picture_y : int; (** The Y offset of the displayed picture. *) + colorspace : colorspace; (** The color space. *) + pixel_fmt : pixelformat; (** The pixel format. *) + target_bitrate : int; (** The target bit-rate in bits per second. *) + quality : int; (** The target quality level. *) + keyframe_granule_shift : int; + (** The amount to shift to extract the last keyframe number from the granule position. *) + version_major : int; + version_minor : int; + version_subminor : int; + fps_numerator : int; + fps_denominator : int; + aspect_numerator : int; + aspect_denominator : int; +} + +external default_granule_shift : unit -> int + = "ocaml_theora_default_granuleshift" + +let default_granule_shift = default_granule_shift () + +type data_buffer = + (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +type yuv_buffer = { + y_width : int; + y_height : int; + y_stride : int; + y : data_buffer; + u_width : int; + u_height : int; + u_stride : int; + u : data_buffer; + v_width : int; + v_height : int; + v_stride : int; + v : data_buffer; +} + +let encoder_tag = "ocaml-theora by the savonet team (http://savonet.sf.net/)" + +external is_keyframe : Ogg.Stream.packet -> int + = "ocaml_theora_ogg_packet_iskeyframe" + +let is_keyframe op = + match is_keyframe op with 1 -> true | 0 -> false | _ -> raise Invalid_data + +module Encoder = struct + type t + + type settings = { + keyframe_frequency : int option; + vp3_compatible : bool option; + soft_target : bool option; + buffer_delay : int option; + speed : int option; + } + + external create : info -> settings -> (string * string) array -> t + = "ocaml_theora_encode_init" + + let create info params comments = + let comments = ("ENCODER", encoder_tag) :: comments in + create info params (Array.of_list comments) + + external encode_header : t -> Ogg.Stream.stream -> bool + = "ocaml_theora_encode_header" + + let encode_header enc os = + let rec f () = if not (encode_header enc os) then f () in + f () + + external encode_buffer : t -> Ogg.Stream.stream -> yuv_buffer -> unit + = "ocaml_theora_encode_buffer" + + let encode_page enc os generator = + let rec f () = + try + let yuv = generator () in + encode_buffer enc os yuv; + Ogg.Stream.get_page os + with Ogg.Not_enough_data -> f () + in + f () + + external frames_of_granulepos : t -> Int64.t -> Int64.t + = "ocaml_theora_encoder_frame_of_granulepos" + + external eos : t -> Ogg.Stream.stream -> unit = "ocaml_theora_encode_eos" +end + +module Decoder = struct + type decoder + type t + + external check : Ogg.Stream.packet -> bool = "caml_theora_check" + external create : unit -> decoder = "ocaml_theora_create_dec" + + external headerin : decoder -> Ogg.Stream.packet -> info * string array + = "ocaml_theora_dec_headerin" + + let headerin dec p = + let info, comments = headerin dec p in + let vendor, comments = + match Array.to_list comments with e :: l -> (e, l) | [] -> ("", []) + in + let split s = + try + let pos = String.index s '=' in + (String.sub s 0 pos, String.sub s (pos + 1) (String.length s - pos - 1)) + with Not_found -> ("", s) + in + (Obj.magic dec, info, vendor, List.map split comments) + + external frames_of_granulepos : t -> Int64.t -> Int64.t + = "ocaml_theora_decoder_frame_of_granulepos" + + external get_yuv : t -> Ogg.Stream.stream -> yuv_buffer + = "ocaml_theora_decode_YUVout" +end + +module Skeleton = struct + external fisbone : + Nativeint.t -> info -> Int64.t -> string -> Ogg.Stream.packet + = "ocaml_theora_skeleton_fisbone" + + let fisbone ?(start_granule = Int64.zero) + ?(headers = [("Content-type", "video/theora")]) ~serialno ~info () = + let concat s (h, v) = Printf.sprintf "%s%s: %s\r\n" s h v in + let s = List.fold_left concat "" headers in + fisbone serialno info start_granule s +end diff --git a/theora/theora.mli b/theora/theora.mli new file mode 100644 index 0000000..05996e8 --- /dev/null +++ b/theora/theora.mli @@ -0,0 +1,254 @@ +(* + * Copyright 2007-2009 Samuel Mimram, Romain Beauxis + * + * This file is part of ocaml-theora. + * + * ocaml-theora is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-theora 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with ocaml-theora; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** + * Functions for encoding theora files using libtheora. + * + * @author Samuel Mimram + * @author Romain Beauxis + *) + +(** {2 Exceptions} *) + +(** General failure. *) +exception Internal_error + +(** Library encountered invalid internal data. *) +exception Invalid_data + +(** An unhandled error happened. *) +exception Unknown_error of int + +(** The decoded packet represented a dropped frame. + * The player can continue to display the current frame, + * as the contents of the decoded frame buffer have not + * changed. *) +exception Duplicate_frame + +(** Exceptions used by the decoding module. *) +exception Done + +exception Not_initialized + +exception Bad_packet +exception Header_not_theora +exception Bad_header +exception Not_implemented + +(** {2 General functions} *) + +(** + * Human-readable string to identify the encoder vendor and version. + *) +val version_string : string + +(** major, minor and sub version numbers of the encoder. *) +val version_number : int * int * int + +(** Determines whether a theora packet is a key frame or not. + * + * raises [Invalid_data] if The packet is not a video data + * packet. *) +val is_keyframe : Ogg.Stream.packet -> bool + +(** {2 Types and datastructures} *) + +(** A Colorspace. *) +type colorspace = + | CS_unspecified (** The colorspace is unknown or unspecified *) + | CS_ITU_REC_470M (** This is the best option for 'NTSC' content *) + | CS_ITU_REC_470BG (** This is the best option for 'PAL' content *) + | CS_NSPACES (** This marks the end of the defined colorspaces *) + +(** + * A Chroma subsampling + * + * These enumerate the available chroma subsampling options supported + * by the theora format. See Section 4.4 of the specification for + * exact definitions. + *) +type pixelformat = + | PF_420 (** Chroma subsampling by 2 in each direction (4:2:0) *) + | PF_reserved (** Reserved value *) + | PF_422 (** Horizonatal chroma subsampling by 2 (4:2:2) *) + | PF_444 (** No chroma subsampling at all (4:4:4) *) + +(** Theora bitstream info. *) +type info = { + frame_width : int; (** The encoded frame width. *) + frame_height : int; (** The encoded frame height. *) + picture_width : int; (** The displayed picture width. *) + picture_height : int; (** The displayed picture height. *) + picture_x : int; (** The X offset of the displayed picture. *) + picture_y : int; (** The Y offset of the displayed picture. *) + colorspace : colorspace; (** The color space. *) + pixel_fmt : pixelformat; (** The pixel format. *) + target_bitrate : int; (** The target bit-rate in bits per second. *) + quality : int; (** The target quality level. *) + keyframe_granule_shift : int; + (** The amount to shift to extract the last keyframe number from the granule position. *) + version_major : int; + version_minor : int; + version_subminor : int; + fps_numerator : int; + fps_denominator : int; + aspect_numerator : int; + aspect_denominator : int; +} + +val default_granule_shift : int + +type data_buffer = + (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +(** + * A YUV buffer for passing uncompressed frames to and from the codec. + * This holds a Y'CbCr frame in planar format. The CbCr planes can be + * subsampled and have their own separate dimensions and row stride + * offsets. Note that the strides may be negative in some + * configurations. For theora the width and height of the largest plane + * must be a multiple of 16. The actual meaningful picture size and + * offset are stored in the [info] structure; frames returned by + * the decoder may need to be cropped for display. + * + * All samples are 8 bits. Within each plane samples are ordered by + * row from the top of the frame to the bottom. Within each row samples + * are ordered from left to right. + *) +type yuv_buffer = { + y_width : int; + y_height : int; + y_stride : int; + y : data_buffer; + u_width : int; + u_height : int; + u_stride : int; + u : data_buffer; + v_width : int; + v_height : int; + v_stride : int; + v : data_buffer; +} + +(** {2 Encoding} *) + +module Encoder : sig + type t + + type settings = { + keyframe_frequency : int option; + vp3_compatible : bool option; + soft_target : bool option; + buffer_delay : int option; + speed : int option; + } + + (** Initialize a [state] handle for decoding. *) + val create : info -> settings -> (string * string) list -> t + + (** + * Fills the given stream with the header packets. + *) + val encode_header : t -> Ogg.Stream.stream -> unit + + (** + * Encode data until a page is filled. + *) + val encode_page : t -> Ogg.Stream.stream -> (unit -> yuv_buffer) -> Ogg.Page.t + + (** Encode a buffer. *) + val encode_buffer : t -> Ogg.Stream.stream -> yuv_buffer -> unit + + (** Convert a granulepos to an absolute frame index, starting at 0. + * The granulepos is interpreted in the context of a given theora_state handle. *) + val frames_of_granulepos : t -> Int64.t -> Int64.t + + (** Set end of stream *) + val eos : t -> Ogg.Stream.stream -> unit + [@@alert + deprecated + "This function generates invalid bitstream. Please use \ + Ogg.Stream.terminate instead!"] +end + +module Decoder : sig + (** Type for an uninitialized decoder. *) + type decoder + + (** Type for an initialized decoder. *) + type t + + (** + * Check wether an ogg logical stream contains theora data + * + * This function shall be called just after you put + * the first page in the stream. See examples/thdecode.ml + * + * Raises [Ogg.Bad_data] if the stream does not contain theora data. *) + val check : Ogg.Stream.packet -> bool + + (** Initialize the decoding structure. + * The decoder should then be processed with [headerin]. *) + val create : unit -> decoder + + (** Add one packet from the stream and try to parse theora headers. + * + * Returns an initialized decoder. + * + * Raises [Ogg.Not_enough_data] is decoding header needs another packet. + * + * This function should be called with the first packets of the stream + * until it returns the requested values. It may consume at most 5 packets + * (3 header packet, 1 additional packet and the initial video packet) *) + val headerin : + decoder -> Ogg.Stream.packet -> t * info * string * (string * string) list + + (** + * Output the next available frame of decoded YUV data. + * + * Raises [Ogg.Not_enough_data] if the Ogg.Stream.stream which + * has been used to initialize the handler does not contain + * enought data. You should submit a new page to it, and + * run this function again until it returns. + * + * Raises [Not_initialized] if the decoder was not properly + * initialized with [headerin]. *) + val get_yuv : t -> Ogg.Stream.stream -> yuv_buffer + + (** Convert a granulepos to an absolute frame index, starting at 0. + * The granulepos is interpreted in the context of a given theora_state handle. *) + val frames_of_granulepos : t -> Int64.t -> Int64.t +end + +module Skeleton : sig + (** Generate a theora fisbone packet with + * these parameters, to use in an ogg skeleton. + * Default value for [start_granule] is [Int64.zero], + * Default value for [headers] is ["Content-type","video/theora"] + * + * See: http://xiph.org/ogg/doc/skeleton.html. *) + val fisbone : + ?start_granule:Int64.t -> + ?headers:(string * string) list -> + serialno:Nativeint.t -> + info:info -> + unit -> + Ogg.Stream.packet +end diff --git a/theora/theora_decoder.ml b/theora/theora_decoder.ml new file mode 100644 index 0000000..952655d --- /dev/null +++ b/theora/theora_decoder.ml @@ -0,0 +1,97 @@ +(* + * Copyright 2007-2011 Savonet team + * + * This file is part of ocaml-theora. + * + * ocaml-theora is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-theora 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with ocaml-theora; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +let check = Theora.Decoder.check + +let decoder ~fill:_ os = + let decoder = Theora.Decoder.create () in + let data = ref None in + let latest_yuv = ref None in + let os = ref os in + let init () = + match !data with + | Some (dec, info, m) -> (dec, info, m) + | None -> + let packet = Ogg.Stream.get_packet !os in + let decoder, info, vendor, m = + Theora.Decoder.headerin decoder packet + in + let meta = (vendor, m) in + data := Some (decoder, info, meta); + (decoder, info, meta) + in + let decode feed = + let decoder, info, _ = init () in + let ret = + try + let yuv = Theora.Decoder.get_yuv decoder !os in + latest_yuv := Some yuv; + yuv + with Theora.Duplicate_frame -> ( + match !latest_yuv with + | Some yuv -> yuv + | None -> raise Theora.Internal_error) + in + let format = + match info.Theora.pixel_fmt with + | Theora.PF_420 -> Ogg_decoder.Yuvj_420 + | Theora.PF_reserved -> assert false + | Theora.PF_422 -> Ogg_decoder.Yuvj_422 + | Theora.PF_444 -> Ogg_decoder.Yuvj_444 + in + let ret = + { + Ogg_decoder.format; + frame_width = info.Theora.frame_width; + frame_height = info.Theora.frame_height; + y_stride = ret.Theora.y_stride; + uv_stride = ret.Theora.u_stride; + y = ret.Theora.y; + u = ret.Theora.u; + v = ret.Theora.v; + } + in + feed ret + in + let info () = + let _, info, m = init () in + ( { + Ogg_decoder.fps_numerator = info.Theora.fps_numerator; + fps_denominator = info.Theora.fps_denominator; + width = info.Theora.frame_width; + height = info.Theora.frame_height; + }, + m ) + in + let restart ~fill:_ new_os = os := new_os in + let samples_of_granulepos pos = + let decoder, _, _ = init () in + Theora.Decoder.frames_of_granulepos decoder pos + in + Ogg_decoder.Video + { + Ogg_decoder.name = "theora"; + info; + decode; + restart; + samples_of_granulepos; + } + +let register () = Hashtbl.add Ogg_decoder.ogg_decoders "theora" (check, decoder) diff --git a/theora/theora_decoder.mli b/theora/theora_decoder.mli new file mode 100644 index 0000000..36b503e --- /dev/null +++ b/theora/theora_decoder.mli @@ -0,0 +1,25 @@ +(* + * Copyright 2007-2011 Savonet team + * + * This file is part of ocaml-theora. + * + * ocaml-theora is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-theora 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with ocaml-theora; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** Implementation of the theora decoder + * for the [Ogg_demuxer] module. *) + +(** Register the decoder. *) +val register : unit -> unit diff --git a/theora/theora_stubs.c b/theora/theora_stubs.c new file mode 100644 index 0000000..6efb8fa --- /dev/null +++ b/theora/theora_stubs.c @@ -0,0 +1,720 @@ +/* + * Copyright 2007-2009 Samuel Mimram and Romain Beauxis + * + * This file is part of ocaml-theora. + * + * ocaml-theora is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-theora 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with ocaml-theora; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include +#include + +#include + +#ifndef Bytes_val +#define Byles_val String_val +#endif + +/***** Error handling ******/ + +static void check_err(int n) { + switch (n) { + case 0: + return; + + case TH_EFAULT: + caml_raise_constant(*caml_named_value("theora_exn_fault")); + + case TH_EINVAL: + caml_raise_constant(*caml_named_value("theora_exn_inval")); + case TH_EVERSION: + caml_raise_constant(*caml_named_value("theora_exn_version")); + case TH_EBADPACKET: + caml_raise_constant(*caml_named_value("theora_exn_bad_packet")); + case TH_ENOTFORMAT: + caml_raise_constant(*caml_named_value("theora_exn_notformat")); + case TH_EBADHEADER: + caml_raise_constant(*caml_named_value("theora_exn_bad_header")); + case TH_EIMPL: + caml_raise_constant(*caml_named_value("theora_exn_not_implemented")); + + case TH_DUPFRAME: + caml_raise_constant(*caml_named_value("theora_exn_dup_frame")); + + default: + caml_raise_with_arg(*caml_named_value("theora_exn_unknown"), Val_int(n)); + } +} + +/***** Version *****/ + +CAMLprim value ocaml_theora_version_string(value unit) { + return caml_copy_string(th_version_string()); +} + +CAMLprim value ocaml_theora_version_number(value unit) { + return Val_int(th_version_number()); +} + +/***** Helper functions *****/ + +static th_colorspace cs_of_val(value v) { + switch (Int_val(v)) { + case 0: + return TH_CS_UNSPECIFIED; + + case 1: + return TH_CS_ITU_REC_470M; + + case 2: + return TH_CS_ITU_REC_470BG; + + case 3: + return TH_CS_NSPACES; + + default: + assert(0); + } +} + +static value val_of_cs(th_colorspace c) { + switch (c) { + case TH_CS_UNSPECIFIED: + return Int_val(0); + + case TH_CS_ITU_REC_470M: + return Int_val(1); + + case TH_CS_ITU_REC_470BG: + return Int_val(2); + + case TH_CS_NSPACES: + return Int_val(3); + + default: + assert(0); + } +} + +static th_pixel_fmt pf_of_val(value v) { + switch (Int_val(v)) { + case 0: + return TH_PF_420; + + case 1: + return TH_PF_RSVD; + + case 2: + return TH_PF_422; + + case 3: + return TH_PF_444; + + default: + assert(0); + } +} + +static value val_of_pf(th_pixel_fmt p) { + switch (p) { + case TH_PF_420: + return Int_val(0); + + case TH_PF_RSVD: + return Int_val(1); + + case TH_PF_422: + return Int_val(2); + + case TH_PF_444: + return Int_val(3); + + default: + assert(0); + } +} + +/* ti is *not* allocated: codec_setup may be allocated by + * theora_info_init and its memory lost. You better check what you need */ +static th_info *info_of_val(value v, th_info *ti) { + int i = 0; + + ti->frame_width = Int_val(Field(v, i++)); + ti->frame_height = Int_val(Field(v, i++)); + ti->pic_width = Int_val(Field(v, i++)); + ti->pic_height = Int_val(Field(v, i++)); + ti->pic_x = Int_val(Field(v, i++)); + ti->pic_y = Int_val(Field(v, i++)); + ti->colorspace = cs_of_val(Field(v, i++)); + ti->pixel_fmt = pf_of_val(Field(v, i++)); + ti->target_bitrate = Int_val(Field(v, i++)); + ti->quality = Int_val(Field(v, i++)); + ti->keyframe_granule_shift = Int_val(Field(v, i++)); + ti->version_major = Int_val(Field(v, i++)); + ti->version_minor = Int_val(Field(v, i++)); + ti->version_subminor = Int_val(Field(v, i++)); + ti->fps_numerator = Int_val(Field(v, i++)); + ti->fps_denominator = Int_val(Field(v, i++)); + ti->aspect_numerator = Int_val(Field(v, i++)); + ti->aspect_denominator = Int_val(Field(v, i++)); + + return ti; +} + +static value val_of_info(th_info *ti) { + CAMLparam0(); + CAMLlocal1(v); + int i = 0; + v = caml_alloc_tuple(18); + Store_field(v, i++, Val_int(ti->frame_width)); + Store_field(v, i++, Val_int(ti->frame_height)); + Store_field(v, i++, Val_int(ti->pic_width)); + Store_field(v, i++, Val_int(ti->pic_height)); + Store_field(v, i++, Val_int(ti->pic_x)); + Store_field(v, i++, Val_int(ti->pic_y)); + Store_field(v, i++, val_of_cs(ti->colorspace)); + Store_field(v, i++, val_of_pf(ti->pixel_fmt)); + Store_field(v, i++, Val_int(ti->target_bitrate)); + Store_field(v, i++, Val_int(ti->quality)); + Store_field(v, i++, Val_int(ti->keyframe_granule_shift)); + Store_field(v, i++, Val_int(ti->version_major)); + Store_field(v, i++, Val_int(ti->version_minor)); + Store_field(v, i++, Val_int(ti->version_subminor)); + Store_field(v, i++, Val_int(ti->fps_numerator)); + Store_field(v, i++, Val_int(ti->fps_denominator)); + Store_field(v, i++, Val_int(ti->aspect_numerator)); + Store_field(v, i++, Val_int(ti->aspect_denominator)); + + CAMLreturn(v); +} + +static void yuv_of_val(value v, th_ycbcr_buffer buffer) { + int i = 0; + struct caml_ba_array *ba; + + /* Y plane */ + buffer[0].width = Int_val(Field(v, i++)); + buffer[0].height = Int_val(Field(v, i++)); + buffer[0].stride = Int_val(Field(v, i++)); + ba = Caml_ba_array_val(Field(v, i++)); + if (ba->dim[0] < buffer[0].stride * buffer[0].height) + caml_raise_constant(*caml_named_value("theora_exn_inval")); + buffer[0].data = (unsigned char *)ba->data; + + /* Cb plane */ + buffer[1].width = Int_val(Field(v, i++)); + buffer[1].height = Int_val(Field(v, i++)); + buffer[1].stride = Int_val(Field(v, i++)); + ba = Caml_ba_array_val(Field(v, i++)); + if (ba->dim[0] < buffer[1].stride * buffer[1].height) + caml_raise_constant(*caml_named_value("theora_exn_inval")); + buffer[1].data = (unsigned char *)ba->data; + + /* Cr plane */ + buffer[2].width = Int_val(Field(v, i++)); + buffer[2].height = Int_val(Field(v, i++)); + buffer[2].stride = Int_val(Field(v, i++)); + ba = Caml_ba_array_val(Field(v, i++)); + if (ba->dim[0] < buffer[2].stride * buffer[2].height) + caml_raise_constant(*caml_named_value("theora_exn_inval")); + buffer[2].data = (unsigned char *)ba->data; + + return; +} + +/* The result must be freed afterwards! */ +/* This should not be called in a blocking section. */ +static value val_of_yuv(th_ycbcr_buffer buffer) { + CAMLparam0(); + CAMLlocal4(ret, y, u, v); + int i = 0; + intnat len; + ret = caml_alloc_tuple(12); + unsigned char *data; + + /* Y plane */ + Store_field(ret, i++, Val_int(buffer[0].width)); + Store_field(ret, i++, Val_int(buffer[0].height)); + Store_field(ret, i++, Val_int(buffer[0].stride)); + len = buffer[0].stride * buffer[0].height; + y = caml_ba_alloc(CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, NULL, &len); + data = Caml_ba_data_val(y); + memcpy(data, buffer[0].data, len); + Store_field(ret, i++, y); + + /* Cb plane */ + Store_field(ret, i++, Val_int(buffer[1].width)); + Store_field(ret, i++, Val_int(buffer[1].height)); + Store_field(ret, i++, Val_int(buffer[1].stride)); + len = buffer[1].stride * buffer[1].height; + u = caml_ba_alloc(CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, NULL, &len); + data = Caml_ba_data_val(u); + memcpy(data, buffer[1].data, len); + Store_field(ret, i++, u); + + /* Cr plane */ + Store_field(ret, i++, Val_int(buffer[2].width)); + Store_field(ret, i++, Val_int(buffer[2].height)); + Store_field(ret, i++, Val_int(buffer[2].stride)); + len = buffer[2].stride * buffer[2].height; + v = caml_ba_alloc(CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, NULL, &len); + data = Caml_ba_data_val(v); + memcpy(data, buffer[2].data, len); + Store_field(ret, i++, v); + + CAMLreturn(ret); +} + +CAMLprim value ocaml_theora_default_granuleshift(value unit) { + CAMLparam0(); + th_info info; + th_info_init(&info); + int ret = info.keyframe_granule_shift; + th_info_clear(&info); + CAMLreturn(Int_val(ret)); +} + +CAMLprim value ocaml_theora_ogg_packet_iskeyframe(value _op) { + CAMLparam1(_op); + ogg_packet *op = Packet_val(_op); + + CAMLreturn(Val_int(th_packet_iskeyframe(op))); +} + +/** Encoding API **/ + +typedef struct enc_state_t { + th_enc_ctx *ts; + th_info ti; + th_comment tc; + ogg_int64_t granulepos; + ogg_int64_t packetno; +} enc_state_t; + +#define Theora_enc_state_val(v) (*((enc_state_t **)Data_custom_val(v))) + +static void finalize_enc_state(value s) { + enc_state_t *state = Theora_enc_state_val(s); + th_encode_free(state->ts); + th_info_clear(&state->ti); + th_comment_clear(&state->tc); + free(state); +} + +static struct custom_operations enc_state_ops = { + "ocaml_enc_theora_state", finalize_enc_state, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +/* Thanks you + * http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php#ref_option + */ +#define Val_none Val_int(0) +#define Some_val(v) Field(v, 0) + +CAMLprim value ocaml_theora_encode_init(value info, value params, + value comments) { + CAMLparam3(info, params, comments); + CAMLlocal2(ans, c); + enc_state_t *state = malloc(sizeof(enc_state_t)); + th_info_init(&state->ti); + info_of_val(info, &state->ti); + th_comment_init(&state->tc); + int i; + for (i = 0; i < Wosize_val(comments); i++) + th_comment_add_tag(&state->tc, + (char *)Bytes_val(Field(Field(comments, i), 0)), + (char *)Bytes_val(Field(Field(comments, i), 1))); + state->ts = th_encode_alloc(&state->ti); + if (state->ts == NULL) { + th_info_clear(&state->ti); + th_comment_clear(&state->tc); + free(state); + check_err(TH_EINVAL); + } + state->granulepos = 0; + state->packetno = 0; + + /* Apply settings */ + int j = 0; + int v; + c = Field(params, j++); + if (c != Val_none) { + v = Int_val(Some_val(c)); + check_err(th_encode_ctl(state->ts, TH_ENCCTL_SET_KEYFRAME_FREQUENCY_FORCE, + &v, sizeof(int))); + } + c = Field(params, j++); + if (c != Val_none) { + v = 0; + if (Some_val(c) == Val_true) + v = 1; + check_err(th_encode_ctl(state->ts, TH_ENCCTL_SET_VP3_COMPATIBLE, &v, + sizeof(int))); + } + c = Field(params, j++); + if (c != Val_none) { + if (Some_val(c) == Val_true) { + v = TH_RATECTL_CAP_UNDERFLOW; + check_err( + th_encode_ctl(state->ts, TH_ENCCTL_SET_RATE_FLAGS, &v, sizeof(int))); + } + } + c = Field(params, j++); + if (c != Val_none) { + v = Int_val(Some_val(c)); + check_err( + th_encode_ctl(state->ts, TH_ENCCTL_SET_RATE_BUFFER, &v, sizeof(int))); + } + c = Field(params, j++); + if (c != Val_none) { + v = Int_val(Some_val(c)); + check_err(th_encode_ctl(state->ts, TH_ENCCTL_SET_SPLEVEL, &v, sizeof(int))); + } + + ans = caml_alloc_custom(&enc_state_ops, sizeof(enc_state_t *), 1, 0); + Theora_enc_state_val(ans) = state; + + CAMLreturn(ans); +} + +CAMLprim value ocaml_theora_encoder_frame_of_granulepos(value t_state, + value gpos) { + CAMLparam2(t_state, gpos); + enc_state_t *state = Theora_enc_state_val(t_state); + CAMLreturn(caml_copy_int64(th_granule_frame(state->ts, Int64_val(gpos)))); +} + +CAMLprim value ocaml_theora_encode_header(value t_state, value o_stream_state) { + CAMLparam2(t_state, o_stream_state); + enc_state_t *state = Theora_enc_state_val(t_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_packet op; + int ret; + + ret = th_encode_flushheader(state->ts, &state->tc, &op); + if (ret < 0) + check_err(ret); + if (ret == 0) + CAMLreturn(Val_true); + else { + state->granulepos = op.granulepos; + state->packetno = op.packetno; + ogg_stream_packetin(os, &op); + CAMLreturn(Val_false); + } +} + +CAMLprim value ocaml_theora_encode_buffer(value t_state, value o_stream_state, + value frame) { + CAMLparam3(t_state, o_stream_state, frame); + CAMLlocal1(v); + enc_state_t *state = Theora_enc_state_val(t_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + th_ycbcr_buffer yb; + ogg_packet op; + int ret = 1; + if (ogg_stream_eos(os)) + caml_raise_constant(*caml_named_value("theora_exn_end_of_file")); + + /* Encode the theora packet. */ + yuv_of_val(frame, yb); + + caml_enter_blocking_section(); + ret = th_encode_ycbcr_in(state->ts, yb); + caml_leave_blocking_section(); + if (ret != 0) + /* TODO: + * \retval OC_EINVAL Encoder is not ready, or is finished. + * \retval -1 The size of the given frame differs from those previously + * input */ + check_err(ret); + + ret = 1; + while (ret > 0) { + ret = th_encode_packetout(state->ts, 0, &op); + if (ret > 0) { + state->granulepos = op.granulepos; + state->packetno = op.packetno; + ogg_stream_packetin(os, &op); + } + } + if (ret < 0) + check_err(ret); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_theora_encode_eos(value t_state, value o_stream_state) { + CAMLparam2(t_state, o_stream_state); + enc_state_t *state = Theora_enc_state_val(t_state); + ogg_stream_state *os = Stream_state_val(o_stream_state); + ogg_packet op; + int ret; + ogg_int64_t iframe; + ogg_int64_t pframe; + + /* TODO: a proper eos should be acheived using an empty ogg page with the + * eos marker.. */ + + /* Try to grab a packet */ + ret = th_encode_packetout(state->ts, 1, &op); + if (ret <= 0) { + check_err(ret); + /* No packet was produced: we bake our own ! */ + op.packet = (unsigned char *)NULL; + op.bytes = 0; + op.b_o_s = 0; + op.e_o_s = 1; + /* Set the granulepos as a new frame */ + iframe = state->granulepos >> state->ti.keyframe_granule_shift; + pframe = state->granulepos & ~iframe; + op.granulepos = (iframe << state->ti.keyframe_granule_shift) | (pframe + 1); + op.packetno = state->packetno + 1; + } + ogg_stream_packetin(os, &op); + + CAMLreturn(Val_unit); +} + +/** Decoding API **/ + +typedef struct dec_state_t { + th_dec_ctx *ts; + th_info ti; + th_comment tc; + th_setup_info *tsi; + int init; + ogg_packet init_packet; +} dec_state_t; + +#define Theora_dec_state_val(v) (*((dec_state_t **)Data_custom_val(v))) + +static void finalize_dec_state(value s) { + dec_state_t *state = Theora_dec_state_val(s); + if (state->ts != NULL) + th_decode_free(state->ts); + th_info_clear(&state->ti); + th_comment_clear(&state->tc); + if (state->tsi != NULL) + th_setup_free(state->tsi); + free(state); +} + +static struct custom_operations dec_state_ops = { + "ocaml_dec_theora_state", finalize_dec_state, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +CAMLprim value caml_theora_check(value packet) { + CAMLparam1(packet); + ogg_packet *op = Packet_val(packet); + + th_info ti; + th_comment tc; + th_setup_info *tsi = NULL; + th_comment_init(&tc); + th_info_init(&ti); + int ret; + + ret = th_decode_headerin(&ti, &tc, &tsi, op); + + th_comment_clear(&tc); + th_info_clear(&ti); + if (tsi != NULL) + th_setup_free(tsi); + + if (ret > 0) + CAMLreturn(Val_true); + else + CAMLreturn(Val_false); +} + +CAMLprim value ocaml_theora_create_dec(value unit) { + CAMLparam0(); + CAMLlocal1(ret); + dec_state_t *state = malloc(sizeof(dec_state_t)); + if (state == NULL) + caml_raise_out_of_memory(); + th_comment_init(&state->tc); + th_info_init(&state->ti); + state->ts = NULL; + state->tsi = NULL; + state->init_packet.packet = NULL; + ret = caml_alloc_custom(&dec_state_ops, sizeof(dec_state_t *), 1, 0); + Theora_dec_state_val(ret) = state; + + CAMLreturn(ret); +} + +CAMLprim value ocaml_theora_dec_headerin(value decoder, value packet) { + CAMLparam1(packet); + CAMLlocal4(ret, t, comment, tmp); + dec_state_t *state = Theora_dec_state_val(decoder); + ogg_packet *op = Packet_val(packet); + int v; + + v = th_decode_headerin(&state->ti, &state->tc, &state->tsi, op); + if (v < 0) + caml_raise_constant(*caml_named_value("theora_exn_inval")); + + if (v == 0) { + /* Keep this packet for the first YUV decoding.. */ + memcpy(&state->init_packet, op, sizeof(ogg_packet)); + state->init = 1; + comment = caml_alloc_tuple(state->tc.comments + 1); + Store_field(comment, 0, caml_copy_string(state->tc.vendor)); + if (state->tc.comments) { + int i; + int len; + for (i = 0; i < state->tc.comments; i++) { + if (state->tc.user_comments[i]) { + len = state->tc.comment_lengths[i]; + tmp = caml_alloc_string(len); + memcpy(Bytes_val(tmp), state->tc.user_comments[i], len); + Store_field(comment, i + 1, tmp); + } + } + } + state->ts = th_decode_alloc(&state->ti, state->tsi); + ret = caml_alloc_tuple(2); + Store_field(ret, 0, val_of_info(&state->ti)); + Store_field(ret, 1, comment); + + CAMLreturn(ret); + } else { + caml_raise_constant(*caml_named_value("theora_exn_not_enough_data")); + } +} + +CAMLprim value ocaml_theora_decode_YUVout(value decoder, value _os) { + CAMLparam2(decoder, _os); + ogg_stream_state *os = Stream_state_val(_os); + dec_state_t *state = Theora_dec_state_val(decoder); + th_ycbcr_buffer yb; + ogg_packet op; + int ret; + + if (state->init != 1) { + ret = ogg_stream_packetout(os, &op); + if (ret == 0) + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + /* TODO: use the third argument (granulepos of the decoded packet) */ + check_err(th_decode_packetin(state->ts, &op, NULL)); + } else { + check_err(th_decode_packetin(state->ts, &state->init_packet, NULL)); + state->init = 0; + } + + caml_enter_blocking_section(); + th_decode_ycbcr_out(state->ts, yb); + caml_leave_blocking_section(); + + CAMLreturn(val_of_yuv(yb)); +} + +CAMLprim value ocaml_theora_decoder_frame_of_granulepos(value t_state, + value gpos) { + CAMLparam2(t_state, gpos); + dec_state_t *state = Theora_dec_state_val(t_state); + CAMLreturn(caml_copy_int64(th_granule_frame(state->ts, Int64_val(gpos)))); +} + +/* Ogg skeleton interface */ + +/* Wrappers */ +static void write32le(unsigned char *ptr, ogg_uint32_t v) { + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; +} + +static void write64le(unsigned char *ptr, ogg_int64_t v) { + ogg_uint32_t hi = v >> 32; + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; + ptr[4] = hi & 0xff; + ptr[5] = (hi >> 8) & 0xff; + ptr[6] = (hi >> 16) & 0xff; + ptr[7] = (hi >> 24) & 0xff; +} + +/* Values from http://xiph.org/ogg/doc/skeleton.html */ +#define FISBONE_IDENTIFIER "fisbone\0" +#define FISBONE_MESSAGE_HEADER_OFFSET 44 +#define FISBONE_SIZE 52 + +/* Code from theorautils.c in ffmpeg2theora */ +CAMLprim value ocaml_theora_skeleton_fisbone(value serial, value info, + value start, value content) { + CAMLparam4(serial, info, start, content); + CAMLlocal1(packet); + ogg_packet op; + th_info ti; + info_of_val(info, &ti); + int len = FISBONE_SIZE + caml_string_length(content); + + memset(&op, 0, sizeof(op)); + op.packet = malloc(len); + if (op.packet == NULL) + caml_raise_out_of_memory(); + + memset(op.packet, 0, len); + /* it will be the fisbone packet for the theora video */ + memcpy(op.packet, FISBONE_IDENTIFIER, 8); /* identifier */ + write32le( + op.packet + 8, + FISBONE_MESSAGE_HEADER_OFFSET); /* offset of the message header fields */ + write32le(op.packet + 12, + Nativeint_val(serial)); /* serialno of the theora stream */ + write32le(op.packet + 16, 3); /* number of header packets */ + /* granulerate, temporal resolution of the bitstream in samples/microsecond */ + write64le(op.packet + 20, + (ogg_int64_t)ti.fps_numerator); /* granulrate numerator */ + write64le(op.packet + 28, + (ogg_int64_t)ti.fps_denominator); /* granulrate denominator */ + write64le(op.packet + 36, (ogg_int64_t)Int64_val(start)); /* start granule */ + write32le(op.packet + 44, 0); /* preroll, for theora its 0 */ + *(op.packet + 48) = ti.keyframe_granule_shift; /* granule shift */ + memcpy(op.packet + FISBONE_SIZE, String_val(content), + caml_string_length(content)); /* message header field */ + + op.b_o_s = 0; + op.e_o_s = 0; + op.bytes = len; + + packet = value_of_packet(&op); + free(op.packet); + CAMLreturn(packet); +} diff --git a/vorbis.opam b/vorbis.opam new file mode 100644 index 0000000..e921340 --- /dev/null +++ b/vorbis.opam @@ -0,0 +1,33 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "Bindings to libvorbis" +maintainer: ["The Savonet Team "] +authors: ["The Savonet Team "] +license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/savonet/ocaml-xiph" +bug-reports: "https://github.com/savonet/ocaml-xiph/issues" +depends: [ + "conf-libvorbis" + "conf-pkg-config" + "ocaml" {>= "4.03.0"} + "dune" {>= "2.8"} + "dune-configurator" + "ogg" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/savonet/ocaml-xiph.git" diff --git a/vorbis/config/discover.ml b/vorbis/config/discover.ml new file mode 100644 index 0000000..6d18f26 --- /dev/null +++ b/vorbis/config/discover.ml @@ -0,0 +1,19 @@ +module C = Configurator.V1 + +let () = + C.main ~name:"vorbis-pkg-config" (fun c -> + let default : C.Pkg_config.package_conf = + { libs = ["-lvorbis"; "-lvorbisfile"; "-lvorbisenc"]; cflags = [] } + in + let conf = + match C.Pkg_config.get c with + | None -> default + | Some pc -> ( + match + C.Pkg_config.query pc ~package:"vorbis vorbisfile vorbisenc" + with + | None -> default + | Some deps -> deps) + in + C.Flags.write_sexp "c_flags.sexp" conf.cflags; + C.Flags.write_sexp "c_library_flags.sexp" conf.libs) diff --git a/vorbis/config/dune b/vorbis/config/dune new file mode 100644 index 0000000..21a5f9a --- /dev/null +++ b/vorbis/config/dune @@ -0,0 +1,3 @@ +(executable + (name discover) + (libraries dune.configurator)) diff --git a/vorbis/dune b/vorbis/dune new file mode 100644 index 0000000..adf9113 --- /dev/null +++ b/vorbis/dune @@ -0,0 +1,25 @@ +(library + (name vorbis) + (public_name vorbis) + (synopsis "OCaml bindings for libvorbis") + (libraries ogg) + (modules vorbis) + (foreign_stubs + (language c) + (names vorbis_stubs) + (flags + (:include c_flags.sexp))) + (c_library_flags + (:include c_library_flags.sexp))) + +(library + (name vorbis_decoder) + (public_name vorbis.decoder) + (synopsis "Vorbis decoder for the ogg-decoder library") + (libraries ogg.decoder vorbis) + (modules vorbis_decoder)) + +(rule + (targets c_flags.sexp c_library_flags.sexp) + (action + (run ./config/discover.exe))) diff --git a/vorbis/vorbis.ml b/vorbis/vorbis.ml new file mode 100644 index 0000000..cdc1a64 --- /dev/null +++ b/vorbis/vorbis.ml @@ -0,0 +1,315 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-vorbis. + * + * Ocaml-vorbis is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-vorbis 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-vorbis; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** + * Decode from or encode to the Ogg Vorbis compressed audio format; or get + * informations about an Ogg Vorbis file. + * + * @author Samuel Mimram + *) + +(* $Id$ *) + +exception Invalid_parameters +exception Invalid_channels +exception Could_not_open_file +exception Not_vorbis +exception Hole_in_data +exception Bad_link +exception Version_mismatch +exception Bad_header +exception Read_error +exception Internal_fault +exception Invalid_argument +exception Not_implemented +exception Unknown_error of int +exception Not_audio +exception False +exception Utf8_failure of string + +(* New register exception printer *) +let string_of_exc e = + let f s = Some s in + match e with + | Invalid_parameters -> f "Invalid vorbis parameters" + | Invalid_channels -> f "Invalid vorbis channels" + | Could_not_open_file -> f "Vorbis: could not open file" + | Not_vorbis -> f "Bitstream is not Vorbis data" + | Hole_in_data -> + f + "Interruption in the vorbis data (one of: garbage between pages, \ + loss of sync followed by recapture, or a corrupt page)" + | Bad_link -> + f + "An invalid vorbis stream section was supplied, or the requested \ + link is corrupt" + | Version_mismatch -> f "Vorbis bitstream version mismatch" + | Bad_header -> f "Invalid Vorbis bitstream header" + | Read_error -> f "Vorbis: read error" + | Internal_fault -> + f + "Internal vorbis logic fault; indicates a bug or heap/stack \ + corruption" + | Invalid_argument -> + f "Invalid vorbis setup request, e.g. out of range argument" + | Not_implemented -> + f + "Unimplemented vorbis feature (e.g. -0.2 quality is only available \ + in aoTuV's implementation)" + | Unknown_error i -> + f + (Printf.sprintf + "Unknown vorbis error %i (it should not have happened, please \ + report)" + i) + | Not_audio -> f "Ogg packet doesn't contain audio data" + | False -> + f + "Vorbis call returned a 'false' status (eg, playback is not in \ + progress, and thus there is no instantaneous bitrate information to \ + report.)" + | Utf8_failure s -> f (Printf.sprintf "UTF8 failure in string: %S" s) + | _ -> None + +let () = Printexc.register_printer string_of_exc + +let _ = + Callback.register_exception "vorbis_exn_invalid_parameters" Invalid_parameters; + Callback.register_exception "vorbis_exn_invalid_channels" Invalid_channels; + Callback.register_exception "vorbis_exn_could_not_open_file" + Could_not_open_file; + Callback.register_exception "vorbis_exn_not_vorbis" Not_vorbis; + Callback.register_exception "vorbis_exn_hole_in_data" Hole_in_data; + Callback.register_exception "vorbis_exn_bad_link" Bad_link; + Callback.register_exception "vorbis_exn_version_mismatch" Version_mismatch; + Callback.register_exception "vorbis_exn_bad_header" Bad_header; + Callback.register_exception "vorbis_exn_read_error" Read_error; + Callback.register_exception "vorbis_exn_internal_fault" Internal_fault; + Callback.register_exception "vorbis_exn_invalid" Invalid_argument; + Callback.register_exception "vorbis_exn_not_implemented" Not_implemented; + Callback.register_exception "vorbis_exn_not_audio" Not_audio; + Callback.register_exception "vorbis_exn_unknown_error" (Unknown_error 0); + Callback.register_exception "vorbis_exn_false" False; + Callback.register_exception "vorbis_exn_utf8_failure" (Utf8_failure "") + +let tags m () = + let ans = ref [] in + let add t v = ans := (t, v) :: !ans in + Hashtbl.iter add m; + List.rev !ans + +let encoder_tag = "ocaml-vorbis by the savonet team (http://savonet.sf.net/)" + +module Encoder = struct + type t + + external create : int -> int -> int -> int -> int -> t + = "ocaml_vorbis_analysis_init" + + external create_vbr : int -> int -> float -> t + = "ocaml_vorbis_analysis_init_vbr" + + external reset : t -> unit = "ocaml_vorbis_reset" + + external headerout_packetout : + t -> + (string * string) array -> + Ogg.Stream.packet * Ogg.Stream.packet * Ogg.Stream.packet + = "ocaml_vorbis_analysis_headerout" + + let headerout_packetout ?(encoder = encoder_tag) state tags = + let tags = Array.of_list (tags @ [("ENCODER", encoder)]) in + headerout_packetout state tags + + let headerout ?encoder state os tags = + let p1, p2, p3 = headerout_packetout ?encoder state tags in + Ogg.Stream.put_packet os p1; + Ogg.Stream.put_packet os p2; + Ogg.Stream.put_packet os p3 + + external get_channels : t -> int = "ocaml_vorbis_encode_get_channels" + + external encode_buffer_float : + t -> Ogg.Stream.stream -> float array array -> int -> int -> unit + = "ocaml_vorbis_encode_float" + + external encode_buffer_float_ba : + t -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + unit = "ocaml_vorbis_encode_float_ba" + + external time_of_granulepos : t -> Int64.t -> Nativeint.t + = "ocaml_vorbis_encode_time_of_granulepos" + + (* We encode a buffer with 0 samples to finish + * the stream, according to the documentation of + * vorbis_analysis_wrote: + * "A value of zero means all input data has been provided and + * the compressed stream should be finalized." *) + let end_of_stream enc os = + let chans = get_channels enc in + let data = Array.make chans [||] in + encode_buffer_float enc os data 0 0 +end + +let split_comment comment = + try + let equal_pos = String.index_from comment 0 '=' in + let c1 = String.uppercase_ascii (String.sub comment 0 equal_pos) in + let c2 = + String.sub comment (equal_pos + 1) (String.length comment - equal_pos - 1) + in + (c1, c2) + with Not_found -> (comment, "") + +type bitstream = int + +type info = { + vorbis_version : int; + audio_channels : int; + audio_samplerate : int; + bitrate_upper : int; + bitrate_nominal : int; + bitrate_lower : int; + bitrate_window : int; +} + +module File = struct + module Decoder = struct + type t + + external create : + (int -> string * int) -> + (int -> Unix.seek_command -> int) -> + (unit -> int) -> + t = "ocaml_vorbis_open_dec_stream" + + let openfile_with_fd fd = + try + create + (fun n -> + let buf = Bytes.create n in + let r = Unix.read fd buf 0 n in + (Bytes.unsafe_to_string buf, r)) + (fun n cmd -> Unix.lseek fd n cmd) + (fun () -> Unix.lseek fd 0 Unix.SEEK_CUR) + with e -> + Unix.close fd; + raise e + + let openfile f = + let fd = Unix.openfile f [Unix.O_RDONLY] 0o400 in + (openfile_with_fd fd, fd) + + external decode_float : t -> float array array -> int -> int -> int + = "ocaml_vorbis_decode_float" + + external decode_float_alloc : t -> int -> float array array + = "ocaml_vorbis_decode_float_alloc" + + external decode_float_ba : + t -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int = "ocaml_vorbis_decode_float_ba" + + external decode_float_alloc_ba : + t -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array + = "ocaml_vorbis_decode_float_alloc_ba" + + external decode : t -> bool -> int -> bool -> bytes -> int -> int -> int + = "ocaml_vorbis_decode_byte" "ocaml_vorbis_decode" + + let decode df ?(big_endian = false) ?(sample_size = 2) ?(signed = true) buf + ofs len = + decode df big_endian sample_size signed buf ofs len + + external bitstream : t -> int = "ocaml_vorbis_get_dec_file_bitstream" + + external comments : t -> int -> string * string array + = "ocaml_vorbis_get_dec_file_comments" + + let comments df bitstream = + let vd, cmts = comments df bitstream in + (vd, Array.to_list (Array.map split_comment cmts)) + + external info : t -> int -> info = "ocaml_vorbis_decoder_info" + external bitrate : t -> int -> int = "ocaml_vorbis_decoder_bitrate" + external duration : t -> int -> float = "ocaml_vorbis_decoder_time_total" + external streams : t -> int = "ocaml_vorbis_decoder_streams" + + external serialnumber : t -> int -> int + = "ocaml_vorbis_decoder_serialnumber" + + external samples : t -> int -> int = "ocaml_vorbis_decoder_pcm_total" + end +end + +module Decoder = struct + type t + + external init : + Ogg.Stream.packet -> Ogg.Stream.packet -> Ogg.Stream.packet -> t + = "ocaml_vorbis_synthesis_init" + + external info : t -> info = "ocaml_vorbis_val_info_of_decoder" + + external comments : t -> string * string array + = "ocaml_vorbis_val_comments_of_decoder" + + let comments dec = + let vend, cmts = comments dec in + (vend, Array.to_list (Array.map split_comment cmts)) + + external check_packet : Ogg.Stream.packet -> bool + = "ocaml_vorbis_check_packet" + + external decode_pcm : + t -> Ogg.Stream.stream -> float array array -> int -> int -> int + = "ocaml_vorbis_decode_pcm" + + external decode_pcm_ba : + t -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int = "ocaml_vorbis_decode_pcm_ba" + + external restart : t -> unit = "ocaml_vorbis_synthesis_restart" +end + +module Skeleton = struct + external fisbone : + Nativeint.t -> Int64.t -> Int64.t -> string -> Ogg.Stream.packet + = "ocaml_vorbis_skeleton_fisbone" + + let fisbone ?(start_granule = Int64.zero) + ?(headers = [("Content-type", "audio/vorbis")]) ~serialno ~samplerate () = + let concat s (h, v) = Printf.sprintf "%s%s: %s\r\n" s h v in + let s = List.fold_left concat "" headers in + fisbone serialno samplerate start_granule s +end diff --git a/vorbis/vorbis.mli b/vorbis/vorbis.mli new file mode 100644 index 0000000..f931532 --- /dev/null +++ b/vorbis/vorbis.mli @@ -0,0 +1,324 @@ +(* + * Copyright 2003-2011 The Savonet team + * + * This file is part of Ocaml-vorbis. + * + * Ocaml-vorbis is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-vorbis 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-vorbis; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** + * Decode from or encode to the Ogg Vorbis compressed audio format; + * or get informations about an Ogg Vorbis file. + * + * @author Samuel Mimram, Julien Cristau, David Baelde + *) + +(* $Id$ *) + +(** {1 Exceptions} *) + +(** The call returned a 'false' status (eg, ov_bitrate_instant + * can return OV_FALSE if playback is not in progress, and thus + * there is no instantaneous bitrate information to report. *) +exception False + +(** Some parameters are invalid for this function. *) +exception Invalid_parameters + +(** The given number of channels is invalid. *) +exception Invalid_channels + +(** Invalid setup request, e.g. out of range argument. *) +exception Invalid_argument + +(** The given file could not be opened. *) +exception Could_not_open_file + +(** Bitstream is not Vorbis data. *) +exception Not_vorbis + +(** Invalid Vorbis bitstream header. *) +exception Bad_header + +(** A read from media returned an error. *) +exception Read_error + +(** Ogg packet doesn't contain audio data *) +exception Not_audio + +(** Internal logic fault; indicates a bug or heap/stack corruption. *) +exception Internal_fault + +(** Indicates there was an interruption in the data (one of: garbage between + * pages, loss of sync followed by recapture, or a corrupt page). *) +exception Hole_in_data + +(** Indicates that an invalid stream section was supplied, + * or the requested link is corrupt. *) +exception Bad_link + +(** Invalid Vorbis bitstream header. *) +exception Version_mismatch + +(** Unimplemented mode. *) +exception Not_implemented + +(** An unknown error happened (it should not have happened, please report). *) +exception Unknown_error of int + +(** Error while converting utf8. *) +exception Utf8_failure of string + +(** Return a string representation + * of an exception *) +val string_of_exc : exn -> string option + +(** {1 Useful types} *) + +(** Index of a logical bitstream. The special value -1 means the physical + * bitsream. + *) +type bitstream = int + +(** Vorbis informations about a file. *) +type info = { + vorbis_version : int; (** version of vorbis codec, must be 0 *) + audio_channels : int; (** number of audio channels *) + audio_samplerate : int; (** samplerate in Hertz *) + bitrate_upper : int; + bitrate_nominal : int; + bitrate_lower : int; + bitrate_window : int; +} + +(** Create a list of vorbis tags. *) +val tags : (string, string) Hashtbl.t -> unit -> (string * string) list + +(** {1 Operations with vorbis streams} *) + +(** {2 Encoding} *) + +module Encoder : sig + (** Internal state of an encoder. *) + type t + + (** [create chans rate max_br nom_br min_br] creates a new encoder with + * [chans] channels, with sample rate [rate] Hz and with respectively [max_br], + * [nom_br] and [min_br] as maximal, nominal and minimal bitrates (in bps). + *) + val create : int -> int -> int -> int -> int -> t + + (** [create_vbr chans rate quality] creates a new encoder in variable bitrate + * with [chans] channels, with sample rate [rate] Hz and with quality + * [quality], which should be between -1 and 1 (1 is the best). + *) + val create_vbr : int -> int -> float -> t + + val reset : t -> unit + + (** Encode a header given a list of tags. *) + val headerout : + ?encoder:string -> t -> Ogg.Stream.stream -> (string * string) list -> unit + + (** Encoder a header, but do not submit packet to + * Ogg Stream. Usefull when multiplexing ogg streams + * since the all first packets of each streams must be packed + * in the initial pages. *) + val headerout_packetout : + ?encoder:string -> + t -> + (string * string) list -> + Ogg.Stream.packet * Ogg.Stream.packet * Ogg.Stream.packet + + (** Get the number of audio channels expected by + * the encoder. *) + val get_channels : t -> int + + (** Encode a buffer of PCM data. + * The PCM data array must have at least the expected + * number of channels. Otherwise, the function raises [Invalid_channels]. *) + val encode_buffer_float : + t -> Ogg.Stream.stream -> float array array -> int -> int -> unit + + val encode_buffer_float_ba : + t -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + unit + + (** Convert a granulepos to absolute time in seconds. The granulepos is + * interpreted in the context of a given encoder, and gives + * the end time of a frame's presentation as used in Ogg mux ordering. *) + val time_of_granulepos : t -> Int64.t -> Nativeint.t + + val end_of_stream : t -> Ogg.Stream.stream -> unit +end + +(** {2 Decoding} *) + +module Decoder : sig + (** Internal decoder state *) + type t + + (** Initialize decoder. Needs the first 3 packets of the ogg logical + * stream. Use [check_packet] to check against the first one. *) + val init : Ogg.Stream.packet -> Ogg.Stream.packet -> Ogg.Stream.packet -> t + + (** Get vorbis infos from the decoder *) + val info : t -> info + + (** Get vorbis comments from the decoder *) + val comments : t -> string * (string * string) list + + (** Check wether a ogg packet contains vorbis data. + * Usefull for parsing ogg containers with multiple streams. *) + val check_packet : Ogg.Stream.packet -> bool + + (** [decode_pcm dec stream buffer pos offset] decodes pcm float data + * from [stream]. The floats are written in [buffer], starting at + * position [pos]. The function returns the number of samples actually written.*) + val decode_pcm : + t -> Ogg.Stream.stream -> float array array -> int -> int -> int + + (** [decode_pcm_ba dec stream buffer pos offset] decodes pcm float data + * from [stream]. The floats are written in [buffer], starting at + * position [pos]. The function returns the number of samples actually written.*) + val decode_pcm_ba : + t -> + Ogg.Stream.stream -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int + + (** Restart the decoder *) + val restart : t -> unit +end + +(** {1 Operations with vorbis files} *) + +(** {2 Decoding} *) + +module File : sig + module Decoder : sig + (** Internal state of a decoder. *) + type t + + (** [create read_func seek_func tell_func params] opens a + * stream like [openfile] for decoding but callbacks are used to + * manipulate the data. [read_func] should return the requested amount of bytes + * (or less if it is the end of file), [seek_funk] should return 0 if the seek + * was ok or -1 if the stream is not seekable, [tell_func] should return the current + * offset or -1 if there is no notion of offset in the stream. + * Raises: [Read_error], [Not_vorbis], [Version_mismatch], [Bad_header], [Internal_fault]. + *) + val create : + (int -> string * int) -> + (int -> Unix.seek_command -> int) -> + (unit -> int) -> + t + + (** Open a vorbis file for decoding. *) + val openfile : string -> t * Unix.file_descr + + val openfile_with_fd : Unix.file_descr -> t + + (** [decode_float dec buff ofs len] decodes [len] samples in each channel and puts + * the result in [buff] starting at position [ofs]. + * @raise Hole_in_data if there was an interruption of the data. + * @raise Invalid_parameters if all the data cannot fit in the buffer starting at the given position. + *) + val decode_float : t -> float array array -> int -> int -> int + + val decode_float_alloc : t -> int -> float array array + + (** [decode_float_ba dec buff ofs len] decodes [len] samples in each channel and puts + * the result in [buff] starting at position [ofs]. + * @raise Hole_in_data if there was an interruption of the data. + * @raise Invalid_parameters if all the data cannot fit in the buffer starting at the given position. + *) + val decode_float_ba : + t -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + int -> + int -> + int + + val decode_float_alloc_ba : + t -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array + + (** Same as [decode_float] but decodes to integers. *) + val decode : + t -> + ?big_endian:bool -> + ?sample_size:int -> + ?signed:bool -> + bytes -> + int -> + int -> + int + + (** Get the number of logical bitstreams within a physical bitstream. *) + val streams : t -> int + + (** Get the index of the sequential logical bitstream currently being decoded + * (incremented at chaining boundaries even for non-seekable streams). For + * seekable streams, it represents the actual chaining index within the + * physical bitstream. + *) + val bitstream : t -> bitstream + + (** Get the vorbis comments from a vorbis file. The second argument is the + * number of the logical bitstream (the current bitstream is used if it is set + * to [None]). + *) + val comments : t -> bitstream -> string * (string * string) list + + (** Get the vorbis information from the stream header of a bitstream. *) + val info : t -> bitstream -> info + + (** Get the bitrate of a bitsream (in bps). *) + val bitrate : t -> bitstream -> int + + (** Get the total pcm samples of a bitstream. *) + val samples : t -> bitstream -> int + + (** Get the duration in seconds of a bitstream. *) + val duration : t -> bitstream -> float + + (** Get the serial number of a bitstream. *) + val serialnumber : t -> bitstream -> int + end +end + +module Skeleton : sig + (** Generate a vorbis fisbone packet with + * these parameters, to use in an ogg skeleton. + * Default value for [start_granule] is [Int64.zero], + * Default value for [headers] is ["Content-type","audio/vorbis"] + * + * See: http://xiph.org/ogg/doc/skeleton.html. *) + val fisbone : + ?start_granule:Int64.t -> + ?headers:(string * string) list -> + serialno:Nativeint.t -> + samplerate:Int64.t -> + unit -> + Ogg.Stream.packet +end diff --git a/vorbis/vorbis_decoder.ml b/vorbis/vorbis_decoder.ml new file mode 100644 index 0000000..03887bf --- /dev/null +++ b/vorbis/vorbis_decoder.ml @@ -0,0 +1,106 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-vorbis. + * + * Ocaml-vorbis is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-vorbis 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-vorbis; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + * + *) + +let check = Vorbis.Decoder.check_packet +let buflen = 1024 + +let decoder ~fill:_ os = + let decoder = ref None in + let packet1 = ref None in + let packet2 = ref None in + let packet3 = ref None in + let os = ref os in + let init () = + match !decoder with + | None -> + let packet1 = + match !packet1 with + | None -> + let p = Ogg.Stream.get_packet !os in + packet1 := Some p; + p + | Some p -> p + in + let packet2 = + match !packet2 with + | None -> + let p = Ogg.Stream.get_packet !os in + packet2 := Some p; + p + | Some p -> p + in + let packet3 = + match !packet3 with + | None -> + let p = Ogg.Stream.get_packet !os in + packet3 := Some p; + p + | Some p -> p + in + let d = Vorbis.Decoder.init packet1 packet2 packet3 in + let info = Vorbis.Decoder.info d in + let meta = Vorbis.Decoder.comments d in + decoder := Some (d, info, meta); + (d, info, meta) + | Some d -> d + in + let info () = + let _, info, meta = init () in + ( { + Ogg_decoder.channels = info.Vorbis.audio_channels; + sample_rate = info.Vorbis.audio_samplerate; + }, + meta ) + in + let restart ~fill:_ new_os = + os := new_os; + let d, _, _ = init () in + Vorbis.Decoder.restart d + in + let decode ~decode_pcm ~make_pcm ~sub_pcm feed = + let decoder, info, _ = init () in + let chan _ = make_pcm buflen in + let buf = Array.init info.Vorbis.audio_channels chan in + try + let ret = decode_pcm decoder !os buf 0 buflen in + feed (Array.map (fun x -> sub_pcm x 0 ret) buf) + with (* Apparently, we should hide this one.. *) + | Vorbis.False -> + raise Ogg.Not_enough_data + in + let decoder ~decode_pcm ~make_pcm ~sub_pcm = + { + Ogg_decoder.name = "vorbis"; + info; + decode = decode ~decode_pcm ~make_pcm ~sub_pcm; + restart; + samples_of_granulepos = (fun x -> x); + } + in + Ogg_decoder.Audio_both + ( decoder ~decode_pcm:Vorbis.Decoder.decode_pcm + ~make_pcm:(fun len -> Array.create_float len) + ~sub_pcm:Array.sub, + decoder ~decode_pcm:Vorbis.Decoder.decode_pcm_ba + ~make_pcm:(Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout) + ~sub_pcm:Bigarray.Array1.sub ) + +let register () = Hashtbl.add Ogg_decoder.ogg_decoders "vorbis" (check, decoder) diff --git a/vorbis/vorbis_decoder.mli b/vorbis/vorbis_decoder.mli new file mode 100644 index 0000000..4669a27 --- /dev/null +++ b/vorbis/vorbis_decoder.mli @@ -0,0 +1,25 @@ +(* + * Copyright 2003-2011 Savonet team + * + * This file is part of Ocaml-vorbis. + * + * Ocaml-vorbis is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * Ocaml-vorbis 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-vorbis; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + *) + +(** This module provides a vorbis decoder for + * the [Ogg_demuxer] module. *) + +(** Register the vorbis decoder *) +val register : unit -> unit diff --git a/vorbis/vorbis_stubs.c b/vorbis/vorbis_stubs.c new file mode 100644 index 0000000..6cbc15e --- /dev/null +++ b/vorbis/vorbis_stubs.c @@ -0,0 +1,1158 @@ +/* + * Copyright 2007 Samuel Mimram + * + * This file is part of ocaml-vorbis. + * + * ocaml-vorbis is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * ocaml-vorbis 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Ocaml-vorbis; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + +/* + * Libvorbis bindings for OCaml. + * + * @author Samuel Mimram + */ + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include +#include +#include + +#include +#include +#include +#include + +#include + +#ifndef Bytes_val +#define Bytes_val String_val +#endif + +static inline float clip(float s) { + if (s < -1) { + return -1; + } else if (s > 1) { + return 1; + } else + return s; +} + +static void raise_err(int ret) { + switch (ret) { + case OV_FALSE: + caml_raise_constant(*caml_named_value("vorbis_exn_false")); + + case OV_HOLE: + caml_raise_constant(*caml_named_value("vorbis_exn_hole_in_data")); + + case OV_EREAD: + caml_raise_constant(*caml_named_value("vorbis_exn_read_error")); + + case OV_EFAULT: + caml_raise_constant(*caml_named_value("vorbis_exn_internal_fault")); + + case OV_ENOTVORBIS: + caml_raise_constant(*caml_named_value("vorbis_exn_not_vorbis")); + + case OV_EBADHEADER: + caml_raise_constant(*caml_named_value("vorbis_exn_bad_header")); + + case OV_EVERSION: + caml_raise_constant(*caml_named_value("vorbis_exn_version_mismatch")); + + case OV_EBADLINK: + caml_raise_constant(*caml_named_value("vorbis_exn_bad_link")); + + case OV_EINVAL: + caml_raise_constant(*caml_named_value("vorbis_exn_invalid")); + + case OV_EIMPL: + caml_raise_constant(*caml_named_value("vorbis_exn_not_implemented")); + + case OV_ENOTAUDIO: + caml_raise_constant(*caml_named_value("vorbis_exn_not_audio")); + + default: + caml_raise_with_arg(*caml_named_value("vorbis_exn_unknown_error"), + Val_int(ret)); + } +} + +/**** Decoding *****/ + +typedef struct { + vorbis_dsp_state vd; + vorbis_block vb; + vorbis_info vi; + vorbis_comment vc; +} decoder_t; + +#define Decoder_val(v) (*((decoder_t **)Data_custom_val(v))) +#define Decoder_dsp_state_val(v) (&Decoder_val(v)->vd) +#define Decoder_info_val(v) (&Decoder_val(v)->vi) +#define Comment_val(v) (&Decoder_val(v)->vc) +#define Block_val(v) (&Decoder_val(v)->vb) + +static void finalize_decoder(value e) { + decoder_t *dec = Decoder_val(e); + + vorbis_block_clear(&dec->vb); + vorbis_dsp_clear(&dec->vd); + vorbis_info_clear(&dec->vi); + vorbis_comment_clear(&dec->vc); + free(dec); +} + +static struct custom_operations decoder_ops = { + "ocaml_decoder_t", finalize_decoder, custom_compare_default, + custom_hash_default, custom_serialize_default, custom_deserialize_default}; + +CAMLprim value ocaml_vorbis_val_info_of_decoder(value vorbis_t) { + CAMLparam1(vorbis_t); + CAMLlocal1(v); + int i = 0; + v = caml_alloc_tuple(7); + vorbis_info *vi = Decoder_info_val(vorbis_t); + + Store_field(v, i++, Val_int(vi->version)); + Store_field(v, i++, Val_int(vi->channels)); + Store_field(v, i++, Val_long(vi->rate)); + Store_field(v, i++, Val_long(vi->bitrate_upper)); + Store_field(v, i++, Val_long(vi->bitrate_nominal)); + Store_field(v, i++, Val_long(vi->bitrate_lower)); + Store_field(v, i++, Val_long(vi->bitrate_window)); + + CAMLreturn(v); +} + +CAMLprim value ocaml_vorbis_val_comments_of_decoder(value decoder) { + CAMLparam1(decoder); + CAMLlocal2(ans, cmts); + + int i; + vorbis_comment *vc = Comment_val(decoder); + + cmts = caml_alloc_tuple(vc->comments); + for (i = 0; i < vc->comments; i++) + Store_field(cmts, i, caml_copy_string(vc->user_comments[i])); + ans = caml_alloc_tuple(2); + if (vc->vendor != NULL) + Store_field(ans, 0, caml_copy_string(vc->vendor)); + else + Store_field(ans, 0, caml_copy_string("(null)")); + Store_field(ans, 1, cmts); + + CAMLreturn(ans); +} + +CAMLprim value ocaml_vorbis_check_packet(value packet) { + CAMLparam1(packet); + ogg_packet *op = Packet_val(packet); + vorbis_info vi; + vorbis_comment vc; + vorbis_info_init(&vi); + vorbis_comment_init(&vc); + int ret = 1; + if (vorbis_synthesis_headerin(&vi, &vc, op) < 0) + ret = 0; + vorbis_info_clear(&vi); + vorbis_comment_clear(&vc); + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_synthesis_init(value packet, value packet2, + value packet3) { + CAMLparam3(packet, packet2, packet3); + CAMLlocal1(ans); + ogg_packet *op = Packet_val(packet); + ogg_packet *op2 = Packet_val(packet2); + ogg_packet *op3 = Packet_val(packet3); + int ret; + + decoder_t *vt = malloc(sizeof(decoder_t)); + if (vt == NULL) + caml_raise_out_of_memory(); + + vorbis_info_init(&vt->vi); + vorbis_comment_init(&vt->vc); + + ret = vorbis_synthesis_headerin(&vt->vi, &vt->vc, op); + if (ret < 0) { + vorbis_info_clear(&vt->vi); + vorbis_comment_clear(&vt->vc); + free(vt); + raise_err(ret); + } + ret = vorbis_synthesis_headerin(&vt->vi, &vt->vc, op2); + if (ret < 0) { + vorbis_info_clear(&vt->vi); + vorbis_comment_clear(&vt->vc); + free(vt); + raise_err(ret); + } + ret = vorbis_synthesis_headerin(&vt->vi, &vt->vc, op3); + if (ret < 0) { + vorbis_info_clear(&vt->vi); + vorbis_comment_clear(&vt->vc); + free(vt); + raise_err(ret); + } + + vorbis_synthesis_init(&vt->vd, &vt->vi); + vorbis_block_init(&vt->vd, &vt->vb); + + ans = caml_alloc_custom(&decoder_ops, sizeof(decoder_t *), 1, 0); + Decoder_val(ans) = vt; + + CAMLreturn(ans); +} + +CAMLprim value ocaml_vorbis_decode_pcm(value vorbis_state, value stream_state, + value buf, value _pos, value _len) { + CAMLparam3(vorbis_state, stream_state, buf); + CAMLlocal2(buffer, chan); + ogg_stream_state *os = Stream_state_val(stream_state); + ogg_packet op; + vorbis_block *vb = Block_val(vorbis_state); + vorbis_dsp_state *vd = Decoder_dsp_state_val(vorbis_state); + vorbis_info *vi = Decoder_info_val(vorbis_state); + int pos = Int_val(_pos); + int len = Int_val(_len); + float **pcm; + int samples; + int i, j, ret; + int total_samples = 0; + + while (1) { + while (total_samples < len) { + caml_release_runtime_system(); + samples = vorbis_synthesis_pcmout(vd, &pcm); + caml_acquire_runtime_system(); + + if (samples < 0) + raise_err(samples); + + if (samples == 0) + break; + + if (samples > len - total_samples) + samples = len - total_samples; + + if (Wosize_val(buf) != vi->channels) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_channels")); + + for (i = 0; i < vi->channels; i++) { + chan = Field(buf, i); + if (Wosize_val(chan) / Double_wosize - pos < samples) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid")); + + for (j = 0; j < samples; j++) + Store_double_field(chan, pos + j, clip(pcm[i][j])); + } + + pos += samples; + total_samples += samples; + + caml_release_runtime_system(); + ret = vorbis_synthesis_read(vd, samples); + caml_acquire_runtime_system(); + + if (ret < 0) + raise_err(ret); + } + if (total_samples == len) + CAMLreturn(Val_int(total_samples)); + + caml_release_runtime_system(); + ret = ogg_stream_packetout(os, &op); + caml_acquire_runtime_system(); + + /* returned values are: + * 1: ok + * 0: not enough data. in this case + * we return the number of samples + * decoded if > 0 and raise + * Ogg_not_enough_data otherwise + * -1: out of sync */ + if (ret == 0) { + if (total_samples > 0) + CAMLreturn(Val_int(total_samples)); + else + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + } + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + caml_release_runtime_system(); + ret = vorbis_synthesis(vb, &op); + caml_acquire_runtime_system(); + + if (ret == 0) { + caml_release_runtime_system(); + ret = vorbis_synthesis_blockin(vd, vb); + caml_acquire_runtime_system(); + } + + if (ret < 0) + raise_err(ret); + } + + CAMLreturn(Val_int(total_samples)); +} + +CAMLprim value ocaml_vorbis_decode_pcm_ba(value vorbis_state, + value stream_state, value buf, + value _pos, value _len) { + CAMLparam3(vorbis_state, stream_state, buf); + CAMLlocal2(buffer, chan); + ogg_stream_state *os = Stream_state_val(stream_state); + ogg_packet op; + vorbis_block *vb = Block_val(vorbis_state); + vorbis_dsp_state *vd = Decoder_dsp_state_val(vorbis_state); + vorbis_info *vi = Decoder_info_val(vorbis_state); + int pos = Int_val(_pos); + int len = Int_val(_len); + float **pcm; + int samples; + int i, j, ret; + int total_samples = 0; + + while (1) { + while (total_samples < len) { + caml_release_runtime_system(); + samples = vorbis_synthesis_pcmout(vd, &pcm); + caml_acquire_runtime_system(); + + if (samples < 0) + raise_err(samples); + + if (samples == 0) + break; + + if (samples > len - total_samples) + samples = len - total_samples; + + if (Wosize_val(buf) != vi->channels) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_channels")); + + for (i = 0; i < vi->channels; i++) { + chan = Field(buf, i); + if (Caml_ba_array_val(chan)->dim[0] - pos < samples) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid")); + + for (j = 0; j < samples; j++) + ((float *)Caml_ba_data_val(chan))[pos + j] = clip(pcm[i][j]); + } + pos += samples; + total_samples += samples; + + caml_release_runtime_system(); + ret = vorbis_synthesis_read(vd, samples); + caml_acquire_runtime_system(); + + if (ret < 0) + raise_err(ret); + } + + if (total_samples == len) + CAMLreturn(Val_int(total_samples)); + + caml_release_runtime_system(); + ret = ogg_stream_packetout(os, &op); + caml_acquire_runtime_system(); + + /* returned values are: + * 1: ok + * 0: not enough data. in this case + * we return the number of samples + * decoded if > 0 and raise + * Ogg_not_enough_data otherwise + * -1: out of sync */ + if (ret == 0) { + if (total_samples > 0) + CAMLreturn(Val_int(total_samples)); + else + caml_raise_constant(*caml_named_value("ogg_exn_not_enough_data")); + } + if (ret == -1) + caml_raise_constant(*caml_named_value("ogg_exn_out_of_sync")); + + caml_release_runtime_system(); + ret = vorbis_synthesis(vb, &op); + caml_acquire_runtime_system(); + + if (ret == 0) { + caml_release_runtime_system(); + ret = vorbis_synthesis_blockin(vd, vb); + caml_acquire_runtime_system(); + } + + if (ret < 0) + raise_err(ret); + } + + CAMLreturn(Val_int(total_samples)); +} + +CAMLprim value ocaml_vorbis_synthesis_restart(value s) { + CAMLparam1(s); + vorbis_synthesis_restart(Decoder_dsp_state_val(s)); + CAMLreturn(Val_unit); +} + +/***** Encoding *****/ + +typedef struct { + vorbis_dsp_state vd; + vorbis_block vb; + vorbis_info vi; + ogg_packet op; +} encoder_t; + +#define Encoder_val(v) (*((encoder_t **)Data_custom_val(v))) +#define Enc_dsp_state_val(v) (&Encoder_val(v)->vd) + +static void finalize_encoder(value e) { + encoder_t *enc = Encoder_val(e); + + vorbis_block_clear(&enc->vb); + vorbis_dsp_clear(&enc->vd); + vorbis_info_clear(&enc->vi); + free(enc); +} + +static struct custom_operations encoder_ops = { + "ocaml_vorbis_encoder", finalize_encoder, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +CAMLprim value ocaml_vorbis_analysis_init(value channels, value rate, + value max_bitrate, + value nominal_bitrate, + value min_bitrate) { + encoder_t *enc = malloc(sizeof(encoder_t)); + value ans; + int err; + + vorbis_info_init(&enc->vi); + err = vorbis_encode_init(&enc->vi, Int_val(channels), Int_val(rate), + Int_val(max_bitrate), Int_val(nominal_bitrate), + Int_val(min_bitrate)); + if (err) { + vorbis_info_clear(&enc->vi); + raise_err(err); + } + vorbis_analysis_init(&enc->vd, &enc->vi); + vorbis_block_init(&enc->vd, &enc->vb); + ans = caml_alloc_custom(&encoder_ops, sizeof(encoder_t *), 1, 0); + Encoder_val(ans) = enc; + + return ans; +} + +CAMLprim value ocaml_vorbis_analysis_init_vbr(value channels, value rate, + value quality) { + encoder_t *enc = malloc(sizeof(encoder_t)); + value ans; + int err; + + vorbis_info_init(&enc->vi); + err = vorbis_encode_init_vbr(&enc->vi, Int_val(channels), Int_val(rate), + Double_val(quality)); + if (err) { + vorbis_info_clear(&enc->vi); + raise_err(err); + } + vorbis_analysis_init(&enc->vd, &enc->vi); + vorbis_block_init(&enc->vd, &enc->vb); + ans = caml_alloc_custom(&encoder_ops, sizeof(encoder_t *), 1, 0); + Encoder_val(ans) = enc; + + return ans; +} + +CAMLprim value ocaml_vorbis_reset(value vdsp) { + encoder_t *enc = Encoder_val(vdsp); + + vorbis_block_clear(&enc->vb); + vorbis_dsp_clear(&enc->vd); + vorbis_info_clear(&enc->vi); + + vorbis_analysis_init(&enc->vd, &enc->vi); + vorbis_block_init(&enc->vd, &enc->vb); + + return Val_unit; +} + +CAMLprim value ocaml_vorbis_analysis_headerout(value vdsp, value comments) { + CAMLparam2(vdsp, comments); + CAMLlocal4(ret, p1, p2, p3); + vorbis_dsp_state *vd = Enc_dsp_state_val(vdsp); + + vorbis_comment vc; + ogg_packet header, header_comm, header_code; + int i; + + vorbis_comment_init(&vc); + for (i = 0; i < Wosize_val(comments); i++) + vorbis_comment_add_tag(&vc, String_val(Field(Field(comments, i), 0)), + String_val(Field(Field(comments, i), 1))); + vorbis_analysis_headerout(vd, &vc, &header, &header_comm, &header_code); + vorbis_comment_clear(&vc); + + ret = caml_alloc_tuple(3); + Store_field(ret, 0, value_of_packet(&header)); + Store_field(ret, 1, value_of_packet(&header_comm)); + Store_field(ret, 2, value_of_packet(&header_code)); + + CAMLreturn(ret); +} + +CAMLprim value ocaml_vorbis_encode_get_channels(value vdsp) { + CAMLparam1(vdsp); + encoder_t *enc = Encoder_val(vdsp); + CAMLreturn(Val_int(enc->vi.channels)); +} + +CAMLprim value ocaml_vorbis_encode_float(value vdsp, value vogg, value data, + value _offs, value _len) { + CAMLparam3(vdsp, vogg, data); + encoder_t *enc = Encoder_val(vdsp); + vorbis_block *vb = &enc->vb; + vorbis_dsp_state *vd = Enc_dsp_state_val(vdsp); + ogg_stream_state *os = Stream_state_val(vogg); + ogg_packet *op = &enc->op; + int offs = Int_val(_offs); + int len = Int_val(_len); + float **vorbis_buffer; + int c, i; + value datac; + int channels = enc->vi.channels; + + if (Wosize_val(data) != channels) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_channels")); + + vorbis_buffer = vorbis_analysis_buffer(vd, len); + for (c = 0; c < channels; c++) { + datac = Field(data, c); + for (i = 0; i < len; i++) + vorbis_buffer[c][i] = Double_field(datac, i + offs); + } + + caml_release_runtime_system(); + vorbis_analysis_wrote(vd, len); + + /* TODO: split the encoding part? */ + + while (vorbis_analysis_blockout(vd, vb) == 1) { + /* Analysis, assume we want to use bitrate management. */ + vorbis_analysis(vb, NULL); + vorbis_bitrate_addblock(vb); + + /* Weld packets into the bitstream. */ + while (vorbis_bitrate_flushpacket(vd, op)) + ogg_stream_packetin(os, op); + } + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_vorbis_encode_float_ba(value vdsp, value vogg, value data, + value _ofs, value _len) { + CAMLparam3(vdsp, vogg, data); + encoder_t *enc = Encoder_val(vdsp); + vorbis_block *vb = &enc->vb; + vorbis_dsp_state *vd = Enc_dsp_state_val(vdsp); + ogg_stream_state *os = Stream_state_val(vogg); + ogg_packet *op = &enc->op; + float **vorbis_buffer; + int ofs = Int_val(_ofs); + int len = Int_val(_len); + int c, i; + value datac; + int channels = enc->vi.channels; + + if (Wosize_val(data) != channels) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_channels")); + + if (channels == 0) + CAMLreturn(Val_unit); + + if (Caml_ba_array_val(Field(data, 0))->dim[0] < ofs + len) + caml_failwith("Invalid length or offset"); + + vorbis_buffer = vorbis_analysis_buffer(vd, len); + for (c = 0; c < channels; c++) { + for (i = 0; i < len; i++) { + vorbis_buffer[c][i] = + ((float *)Caml_ba_data_val(Field(data, c)))[i + ofs]; + } + } + + caml_release_runtime_system(); + vorbis_analysis_wrote(vd, len); + + /* TODO: split the encoding part? */ + + while (vorbis_analysis_blockout(vd, vb) == 1) { + /* Analysis, assume we want to use bitrate management. */ + vorbis_analysis(vb, NULL); + vorbis_bitrate_addblock(vb); + + /* Weld packets into the bitstream. */ + while (vorbis_bitrate_flushpacket(vd, op)) + ogg_stream_packetin(os, op); + } + caml_acquire_runtime_system(); + + CAMLreturn(Val_unit); +} + +CAMLprim value ocaml_vorbis_encode_time_of_granulepos(value v_state, + value gpos) { + CAMLparam2(v_state, gpos); + encoder_t *enc = Encoder_val(v_state); + ogg_int64_t granulepos = Int64_val(gpos); + CAMLreturn(caml_copy_nativeint(vorbis_granule_time(&enc->vd, granulepos))); +} + +/***** File Decoding *****/ + +/* This should be malloced since we might want to register *_func as global + * root. */ +typedef struct { + OggVorbis_File *ovf; + int bitstream; + value read_func; + value seek_func; + value tell_func; +} myvorbis_dec_file_t; + +#define Decfile_val(v) (*((myvorbis_dec_file_t **)Data_custom_val(v))) + +static void finalize_dec_file(value _df) { + myvorbis_dec_file_t *df = Decfile_val(_df); + + ov_clear(df->ovf); + free(df->ovf); + df->ovf = NULL; + caml_remove_global_root(&df->read_func); + caml_remove_global_root(&df->seek_func); + caml_remove_global_root(&df->tell_func); + + free(df); +} + +static struct custom_operations decfile_ops = { + "ocaml_vorbis_decfile", finalize_dec_file, + custom_compare_default, custom_hash_default, + custom_serialize_default, custom_deserialize_default}; + +static size_t read_func_cb(void *ptr, size_t size, size_t nmemb, + void *datasource) { + myvorbis_dec_file_t *df = datasource; + value ret; + int len; + + caml_acquire_runtime_system(); + ret = caml_callback(df->read_func, Val_int(size * nmemb)); + len = Int_val(Field(ret, 1)); + memcpy(ptr, String_val(Field(ret, 0)), len); + caml_release_runtime_system(); + + return len; +} + +static int seek_func_cb(void *datasource, ogg_int64_t offset, int whence) { + myvorbis_dec_file_t *df = datasource; + int cmd; + int ret; + + switch (whence) { + case SEEK_SET: + cmd = 0; + break; + + case SEEK_CUR: + cmd = 1; + break; + + case SEEK_END: + cmd = 2; + break; + + default: + assert(0); + } + caml_acquire_runtime_system(); + ret = Int_val(caml_callback2(df->seek_func, Val_int(offset), Val_int(cmd))); + caml_release_runtime_system(); + + return ret; +} + +static long tell_func_cb(void *datasource) { + myvorbis_dec_file_t *df = datasource; + int ret; + + caml_acquire_runtime_system(); + ret = Int_val(caml_callback(df->tell_func, Val_unit)); + caml_release_runtime_system(); + + return ret; +} + +static ov_callbacks callbacks = {.read_func = read_func_cb, + .seek_func = seek_func_cb, + .close_func = NULL, + .tell_func = tell_func_cb}; + +CAMLprim value ocaml_vorbis_open_dec_stream(value read_func, value seek_func, + value tell_func, value params) { + CAMLparam4(read_func, seek_func, tell_func, params); + CAMLlocal1(block); + int ret = 0; + myvorbis_dec_file_t *df; + + df = malloc(sizeof(myvorbis_dec_file_t)); + + df->ovf = (OggVorbis_File *)malloc(sizeof(OggVorbis_File)); + df->bitstream = 0; + caml_register_global_root(&df->read_func); + df->read_func = read_func; + caml_register_global_root(&df->seek_func); + df->seek_func = seek_func; + caml_register_global_root(&df->tell_func); + df->tell_func = tell_func; + + caml_release_runtime_system(); + ret = ov_open_callbacks(df, df->ovf, NULL, 0, callbacks); + caml_acquire_runtime_system(); + + if (ret < 0) { + caml_remove_global_root(&df->tell_func); + caml_remove_global_root(&df->seek_func); + caml_remove_global_root(&df->read_func); + free(df->ovf); + free(df); + raise_err(ret); + } + + block = caml_alloc_custom(&decfile_ops, sizeof(myvorbis_dec_file_t *), 0, 1); + Decfile_val(block) = df; + + CAMLreturn(block); +} + +CAMLprim value ocaml_vorbis_decode(value d_f, value be_, value ss_, + value signed_, value buf_, value ofs_, + value len_) { + CAMLparam2(d_f, buf_); + + myvorbis_dec_file_t *df = Decfile_val(d_f); + int ret = 0; + int ofs = Int_val(ofs_); + int len = Int_val(len_); + int big_endian = Bool_val(be_); + int sample_size = Int_val(ss_); + int sign = Bool_val(signed_); + char *buf; + + if (!df->ovf) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + if (ofs + len > caml_string_length(buf_)) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + /* TODO: this buffer could be allocated once when creating the decoder + * and reused for every decoding pass. This might be useful to reduce + * load or memory fragmentation if needed. + */ + buf = malloc(len); + + /* We have to make sure that when a callback is called, the ocaml master lock + * has been released. Callbacks are responsible for taking it back if they + * need to call ocaml code. + */ + caml_release_runtime_system(); + ret = + ov_read(df->ovf, buf, len, big_endian, sample_size, sign, &df->bitstream); + caml_acquire_runtime_system(); + + if (ret <= 0) { + free(buf); + ret ? raise_err(ret) : caml_raise_end_of_file(); + } + memcpy(Bytes_val(buf_) + ofs, buf, ret); + free(buf); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_decode_byte(value *argv, int argn) { + return ocaml_vorbis_decode(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5], argv[6]); +} + +CAMLprim value ocaml_vorbis_decode_float(value d_f, value dst, value ofs_, + value len_) { + CAMLparam2(d_f, dst); + + myvorbis_dec_file_t *df = Decfile_val(d_f); + int ret = 0; + int ofs = Int_val(ofs_); + int len = Int_val(len_); + float **buf; + int chans, c, i; + + if (!df->ovf) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + chans = df->ovf->vi->channels; + + if (chans > Wosize_val(dst)) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + if (Wosize_val(dst) < 1 || + Wosize_val(Field(dst, 0)) / Double_wosize - ofs < len) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + + /* We have to make sure that when a callback is called, the ocaml master lock + * has been released. Callbacks are responsible for taking it back if they + * need to call ocaml code. + */ + caml_release_runtime_system(); + ret = ov_read_float(df->ovf, &buf, len, &df->bitstream); + caml_acquire_runtime_system(); + + if (ret <= 0) + ret ? raise_err(ret) : caml_raise_end_of_file(); + + for (c = 0; c < chans; c++) + for (i = 0; i < ret; i++) + Store_double_field(Field(dst, c), i + ofs, clip(buf[c][i])); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_decode_float_alloc(value d_f, value len_) { + CAMLparam1(d_f); + CAMLlocal2(ans, ansc); + + myvorbis_dec_file_t *df = Decfile_val(d_f); + int ret = 0; + int len = Int_val(len_); + float **buf; + int chans, c, i; + + if (!df->ovf) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + chans = df->ovf->vi->channels; + + /* We have to make sure that when a callback is called, the ocaml master lock + * has been released. Callbacks are responsible for taking it back if they + * need to call ocaml code. + */ + caml_release_runtime_system(); + ret = ov_read_float(df->ovf, &buf, len, &df->bitstream); + caml_acquire_runtime_system(); + + if (ret <= 0) + ret ? raise_err(ret) : caml_raise_end_of_file(); + + ans = caml_alloc_tuple(chans); + for (c = 0; c < chans; c++) { + ansc = caml_alloc(ret * Double_wosize, Double_array_tag); + Store_field(ans, c, ansc); + for (i = 0; i < ret; i++) + Store_double_field(ansc, i, clip(buf[c][i])); + } + + CAMLreturn(ans); +} + +CAMLprim value ocaml_vorbis_decode_float_ba(value d_f, value dst, value ofs_, + value len_) { + CAMLparam2(d_f, dst); + + myvorbis_dec_file_t *df = Decfile_val(d_f); + int ret = 0; + int ofs = Int_val(ofs_); + int len = Int_val(len_); + float **buf; + int chans, c, i; + + if (!df->ovf) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + chans = df->ovf->vi->channels; + + if (chans > Wosize_val(dst)) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + if (Wosize_val(dst) < 1 || + Caml_ba_array_val(Field(dst, 0))->dim[0] - ofs < len) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + + /* We have to make sure that when a callback is called, the ocaml master lock + * has been released. Callbacks are responsible for taking it back if they + * need to call ocaml code. + */ + caml_release_runtime_system(); + ret = ov_read_float(df->ovf, &buf, len, &df->bitstream); + caml_acquire_runtime_system(); + + if (ret <= 0) + ret ? raise_err(ret) : caml_raise_end_of_file(); + + for (c = 0; c < chans; c++) + for (i = 0; i < ret; i++) + ((float *)Caml_ba_data_val(Field(dst, c)))[i + ofs] = buf[c][i]; + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_decode_float_alloc_ba(value d_f, value len_) { + CAMLparam1(d_f); + CAMLlocal2(ans, ansc); + + myvorbis_dec_file_t *df = Decfile_val(d_f); + int ret = 0; + int len = Int_val(len_); + float **buf; + int chans, c, i; + + if (!df->ovf) + caml_raise_constant(*caml_named_value("vorbis_exn_invalid_parameters")); + chans = df->ovf->vi->channels; + + /* We have to make sure that when a callback is called, the ocaml master lock + * has been released. Callbacks are responsible for taking it back if they + * need to call ocaml code. + */ + caml_release_runtime_system(); + ret = ov_read_float(df->ovf, &buf, len, &df->bitstream); + caml_acquire_runtime_system(); + + if (ret <= 0) + ret ? raise_err(ret) : caml_raise_end_of_file(); + + ans = caml_alloc_tuple(chans); + for (c = 0; c < chans; c++) { + ansc = caml_ba_alloc_dims(CAML_BA_FLOAT32 | CAML_BA_C_LAYOUT, 1, NULL, ret); + Store_field(ans, c, ansc); + for (i = 0; i < ret; i++) + ((float *)Caml_ba_data_val(ansc))[i] = clip(buf[c][i]); + } + + CAMLreturn(ans); +} + +CAMLprim value ocaml_vorbis_get_dec_file_bitstream(value d_f) { + myvorbis_dec_file_t *df = Decfile_val(d_f); + return Val_int(df->bitstream); +} + +CAMLprim value ocaml_vorbis_decoder_info(value d_f, value bs) { + CAMLparam1(d_f); + CAMLlocal1(ans); + myvorbis_dec_file_t *df = Decfile_val(d_f); + int bitstream = Int_val(bs); + vorbis_info *vi; + + caml_release_runtime_system(); + vi = ov_info(df->ovf, bitstream); + caml_acquire_runtime_system(); + + assert(vi); + ans = caml_alloc_tuple(7); + Store_field(ans, 0, Val_int(vi->version)); + Store_field(ans, 1, Val_int(vi->channels)); + Store_field(ans, 2, Val_int(vi->rate)); + Store_field(ans, 3, Val_int(vi->bitrate_upper)); + Store_field(ans, 4, Val_int(vi->bitrate_nominal)); + Store_field(ans, 5, Val_int(vi->bitrate_lower)); + Store_field(ans, 6, Val_int(vi->bitrate_window)); + + CAMLreturn(ans); +} + +CAMLprim value ocaml_vorbis_get_dec_file_comments(value d_f, value link_) { + CAMLparam2(d_f, link_); + CAMLlocal2(ans, cmts); + + myvorbis_dec_file_t *df = Decfile_val(d_f); + int link = Int_val(link_); + int i; + vorbis_comment *vc; + + caml_release_runtime_system(); + vc = ov_comment(df->ovf, link); + caml_acquire_runtime_system(); + + if (!vc) + /* TODO: better error */ + caml_raise_with_arg(*caml_named_value("vorbis_exn_unknown_error"), + Val_int(666)); + + cmts = caml_alloc_tuple(vc->comments); + for (i = 0; i < vc->comments; i++) + Store_field(cmts, i, caml_copy_string(vc->user_comments[i])); + ans = caml_alloc_tuple(2); + if (vc->vendor != NULL) + Store_field(ans, 0, caml_copy_string(vc->vendor)); + else + Store_field(ans, 0, caml_copy_string("(null)")); + Store_field(ans, 1, cmts); + + CAMLreturn(ans); +} + +CAMLprim value ocaml_vorbis_decoder_bitrate(value d_f, value bs) { + CAMLparam1(d_f); + myvorbis_dec_file_t *df = Decfile_val(d_f); + int bitstream = Int_val(bs); + long ret; + + caml_release_runtime_system(); + ret = ov_bitrate(df->ovf, bitstream); + caml_acquire_runtime_system(); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_decoder_time_total(value d_f, value bs) { + CAMLparam1(d_f); + myvorbis_dec_file_t *df = Decfile_val(d_f); + int bitstream = Int_val(bs); + double ret; + + caml_release_runtime_system(); + ret = ov_time_total(df->ovf, bitstream); + caml_acquire_runtime_system(); + + CAMLreturn(caml_copy_double(ret)); +} + +CAMLprim value ocaml_vorbis_decoder_pcm_total(value d_f, value bs) { + CAMLparam1(d_f); + myvorbis_dec_file_t *df = Decfile_val(d_f); + int bitstream = Int_val(bs); + ogg_int64_t ret; + + caml_release_runtime_system(); + ret = ov_pcm_total(df->ovf, bitstream); + caml_acquire_runtime_system(); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_decoder_streams(value d_f) { + CAMLparam1(d_f); + myvorbis_dec_file_t *df = Decfile_val(d_f); + long ret; + + caml_release_runtime_system(); + ret = ov_streams(df->ovf); + caml_acquire_runtime_system(); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value ocaml_vorbis_decoder_serialnumber(value d_f, value bs) { + CAMLparam1(d_f); + myvorbis_dec_file_t *df = Decfile_val(d_f); + int bitstream = Int_val(bs); + long ret; + + caml_release_runtime_system(); + ret = ov_serialnumber(df->ovf, bitstream); + caml_acquire_runtime_system(); + + CAMLreturn(Val_int(ret)); +} + +/* Ogg skeleton interface */ + +/* Wrappers */ +static void write32le(unsigned char *ptr, ogg_uint32_t v) { + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; +} + +static void write64le(unsigned char *ptr, ogg_int64_t v) { + ogg_uint32_t hi = v >> 32; + ptr[0] = v & 0xff; + ptr[1] = (v >> 8) & 0xff; + ptr[2] = (v >> 16) & 0xff; + ptr[3] = (v >> 24) & 0xff; + ptr[4] = hi & 0xff; + ptr[5] = (hi >> 8) & 0xff; + ptr[6] = (hi >> 16) & 0xff; + ptr[7] = (hi >> 24) & 0xff; +} + +/* Values from http://xiph.org/ogg/doc/skeleton.html */ +#define FISBONE_IDENTIFIER "fisbone\0" +#define FISBONE_MESSAGE_HEADER_OFFSET 44 +#define FISBONE_SIZE 52 + +/* Code from theorautils.c in ffmpeg2theora */ +CAMLprim value ocaml_vorbis_skeleton_fisbone(value serial, value samplerate, + value start, value content) { + CAMLparam4(serial, samplerate, start, content); + CAMLlocal1(packet); + ogg_packet op; + int len = FISBONE_SIZE + caml_string_length(content); + + memset(&op, 0, sizeof(op)); + op.packet = malloc(len); + if (op.packet == NULL) + caml_raise_out_of_memory(); + + memset(op.packet, 0, len); + /* it will be the fisbone packet for the vorbis audio */ + memcpy(op.packet, FISBONE_IDENTIFIER, 8); /* identifier */ + write32le( + op.packet + 8, + FISBONE_MESSAGE_HEADER_OFFSET); /* offset of the message header fields */ + write32le(op.packet + 12, + Nativeint_val(serial)); /* serialno of the vorbis stream */ + write32le(op.packet + 16, 3); /* number of header packet */ + /* granulerate, temporal resolution of the bitstream in Hz */ + write64le(op.packet + 20, + (ogg_int64_t)Int64_val(samplerate)); /* granulerate numerator */ + write64le(op.packet + 28, (ogg_int64_t)1); /* granulerate denominator */ + write64le(op.packet + 36, (ogg_int64_t)Int64_val(start)); /* start granule */ + write32le(op.packet + 44, 2); /* preroll, for vorbis its 2 */ + *(op.packet + 48) = 0; /* granule shift, always 0 for vorbis */ + memcpy(op.packet + FISBONE_SIZE, String_val(content), + caml_string_length(content)); + + op.b_o_s = 0; + op.e_o_s = 0; + op.bytes = len; + + packet = value_of_packet(&op); + free(op.packet); + CAMLreturn(packet); +}