BSON-v1.12.1/000755 000765 000024 00000000000 13524525151 012760 5ustar00davidstaff000000 000000 BSON-v1.12.1/devel/000755 000765 000024 00000000000 13524525151 014057 5ustar00davidstaff000000 000000 BSON-v1.12.1/LICENSE000644 000765 000024 00000026372 13524525151 013777 0ustar00davidstaff000000 000000 This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. BSON-v1.12.1/cpanfile000644 000765 000024 00000004421 13524525151 014465 0ustar00davidstaff000000 000000 requires "B" => "0"; requires "Carp" => "0"; requires "Crypt::URandom" => "0"; requires "Exporter" => "0"; requires "List::Util" => "0"; requires "MIME::Base64" => "0"; requires "Math::BigFloat" => "0"; requires "Math::BigInt" => "0"; requires "Moo" => "2.002004"; requires "Scalar::Util" => "0"; requires "Sys::Hostname" => "0"; requires "Tie::IxHash" => "0"; requires "Time::HiRes" => "0"; requires "Time::Local" => "0"; requires "base" => "0"; requires "boolean" => "0.45"; requires "constant" => "0"; requires "if" => "0"; requires "mro" => "0"; requires "namespace::clean" => "0"; requires "overload" => "0"; requires "perl" => "5.010001"; requires "re" => "0"; requires "strict" => "0"; requires "threads::shared" => "0"; requires "version" => "0"; requires "warnings" => "0"; on 'test' => sub { requires "Data::Dumper" => "0"; requires "Devel::Peek" => "0"; requires "ExtUtils::MakeMaker" => "0"; requires "File::Spec" => "0"; requires "JSON::MaybeXS" => "0"; requires "JSON::PP" => "2.97001"; requires "Path::Tiny" => "0.054"; requires "Test::Deep" => "0"; requires "Test::Fatal" => "0"; requires "Test::More" => "0.96"; requires "lib" => "0"; requires "perl" => "5.010001"; requires "utf8" => "0"; }; on 'test' => sub { recommends "CPAN::Meta" => "2.120900"; }; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "6.17"; requires "perl" => "5.010001"; }; on 'develop' => sub { requires "Dist::Zilla" => "5"; requires "Dist::Zilla::Plugin::Meta::Contributors" => "0"; requires "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" => "0"; requires "Dist::Zilla::Plugin::RemovePrereqs" => "0"; requires "Dist::Zilla::PluginBundle::DAGOLDEN" => "0.072"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "IO::Handle" => "0"; requires "IPC::Open3" => "0"; requires "Pod::Coverage::TrustPod" => "0"; requires "Pod::Wordlist" => "0"; requires "Software::License::Apache_2_0" => "0"; requires "Test::CPAN::Meta" => "0"; requires "Test::MinimumVersion" => "0"; requires "Test::More" => "0"; requires "Test::Perl::Critic" => "0"; requires "Test::Pod" => "1.41"; requires "Test::Pod::Coverage" => "1.08"; requires "Test::Portability::Files" => "0"; requires "Test::Spelling" => "0.12"; requires "Test::Version" => "1"; }; BSON-v1.12.1/Changes000644 000765 000024 00000022270 13524525151 014256 0ustar00davidstaff000000 000000 Revision history for BSON v1.12.1 2019-08-13 08:17:13-04:00 America/New_York [!!! END OF LIFE NOTICE !!!] - Version v1.12.0 is the final feature release of the MongoDB BSON library. The library is now in a 12-month "sunset" period and will receive security patches and critical bug fixes only. The BSON library will be end-of-life and unsupported on August 13, 2020. v1.12.0 2019-07-12 12:06:36-04:00 America/New_York [Added] - Added BSON::Array as a wrapper for edge cases in the MongoDB driver where an array reference could be misinterpreted as a top-level document container. v1.10.2 2018-12-07 12:26:15-05:00 America/New_York [Bugs fixed] - PERL-1045 Fixed module name typo in fork-protection code. v1.10.1 2018-11-30 00:33:12-05:00 America/New_York [Bugs fixed] - PERL-1043 Max depth limits miscounted BSON::Raw, triggering exceptions when there shouldn't be one. v1.10.0 2018-11-29 11:10:19-05:00 America/New_York [Bugs fixed] - PERL-1009 BSON 1.8.1 fails on bleadperl with -Duselongdouble [Changed] - PERL-606 Improve BSON error messages - PERL-1010 BSON::Raw add get_first_key method - PERL-740 Limit BSON encoding/decoding to max depth limits - PERL-975 Implement ObjectID spec [Testing] - PERL-737 Test encoding of dual vars and PVMG types v1.8.1 2018-10-01 16:28:47-04:00 America/New_York [Bugs fixed] - PERL-1000 Fixed ExtJSON conversions on 32-bit perls v1.8.0 2018-09-12 20:57:40-04:00 America/New_York [*** Deprecations ***] - Deprecated the 'inflate_extjson' method in favor of the new 'extjson_to_perl' method. [Added] - PERL-747 Added support for Extended JSON v2 [Testing] - PERL-738 Added regression tests for Perl->BSON edge cases v1.6.7 2018-07-10 09:58:56-04:00 America/New_York [Testing] - PERL-954 Prevent deprecation warnings from use of deprecated MongoDB v2.0.0 classes in test code. - PERL-957 Remove tests for MongoDB::BSON::_EncodedDoc (legacy type) v1.6.6 2018-06-23 13:36:09-04:00 America/New_York [Bugs fixed] - PERL-943 Better handling of BSON::Timestamp comparison to undef v1.6.5 2018-06-19 16:19:26-06:00 America/Denver [Bugs fixed] - PERL-941 Fix BSON::Time epoch conversion on perl w/o 64-bit ints v1.6.4 2018-06-13 10:01:32-04:00 America/New_York [Documentation] - Clarified BSON type mapping table and BSON::Time SYNOPSIS v1.6.3 2018-05-25 13:53:32-04:00 America/New_York [Bugs] - PERL-911 Implement 'bool' overloading for BSON::String to avoid the fallback implementation relying on numification and giving warnings. v1.6.2 2018-05-24 12:43:06-04:00 America/New_York [Bugs] - [PERL-641] Fix back-compatible BSON::Timestamp constructor so that MongoDB::Timestamp can be an empty subclass of it. v1.6.1 2018-05-17 13:41:11-04:00 America/New_York [Bugs] - [PERL-893] Fix 'prefer_numeric' handling of dual-vars to apply the heuristic only when no numeric form already exists. - [PERL-896] The 'epoch' method on BSON::Time was truncating to integers; it's now a floating point value as documented. - [PERL-896] Fixed PID generation within OIDs v1.6.0 2018-05-15 09:41:21-04:00 America/New_York [Bugs] - [PERL-739] Validate Uint32 range on BSON::Timestamp components [New Feature] - [PERL-593] Add comparison overloading to BSON::OID - [PERL-688] Add create_oid class method - [PERL-868] Add comparison overloading to BSON::Timestamp v1.4.0 2017-03-16 18:00:04-04:00 America/New_York [!!! Incompatible Changes !!!] - Minimum Perl version bumped up to v5.10.1 for byte-order modifiers for pack and unpack. [Bugs] - [PERL-694] - Tests fail on x86 (32-bit) without use64bitint perl [New Feature] - [PERL-751] - Support big-endian architectures v1.2.2 2016-10-27 17:51:52-04:00 America/New_York [Changed] - Removed Module::Runtime prerequisite and improved error messages when no backends were loaded. [Testing] - Add testing for BSON::Regex flag ordering v1.2.1 2016-10-24 20:56:51-04:00 America/New_York [Fixed] - Detects (and throws error) during encoding for non-container types - Fix BSON::Time for 32-bit Perls [Changed] - Switch to BSON::XS for optimized OID generation if available - Always stringify plain scalars as a last resort in encoding [Testing] - Add test module to reset environment and hide XS v1.2.0 2016-08-17 15:51:50-04:00 America/New_York [Added] - Added dt_type support for Mango::BSON::Time - Added 'from_epoch' constructor method to BSON::OID [Documentation] - Credited Sebastian Riedel for inspiration regarding helper functions - Hash::Ordered is not yet supported v1.0.0 2016-07-06 12:39:38-04:00 America/New_York [!!! Incompatible Changes !!!] - Internal representation of BSON::Bool changed to make it a subclass of boolean.pm for conistency with other "boolean" type classes on CPAN. - All BSON type wrapper classes are now immutable; accessors have been changed to read-only. [*** Deprecations ***] - BSON::Binary deprecated in favor of the new BSON::Bytes module. - BSON::Bool deprecated in favor of direct use of boolean.pm. - BSON::ObjectID deprecated in favor of the new BSON::OID module. - The 'ixhash' option is deprecated in favor of 'ordered' and the resulting tied object is no longer guaranteed to be Tie::IxHash. This will allow future optimization, as Tie::IxHash is extremely slow. [API] - BSON module is now object-oriented, with an API and options directly compatible with the MongoDB driver. Options set as constructor attributes apply to all encoding/decoding, unless options given to methods override them. - Added a method for inflation of MongoDB's extended JSON format to BSON type wrapper objects. [BSON types] - Added new type wrappers to cover all BSON Types, including forthcoming Decimal128 (but Decimal128 is still considered 'experimental' and subject to change). - Rationalized/harmonized BSON type classes for compatibility with pre-existing MongoDB BSON classes. Classes that could not be made to interoperate are deprecated as listed above. [Bug fixes] - Fixed numerous encoding and decoding bugs revealed by greater test coverage (e.g. fixes to UTF-8 encoding/decoding). [Testing] - Significantly improved test coverage, including tests using a standardized BSON corpus. - Skip threads tests before 5.8.5 because of problems with weak references during global destruction. - Require newer Path::Tiny with full-featured "basename" method. [Prereqs] - Bump boolean prereq to 0.45 to avoid conflicts between some versions of JSON::XS and older boolean.pm releases that had read-only singletons. - Bump Moo prereq to 2.002004 to work around core sub shadowing bug in generated constructor. [~Internal Changes~] - Pure-perl implementation split into a separate module to avoid its load time in the future when an XS implementation becomes available. - Will prefer BSON::XS (when released) or fallback to BSON::PP; PERL_BSON_BACKEND environment variable will override. v0.999.5 2016-06-29 11:31:51-04:00 America/New_York (TRIAL RELEASE) v0.999.4 2016-06-27 23:19:56-04:00 America/New_York (TRIAL RELEASE) v0.999.3 2016-06-23 00:44:37-04:00 America/New_York (TRIAL RELEASE) v0.999.2 2016-06-13 16:02:54-04:00 America/New_York (TRIAL RELEASE) v0.999.1 2016-06-08 16:03:23-04:00 America/New_York (TRIAL RELEASE) v0.999.0 2016-06-01 18:27:43-04:00 America/New_York (TRIAL RELEASE) 0.16 2015-09-25 10:54:41-04:00 America/New_York [CHANGES] - Improved diagnostic output if integers are too big [BUG FIXES] - Improved OID counter thread-safety - Fix tests for perls with long doubles [OPTIMIZATION] - BSON::ObjectId generation now ~ 1.9x faster 0.13 2015-04-07 12:02:29-04:00 America/New_York (TRIAL RELEASE) [BUG FIXES] - Fix t/10-bson.t bug comparing floating point values; now using Test::Number::Delta for comparison 0.12 2015-04-06 16:11:59-04:00 America/New_York [BUG FIXES] - added decoding support for BSON type 0x06 (Javascript "undefined"); treated like type 0x0A (null value) and decoded as Perl undef [OPTIMIZATION] - Inlined most functions for 10-20% performance increase measured on a sample of Twitter tweets. [META] - Switched repository to Dist::Zilla structure using @DAGOLDEN plugin bundle and associated file layout 0.11 2011-12-14 use Math::Int64 to address the 32-bit only Perl support 0.06 2011-09-26 Lower the required Perl version to 5.8 0.04 2011-08-04 17:30 PST Add BSON::String type 0.03 2011-08-02 14:00:00 PST Fix regex parsing for Perl<5.14 Fix thread dependency in oid.t 0.02 2011-07-25 19:10:00 PST Fix spelling errors 0.01 2011-07-22 16:45:00 PST First version, released. BSON-v1.12.1/corpus/000755 000765 000024 00000000000 13524525151 014273 5ustar00davidstaff000000 000000 BSON-v1.12.1/MANIFEST000644 000765 000024 00000006341 13524525151 014115 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.012. CONTRIBUTING.mkdn Changes LICENSE MANIFEST META.json META.yml Makefile.PL README corpus/README.md corpus/array.json corpus/binary.json corpus/boolean.json corpus/code.json corpus/code_w_scope.json corpus/datetime.json corpus/dbpointer.json corpus/dbref.json corpus/decimal128-1.json corpus/decimal128-2.json corpus/decimal128-3.json corpus/decimal128-4.json corpus/decimal128-5.json corpus/decimal128-6.json corpus/decimal128-7.json corpus/decode-dump.pl corpus/deprecated/dbpointer.json corpus/deprecated/symbol.json corpus/deprecated/undefined.json corpus/document.json corpus/double.json corpus/encode-dump.pl corpus/int32.json corpus/int64.json corpus/maxkey.json corpus/minkey.json corpus/multi-type-deprecated.json corpus/multi-type.json corpus/null.json corpus/oid.json corpus/regex.json corpus/string.json corpus/symbol.json corpus/timestamp.json corpus/top.json corpus/undefined.json cpanfile devel/bson-types-survey.md devel/typemap.md dist.ini lib/BSON.pm lib/BSON/Array.pm lib/BSON/Binary.pm lib/BSON/Bool.pm lib/BSON/Bytes.pm lib/BSON/Code.pm lib/BSON/DBPointer.pm lib/BSON/DBRef.pm lib/BSON/Decimal128.pm lib/BSON/Doc.pm lib/BSON/Double.pm lib/BSON/Int32.pm lib/BSON/Int64.pm lib/BSON/MaxKey.pm lib/BSON/MinKey.pm lib/BSON/OID.pm lib/BSON/ObjectId.pm lib/BSON/PP.pm lib/BSON/Raw.pm lib/BSON/Regex.pm lib/BSON/String.pm lib/BSON/Symbol.pm lib/BSON/Time.pm lib/BSON/Timestamp.pm lib/BSON/Types.pm perlcritic.rc t/00-report-prereqs.dd t/00-report-prereqs.t t/backend.t t/common/bson_array.t t/common/create_oid.t t/common/cycle.t t/common/dualvar.t t/common/errors.t t/common/number_heuristics.t t/common/options.t t/common/tied.t t/common/top-array.t t/corpus/array.t t/corpus/binary.t t/corpus/boolean.t t/corpus/code.t t/corpus/code_w_scope.t t/corpus/corpus.pl t/corpus/datetime.t t/corpus/dbpointer.t t/corpus/dbref.t t/corpus/decimal128-1.t t/corpus/decimal128-2.t t/corpus/decimal128-3.t t/corpus/decimal128-4.t t/corpus/decimal128-5.t t/corpus/decimal128-6.t t/corpus/decimal128-7.t t/corpus/document.t t/corpus/double.t t/corpus/int32.t t/corpus/int64.t t/corpus/maxkey.t t/corpus/minkey.t t/corpus/multi-type.t t/corpus/null.t t/corpus/oid.t t/corpus/regex.t t/corpus/string.t t/corpus/symbol.t t/corpus/timestamp.t t/corpus/top.t t/corpus/undefined.t t/legacy/01-bool.t t/legacy/02-oid.t t/legacy/03-time.t t/legacy/04-binary.t t/legacy/05-code.t t/legacy/06-timestamp.t t/legacy/07-minmaxkey.t t/legacy/08-string.t t/legacy/10-bson.t t/legacy/11-random.t t/legacy/12-exception.t t/lib/CorpusTest.pm t/lib/TestTie.pm t/lib/TestUtils.pm t/mapping/binary.t t/mapping/boolean.t t/mapping/code.t t/mapping/dbref.t t/mapping/decimal128.t t/mapping/double.t t/mapping/hashref.t t/mapping/int32.t t/mapping/int64.t t/mapping/minmaxkey.t t/mapping/oid.t t/mapping/regex.t t/mapping/string.t t/mapping/time.t t/mapping/timestamp.t t/pvtlib/CleanEnv.pm t/pvtlib/PPSubclass.pm t/raw.t t/regression/boolean_copy.t t/regression/scalar_ref_value.t t/regression/undef_round_trip.t t/wrapper_apis.t xt/author/00-compile.t xt/author/critic.t xt/author/minimum-version.t xt/author/pod-coverage.t xt/author/pod-spell.t xt/author/pod-syntax.t xt/author/portability.t xt/author/test-version.t xt/release/distmeta.t BSON-v1.12.1/perlcritic.rc000644 000765 000024 00000001166 13524525151 015452 0ustar00davidstaff000000 000000 severity = 5 verbose = 8 [Variables::ProhibitPunctuationVars] allow = $@ $! [TestingAndDebugging::ProhibitNoStrict] allow = refs [Variables::ProhibitEvilVariables] variables = $DB::single # Turn these off [-BuiltinFunctions::ProhibitStringyEval] [-ControlStructures::ProhibitPostfixControls] [-ControlStructures::ProhibitUnlessBlocks] [-Documentation::RequirePodSections] [-InputOutput::ProhibitInteractiveTest] [-References::ProhibitDoubleSigils] [-RegularExpressions::RequireExtendedFormatting] [-InputOutput::ProhibitTwoArgOpen] [-Modules::ProhibitEvilModules] # Turn this on [Lax::ProhibitStringyEval::ExceptForRequire] BSON-v1.12.1/CONTRIBUTING.mkdn000644 000765 000024 00000005751 13524525151 015552 0ustar00davidstaff000000 000000 ## HOW TO CONTRIBUTE Thank you for considering contributing to this distribution. This file contains instructions that will help you work with the source code. The distribution is managed with Dist::Zilla. This means than many of the usual files you might expect are not in the repository, but are generated at release time, as is much of the documentation. Some generated files are kept in the repository as a convenience (e.g. Makefile.PL or cpanfile). Generally, **you do not need Dist::Zilla to contribute patches**. You do need Dist::Zilla to create a tarball. See below for guidance. ### Getting dependencies If you have App::cpanminus 1.6 or later installed, you can use `cpanm` to satisfy dependencies like this: $ cpanm --installdeps . Otherwise, look for either a `Makefile.PL` or `cpanfile` file for a list of dependencies to satisfy. ### Running tests You can run tests directly using the `prove` tool: $ prove -l $ prove -lv t/some_test_file.t For most of my distributions, `prove` is entirely sufficient for you to test any patches you have. I use `prove` for 99% of my testing during development. ### Code style and tidying Please try to match any existing coding style. If there is a `.perltidyrc` file, please install Perl::Tidy and use perltidy before submitting patches. If there is a `tidyall.ini` file, you can also install Code::TidyAll and run `tidyall` on a file or `tidyall -a` to tidy all files. ### Patching documentation Much of the documentation Pod is generated at release time. Some is generated boilerplate; other documentation is built from pseudo-POD directives in the source like C<=method> or C<=func>. If you would like to submit a documentation edit, please limit yourself to the documentation you see. If you see typos or documentation issues in the generated docs, please email or open a bug ticket instead of patching. ### Installing and using Dist::Zilla Dist::Zilla is a very powerful authoring tool, optimized for maintaining a large number of distributions with a high degree of automation, but it has a large dependency chain, a bit of a learning curve and requires a number of author-specific plugins. To install it from CPAN, I recommend one of the following approaches for the quickest installation: # using CPAN.pm, but bypassing non-functional pod tests $ cpan TAP::Harness::Restricted $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla # using cpanm, bypassing *all* tests $ cpanm -n Dist::Zilla In either case, it's probably going to take about 10 minutes. Go for a walk, go get a cup of your favorite beverage, take a bathroom break, or whatever. When you get back, Dist::Zilla should be ready for you. Then you need to install any plugins specific to this distribution: $ cpan `dzil authordeps` $ dzil authordeps | cpanm Once installed, here are some dzil commands you might try: $ dzil build $ dzil test $ dzil xtest You can learn more about Dist::Zilla at http://dzil.org/ BSON-v1.12.1/t/000755 000765 000024 00000000000 13524525151 013223 5ustar00davidstaff000000 000000 BSON-v1.12.1/xt/000755 000765 000024 00000000000 13524525151 013413 5ustar00davidstaff000000 000000 BSON-v1.12.1/README000644 000765 000024 00000046366 13524525151 013657 0ustar00davidstaff000000 000000 NAME BSON - BSON serialization and deserialization VERSION version v1.12.1 END OF LIFE NOTICE Version v1.12.0 is the final feature release of the MongoDB BSON library. The library is now in a 12-month "sunset" period and will receive security patches and critical bug fixes only. The BSON library will be end-of-life and unsupported on August 13, 2020. SYNOPSIS use BSON; use BSON::Types ':all'; use boolean; my $codec = BSON->new; my $document = { _id => bson_oid(), creation_time => bson_time(), # now zip_code => bson_string("08544"), hidden => false, }; my $bson = $codec->encode_one( $document ); my $doc = $codec->decode_one( $bson ); DESCRIPTION This class implements a BSON encoder/decoder ("codec"). It consumes "documents" (typically hash references) and emits BSON strings and vice versa in accordance with the BSON Specification . BSON is the primary data representation for MongoDB. While this module has several features that support MongoDB-specific needs and conventions, it can be used as a standalone serialization format. The codec may be customized through attributes on the codec option as well as encode/decode specific options on methods: my $codec = BSON->new( \%global_attributes ); my $bson = $codec->encode_one( $document, \%encode_options ); my $doc = $codec->decode_one( $bson , \%decode_options ); Because BSON is strongly-typed and Perl is not, this module supports a number of "type wrappers" – classes that wrap Perl data to indicate how they should serialize. The BSON::Types module describes these and provides associated helper functions. See "PERL-BSON TYPE MAPPING" for more details. When decoding, type wrappers are used for any data that has no native Perl representation. Optionally, all data may be wrapped for precise control of round-trip encoding. Please read the configuration attributes carefully to understand more about how to control encoding and decoding. At compile time, this module will select an implementation backend. It will prefer "BSON::XS" (released separately) if available, or will fall back to BSON::PP (bundled with this module). See "ENVIRONMENT" for a way to control the selection of the backend. ATTRIBUTES error_callback This attribute specifies a function reference that will be called with three positional arguments: * an error string argument describing the error condition * a reference to the problematic document or byte-string * the method in which the error occurred (e.g. "encode_one" or "decode_one") Note: for decoding errors, the byte-string is passed as a reference to avoid copying possibly large strings. If not provided, errors messages will be thrown with "Carp::croak". invalid_chars A string containing ASCII characters that must not appear in keys. The default is the empty string, meaning there are no invalid characters. max_length This attribute defines the maximum document size. The default is 0, which disables any maximum. If set to a positive number, it applies to both encoding and decoding (the latter is necessary for prevention of resource consumption attacks). op_char This is a single character to use for special MongoDB-specific query operators. If a key starts with "op_char", the "op_char" character will be replaced with "$". The default is "$", meaning that no replacement is necessary. ordered If set to a true value, then decoding will return a reference to a tied hash that preserves key order. Otherwise, a regular (unordered) hash reference will be returned. IMPORTANT CAVEATS: * When 'ordered' is true, users must not rely on the return value being any particular tied hash implementation. It may change in the future for efficiency. * Turning this option on entails a significant speed penalty as tied hashes are slower than regular Perl hashes. The default is false. prefer_numeric When false, scalar values will be encoded as a number if they were originally a number or were ever used in a numeric context. However, a string that looks like a number but was never used in a numeric context (e.g. "42") will be encoded as a string. If "prefer_numeric" is set to true, the encoder will attempt to coerce strings that look like a number into a numeric value. If the string doesn't look like a double or integer, it will be encoded as a string. IMPORTANT CAVEAT: the heuristics for determining whether something is a string or number are less accurate on older Perls. See BSON::Types for wrapper classes that specify exact serialization types. The default is false. wrap_dbrefs If set to true, during decoding, documents with the fields '$id' and '$ref' (literal dollar signs, not variables) will be wrapped as BSON::DBRef objects. If false, they are decoded into ordinary hash references (or ordered hashes, if "ordered" is true). The default is true. wrap_numbers If set to true, during decoding, numeric values will be wrapped into BSON type-wrappers: BSON::Double, BSON::Int64 or BSON::Int32. While very slow, this can help ensure fields can round-trip if unmodified. The default is false. wrap_strings If set to true, during decoding, string values will be wrapped into a BSON type-wrappers, BSON::String. While very slow, this can help ensure fields can round-trip if unmodified. The default is false. dt_type (Discouraged) Sets the type of object which is returned for BSON DateTime fields. The default is "undef", which returns objects of type BSON::Time. This is overloaded to be the integer epoch value when used as a number or string, so is somewhat backwards compatible with "dt_type" in the MongoDB driver. Other acceptable values are BSON::Time (explicitly), DateTime, Time::Moment, DateTime::Tiny, Mango::BSON::Time. Because BSON::Time objects have methods to convert to DateTime, Time::Moment or DateTime::Tiny, use of this field is discouraged. Users should use these methods on demand. This option is provided for backwards compatibility only. METHODS encode_one $byte_string = $codec->encode_one( $doc ); $byte_string = $codec->encode_one( $doc, \%options ); Takes a "document", typically a hash reference, an array reference, or a Tie::IxHash object and returns a byte string with the BSON representation of the document. An optional hash reference of options may be provided. Valid options include: * first_key – if "first_key" is defined, it and "first_value" will be encoded first in the output BSON; any matching key found in the document will be ignored. * first_value - value to assign to "first_key"; will encode as Null if omitted * error_callback – overrides codec default * invalid_chars – overrides codec default * max_length – overrides codec default * op_char – overrides codec default * prefer_numeric – overrides codec default decode_one $doc = $codec->decode_one( $byte_string ); $doc = $codec->decode_one( $byte_string, \%options ); Takes a byte string with a BSON-encoded document and returns a hash reference representing the decoded document. An optional hash reference of options may be provided. Valid options include: * dt_type – overrides codec default * error_callback – overrides codec default * max_length – overrides codec default * ordered - overrides codec default * wrap_dbrefs - overrides codec default * wrap_numbers - overrides codec default * wrap_strings - overrides codec default clone $copy = $codec->clone( ordered => 1 ); Constructs a copy of the original codec, but allows changing attributes in the copy. create_oid $oid = BSON->create_oid; This class method returns a new BSON::OID. This abstracts OID generation away from any specific Object ID class and makes it an interface on a BSON codec. Alternative BSON codecs should define a similar class method that returns an Object ID of whatever type is appropriate. inflate_extjson (DEPRECATED) This legacy method does not follow the MongoDB Extended JSON specification. Use "extjson_to_perl" instead. perl_to_extjson use JSON::MaybeXS; my $ext = BSON->perl_to_extjson($data, \%options); my $json = encode_json($ext); Takes a perl data structure (i.e. hashref) and turns it into an MongoDB Extended JSON structure. Note that the structure will still have to be serialized. Possible options are: * "relaxed" A boolean indicating if "relaxed extended JSON" should be generated. If not set, the default value is taken from the "BSON_EXTJSON_RELAXED" environment variable. extjson_to_perl use JSON::MaybeXS; my $ext = decode_json($json); my $data = $bson->extjson_to_perl($ext); Takes an MongoDB Extended JSON data structure and inflates it into a Perl data structure. Note that you have to decode the JSON string manually beforehand. Canonically specified numerical values like "{"$numberInt":"23"}" will be inflated into their respective "BSON::*" wrapper types. Plain numeric values will be left as-is. FUNCTIONS encode my $bson = encode({ bar => 'foo' }, \%options); This is the legacy, functional interface and is only exported on demand. It takes a hashref and returns a BSON string. It uses an internal codec singleton with default attributes. decode my $hash = decode( $bson, \%options ); This is the legacy, functional interface and is only exported on demand. It takes a BSON string and returns a hashref. It uses an internal codec singleton with default attributes. PERL-BSON TYPE MAPPING BSON has numerous data types and Perl does not. When decoding, each BSON type should result in a single, predictable Perl type. Where no native Perl type is appropriate, BSON decodes to an object of a particular class (a "type wrapper"). When encoding, for historical reasons, there may be many Perl representations that should encode to a particular BSON type. For example, all the popular "boolean" type modules on CPAN should encode to the BSON boolean type. Likewise, as this module is intended to supersede the type wrappers that have shipped with the MongoDB module, those type wrapper are supported by this codec. The table below describes the BSON/Perl mapping for both encoding and decoding. On the left are all the Perl types or classes this BSON codec knows how to serialize to BSON. The middle column is the BSON type for each class. The right-most column is the Perl type or class that the BSON type deserializes to. Footnotes indicate variations or special behaviors. Perl type/class -> BSON type -> Perl type/class ------------------------------------------------------------------- float[1] 0x01 DOUBLE float[2] BSON::Double ------------------------------------------------------------------- string[3] 0x02 UTF8 string[2] BSON::String ------------------------------------------------------------------- hashref 0x03 DOCUMENT hashref[4][5] BSON::Doc BSON::Raw MongoDB::BSON::Raw[d] Tie::IxHash ------------------------------------------------------------------- arrayref 0x04 ARRAY arrayref ------------------------------------------------------------------- BSON::Bytes 0x05 BINARY BSON::Bytes scalarref BSON::Binary[d] MongoDB::BSON::Binary[d] ------------------------------------------------------------------- n/a 0x06 UNDEFINED[d] undef ------------------------------------------------------------------- BSON::OID 0x07 OID BSON::OID BSON::ObjectId[d] MongoDB::OID[d] ------------------------------------------------------------------- boolean 0x08 BOOL boolean BSON::Bool[d] JSON::XS::Boolean JSON::PP::Boolean JSON::Tiny::_Bool Mojo::JSON::_Bool Cpanel::JSON::XS::Boolean Types::Serialiser::Boolean ------------------------------------------------------------------- BSON::Time 0x09 DATE_TIME BSON::Time DateTime DateTime::Tiny Time::Moment Mango::BSON::Time ------------------------------------------------------------------- undef 0x0a NULL undef ------------------------------------------------------------------- BSON::Regex 0x0b REGEX BSON::Regex qr// reference MongoDB::BSON::Regexp[d] ------------------------------------------------------------------- n/a 0x0c DBPOINTER[d] BSON::DBRef ------------------------------------------------------------------- BSON::Code[6] 0x0d CODE BSON::Code MongoDB::Code[6] ------------------------------------------------------------------- n/a 0x0e SYMBOL[d] string ------------------------------------------------------------------- BSON::Code[6] 0x0f CODEWSCOPE BSON::Code MongoDB::Code[6] ------------------------------------------------------------------- integer[7][8] 0x10 INT32 integer[2] BSON::Int32 ------------------------------------------------------------------- BSON::Timestamp 0x11 TIMESTAMP BSON::Timestamp MongoDB::Timestamp[d] ------------------------------------------------------------------- integer[7] 0x12 INT64 integer[2][9] BSON::Int64 Math::BigInt Math::Int64 ------------------------------------------------------------------- BSON::MaxKey 0x7F MAXKEY BSON::MaxKey MongoDB::MaxKey[d] ------------------------------------------------------------------- BSON::MinKey 0xFF MINKEY BSON::MinKey MongoDB::MinKey[d] [d] Deprecated or soon to be deprecated. [1] Scalar with "NV" internal representation or a string that looks like a float if the 'prefer_numeric' option is true. [2] If the 'wrap_numbers' option is true, numeric types will be wrapped as BSON::Double, BSON::Int32 or BSON::Int64 as appropriate to ensure round-tripping. If the 'wrap_strings' option is true, strings will be wrapped as BSON::String, likewise. [3] Scalar without "NV" or "IV" representation and not identified as a number by notes [1] or [7]. [4] If 'ordered' option is set, will return a tied hash that preserves order (deprecated 'ixhash' option still works). [5] If the document appears to contain a DBRef and a 'dbref_callback' exists, that callback is executed with the deserialized document. [6] Code is serialized as CODE or CODEWSCOPE depending on whether a scope hashref exists in BSON::Code/MongoDB::Code. [7] Scalar with "IV" internal representation or a string that looks like an integer if the 'prefer_numeric' option is true. [8] Only if the integer fits in 32 bits. [9] On 32-bit platforms, 64-bit integers are deserialized to Math::BigInt objects (even if subsequently wrapped into BSON::Int64 if 'wrap_scalars' is true). THREADS Threads are never recommended in Perl, but this module is thread safe. ENVIRONMENT * PERL_BSON_BACKEND – if set at compile time, this will be treated as a module name. The module will be loaded and used as the BSON backend implementation. It must implement the same API as "BSON::PP". * BSON_EXTJSON - if set, serializing BSON type wrappers via "TO_JSON" will produce Extended JSON v2 output. * BSON_EXTJSON_RELAXED - if producing Extended JSON output, if this is true, values will use the "Relaxed" form of Extended JSON, which sacrifices type round-tripping for improved human readability. SEMANTIC VERSIONING SCHEME Starting with BSON "v0.999.0", this module is using a "tick-tock" three-part version-tuple numbering scheme: "vX.Y.Z" * In stable releases, "X" will be incremented for incompatible API changes. * Even-value increments of "Y" indicate stable releases with new functionality. "Z" will be incremented for bug fixes. * Odd-value increments of "Y" indicate unstable ("development") releases that should not be used in production. "Z" increments have no semantic meaning; they indicate only successive development releases. Development releases may have API-breaking changes, usually indicated by "Y" equal to "999". HISTORY AND ROADMAP This module was originally written by Stefan G. In 2014, he graciously transferred ongoing maintenance to MongoDB, Inc. The "bson_xxxx" helper functions in BSON::Types were inspired by similar work in Mango::BSON by Sebastian Riedel. SUPPORT Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at . You will be notified automatically of any progress on your issue. Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. git clone https://github.com/mongodb/mongo-perl-bson.git AUTHORS * David Golden * Stefan G. CONTRIBUTORS * Eric Daniels * Finn * Olivier Duclos * Pat Gunn * Petr Písař * Robert Sedlacek * Thomas Bloor * Tobias Leich * Wallace Reis * Yury Zavarin * Oleg Kostyuk COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 BSON-v1.12.1/META.yml000644 000765 000024 00000007022 13524525151 014232 0ustar00davidstaff000000 000000 --- abstract: 'BSON serialization and deserialization' author: - 'David Golden ' - 'Stefan G. ' build_requires: Data::Dumper: '0' Devel::Peek: '0' ExtUtils::MakeMaker: '0' File::Spec: '0' JSON::MaybeXS: '0' JSON::PP: '2.97001' Path::Tiny: '0.054' Test::Deep: '0' Test::Fatal: '0' Test::More: '0.96' lib: '0' perl: '5.010001' utf8: '0' configure_requires: ExtUtils::MakeMaker: '6.17' perl: '5.010001' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: BSON no_index: directory: - corpus - examples - t - xt package: - DB provides: BSON: file: lib/BSON.pm version: v1.12.1 BSON::Array: file: lib/BSON/Array.pm version: v1.12.1 BSON::Binary: file: lib/BSON/Binary.pm version: v1.12.1 BSON::Bool: file: lib/BSON/Bool.pm version: v1.12.1 BSON::Bytes: file: lib/BSON/Bytes.pm version: v1.12.1 BSON::Code: file: lib/BSON/Code.pm version: v1.12.1 BSON::DBPointer: file: lib/BSON/DBPointer.pm version: v1.12.1 BSON::DBRef: file: lib/BSON/DBRef.pm version: v1.12.1 BSON::Decimal128: file: lib/BSON/Decimal128.pm version: v1.12.1 BSON::Doc: file: lib/BSON/Doc.pm version: v1.12.1 BSON::Double: file: lib/BSON/Double.pm version: v1.12.1 BSON::Int32: file: lib/BSON/Int32.pm version: v1.12.1 BSON::Int64: file: lib/BSON/Int64.pm version: v1.12.1 BSON::MaxKey: file: lib/BSON/MaxKey.pm version: v1.12.1 BSON::MinKey: file: lib/BSON/MinKey.pm version: v1.12.1 BSON::OID: file: lib/BSON/OID.pm version: v1.12.1 BSON::ObjectId: file: lib/BSON/ObjectId.pm version: v1.12.1 BSON::PP: file: lib/BSON/PP.pm version: v1.12.1 BSON::Raw: file: lib/BSON/Raw.pm version: v1.12.1 BSON::Regex: file: lib/BSON/Regex.pm version: v1.12.1 BSON::String: file: lib/BSON/String.pm version: v1.12.1 BSON::Symbol: file: lib/BSON/Symbol.pm version: v1.12.1 BSON::Time: file: lib/BSON/Time.pm version: v1.12.1 BSON::Timestamp: file: lib/BSON/Timestamp.pm version: v1.12.1 BSON::Types: file: lib/BSON/Types.pm version: v1.12.1 requires: B: '0' Carp: '0' Crypt::URandom: '0' Exporter: '0' List::Util: '0' MIME::Base64: '0' Math::BigFloat: '0' Math::BigInt: '0' Moo: '2.002004' Scalar::Util: '0' Sys::Hostname: '0' Tie::IxHash: '0' Time::HiRes: '0' Time::Local: '0' base: '0' boolean: '0.45' constant: '0' if: '0' mro: '0' namespace::clean: '0' overload: '0' perl: '5.010001' re: '0' strict: '0' threads::shared: '0' version: '0' warnings: '0' resources: bugtracker: https://jira.mongodb.org/browse/PERL homepage: https://github.com/mongodb/mongo-perl-bson repository: https://github.com/mongodb/mongo-perl-bson.git version: v1.12.1 x_authority: cpan:MONGODB x_contributors: - 'Eric Daniels ' - 'Finn ' - 'Olivier Duclos ' - 'Pat Gunn ' - 'Petr Písař ' - 'Robert Sedlacek ' - 'Thomas Bloor ' - 'Tobias Leich ' - 'Wallace Reis ' - 'Yury Zavarin ' - 'Oleg Kostyuk ' x_generated_by_perl: v5.28.1 x_serialization_backend: 'YAML::Tiny version 1.73' BSON-v1.12.1/lib/000755 000765 000024 00000000000 13524525151 013526 5ustar00davidstaff000000 000000 BSON-v1.12.1/Makefile.PL000644 000765 000024 00000005246 13524525151 014741 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.012. use strict; use warnings; use 5.010001; use ExtUtils::MakeMaker 6.17; my %WriteMakefileArgs = ( "ABSTRACT" => "BSON serialization and deserialization", "AUTHOR" => "David Golden , Stefan G. ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.17" }, "DISTNAME" => "BSON", "LICENSE" => "apache", "MIN_PERL_VERSION" => "5.010001", "NAME" => "BSON", "PREREQ_PM" => { "B" => 0, "Carp" => 0, "Crypt::URandom" => 0, "Exporter" => 0, "List::Util" => 0, "MIME::Base64" => 0, "Math::BigFloat" => 0, "Math::BigInt" => 0, "Moo" => "2.002004", "Scalar::Util" => 0, "Sys::Hostname" => 0, "Tie::IxHash" => 0, "Time::HiRes" => 0, "Time::Local" => 0, "base" => 0, "boolean" => "0.45", "constant" => 0, "if" => 0, "mro" => 0, "namespace::clean" => 0, "overload" => 0, "re" => 0, "strict" => 0, "threads::shared" => 0, "version" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "Data::Dumper" => 0, "Devel::Peek" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "JSON::MaybeXS" => 0, "JSON::PP" => "2.97001", "Path::Tiny" => "0.054", "Test::Deep" => 0, "Test::Fatal" => 0, "Test::More" => "0.96", "lib" => 0, "utf8" => 0 }, "VERSION" => "v1.12.1", "test" => { "TESTS" => "t/*.t t/common/*.t t/corpus/*.t t/legacy/*.t t/mapping/*.t t/regression/*.t" } ); my %FallbackPrereqs = ( "B" => 0, "Carp" => 0, "Crypt::URandom" => 0, "Data::Dumper" => 0, "Devel::Peek" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "JSON::MaybeXS" => 0, "JSON::PP" => "2.97001", "List::Util" => 0, "MIME::Base64" => 0, "Math::BigFloat" => 0, "Math::BigInt" => 0, "Moo" => "2.002004", "Path::Tiny" => "0.054", "Scalar::Util" => 0, "Sys::Hostname" => 0, "Test::Deep" => 0, "Test::Fatal" => 0, "Test::More" => "0.96", "Tie::IxHash" => 0, "Time::HiRes" => 0, "Time::Local" => 0, "base" => 0, "boolean" => "0.45", "constant" => 0, "if" => 0, "lib" => 0, "mro" => 0, "namespace::clean" => 0, "overload" => 0, "re" => 0, "strict" => 0, "threads::shared" => 0, "utf8" => 0, "version" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); BSON-v1.12.1/META.json000644 000765 000024 00000015304 13524525151 014404 0ustar00davidstaff000000 000000 { "abstract" : "BSON serialization and deserialization", "author" : [ "David Golden ", "Stefan G. " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "BSON", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17", "perl" : "5.010001" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::Meta::Contributors" : "0", "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Apache_2_0" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1" } }, "runtime" : { "requires" : { "B" : "0", "Carp" : "0", "Crypt::URandom" : "0", "Exporter" : "0", "List::Util" : "0", "MIME::Base64" : "0", "Math::BigFloat" : "0", "Math::BigInt" : "0", "Moo" : "2.002004", "Scalar::Util" : "0", "Sys::Hostname" : "0", "Tie::IxHash" : "0", "Time::HiRes" : "0", "Time::Local" : "0", "base" : "0", "boolean" : "0.45", "constant" : "0", "if" : "0", "mro" : "0", "namespace::clean" : "0", "overload" : "0", "perl" : "5.010001", "re" : "0", "strict" : "0", "threads::shared" : "0", "version" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "Data::Dumper" : "0", "Devel::Peek" : "0", "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "JSON::MaybeXS" : "0", "JSON::PP" : "2.97001", "Path::Tiny" : "0.054", "Test::Deep" : "0", "Test::Fatal" : "0", "Test::More" : "0.96", "lib" : "0", "perl" : "5.010001", "utf8" : "0" } } }, "provides" : { "BSON" : { "file" : "lib/BSON.pm", "version" : "v1.12.1" }, "BSON::Array" : { "file" : "lib/BSON/Array.pm", "version" : "v1.12.1" }, "BSON::Binary" : { "file" : "lib/BSON/Binary.pm", "version" : "v1.12.1" }, "BSON::Bool" : { "file" : "lib/BSON/Bool.pm", "version" : "v1.12.1" }, "BSON::Bytes" : { "file" : "lib/BSON/Bytes.pm", "version" : "v1.12.1" }, "BSON::Code" : { "file" : "lib/BSON/Code.pm", "version" : "v1.12.1" }, "BSON::DBPointer" : { "file" : "lib/BSON/DBPointer.pm", "version" : "v1.12.1" }, "BSON::DBRef" : { "file" : "lib/BSON/DBRef.pm", "version" : "v1.12.1" }, "BSON::Decimal128" : { "file" : "lib/BSON/Decimal128.pm", "version" : "v1.12.1" }, "BSON::Doc" : { "file" : "lib/BSON/Doc.pm", "version" : "v1.12.1" }, "BSON::Double" : { "file" : "lib/BSON/Double.pm", "version" : "v1.12.1" }, "BSON::Int32" : { "file" : "lib/BSON/Int32.pm", "version" : "v1.12.1" }, "BSON::Int64" : { "file" : "lib/BSON/Int64.pm", "version" : "v1.12.1" }, "BSON::MaxKey" : { "file" : "lib/BSON/MaxKey.pm", "version" : "v1.12.1" }, "BSON::MinKey" : { "file" : "lib/BSON/MinKey.pm", "version" : "v1.12.1" }, "BSON::OID" : { "file" : "lib/BSON/OID.pm", "version" : "v1.12.1" }, "BSON::ObjectId" : { "file" : "lib/BSON/ObjectId.pm", "version" : "v1.12.1" }, "BSON::PP" : { "file" : "lib/BSON/PP.pm", "version" : "v1.12.1" }, "BSON::Raw" : { "file" : "lib/BSON/Raw.pm", "version" : "v1.12.1" }, "BSON::Regex" : { "file" : "lib/BSON/Regex.pm", "version" : "v1.12.1" }, "BSON::String" : { "file" : "lib/BSON/String.pm", "version" : "v1.12.1" }, "BSON::Symbol" : { "file" : "lib/BSON/Symbol.pm", "version" : "v1.12.1" }, "BSON::Time" : { "file" : "lib/BSON/Time.pm", "version" : "v1.12.1" }, "BSON::Timestamp" : { "file" : "lib/BSON/Timestamp.pm", "version" : "v1.12.1" }, "BSON::Types" : { "file" : "lib/BSON/Types.pm", "version" : "v1.12.1" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://jira.mongodb.org/browse/PERL" }, "homepage" : "https://github.com/mongodb/mongo-perl-bson", "repository" : { "type" : "git", "url" : "https://github.com/mongodb/mongo-perl-bson.git", "web" : "https://github.com/mongodb/mongo-perl-bson" } }, "version" : "v1.12.1", "x_authority" : "cpan:MONGODB", "x_contributors" : [ "Eric Daniels ", "Finn ", "Olivier Duclos ", "Pat Gunn ", "Petr P\u00edsa\u0159 ", "Robert Sedlacek ", "Thomas Bloor ", "Tobias Leich ", "Wallace Reis ", "Yury Zavarin ", "Oleg Kostyuk " ], "x_generated_by_perl" : "v5.28.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.09" } BSON-v1.12.1/dist.ini000644 000765 000024 00000002300 13524525151 014417 0ustar00davidstaff000000 000000 name = BSON author = David Golden author = Stefan G. license = Apache_2_0 copyright_holder = Stefan G. and MongoDB, Inc. [@DAGOLDEN] :version = 0.072 authority = cpan:MONGODB github_issues = 0 Bugtracker.web = https://jira.mongodb.org/browse/PERL UploadToCPAN.pause_cfg_file = .pause-mongodb Test::ReportPrereqs.include[0] = JSON::PP Test::ReportPrereqs.include[1] = JSON::XS Test::ReportPrereqs.include[2] = CPanel::JSON::XS Test::MinimumVersion.max_target_perl = 5.010001 stopwords = OIDs stopwords = ObjectID stopwords = PCRE stopwords = Riedel stopwords = VERSIONING stopwords = bson stopwords = codec stopwords = codecs stopwords = dbrefs stopwords = ixhash stopwords = numification stopwords = oid stopwords = sharding stopwords = tock [ReleaseStatus::FromVersion] testing = second_element_odd [Meta::Contributors] contributor = Oleg Kostyuk [RemovePrereqs] remove = DateTime remove = DateTime::Tiny remove = Mango::BSON::Time remove = Math::Int64 remove = MongoDB remove = MongoDB::BSON::Binary remove = MongoDB::BSON::Regexp remove = MongoDB::Code remove = MongoDB::DBRef remove = MongoDB::OID remove = MongoDB::Timestamp remove = Time::Moment BSON-v1.12.1/lib/BSON/000755 000765 000024 00000000000 13524525151 014267 5ustar00davidstaff000000 000000 BSON-v1.12.1/lib/BSON.pm000644 000765 000024 00000135631 13524525151 014636 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON; # ABSTRACT: BSON serialization and deserialization use base 'Exporter'; our @EXPORT_OK = qw/encode decode/; use version; our $VERSION = 'v1.12.1'; use Carp; use Config; use Scalar::Util qw/blessed looks_like_number/; use Moo 2.002004; # safer generated code use boolean; use BSON::OID; use constant { HAS_INT64 => $Config{use64bitint}, HAS_LD => $Config{uselongdouble}, }; use if !HAS_INT64, "Math::BigInt"; my $bools_re = qr/::(?:Boolean|_Bool|Bool)\z/; use namespace::clean -except => 'meta'; my $max_int32 = 2147483647; # Dependency-free equivalent of what we need from Module::Runtime sub _try_load { my ( $mod, $ver ) = @_; ( my $file = "$mod.pm" ) =~ s{::}{/}g; my $load = eval { require $file; $mod->VERSION($ver) if defined $ver; 1 }; delete $INC{$file} if !$load; # for old, broken perls die $@ if !$load; return 1; } BEGIN { my ($class, @errs); if ( $class = $ENV{PERL_BSON_BACKEND} ) { eval { _try_load($class) }; if ( my $err = $@ ) { $err =~ s{ at \S+ line .*}{}; die "Error: PERL_BSON_BACKEND '$class' could not be loaded: $err\n"; } unless ($class->can("_encode_bson") && $class->can("_decode_bson") ) { die "Error: PERL_BSON_BACKEND '$class' does not implement the correct API.\n"; } } elsif ( eval { _try_load( $class = "BSON::XS" ) } or do { push @errs, $@; 0 } ) { # module loaded; nothing else to do } elsif ( eval { _try_load( $class = "BSON::PP" ) } or do { push @errs, $@; 0 } ) { # module loaded; nothing else to do } else { s/\n/ /g for @errs; die join( "\n* ", "Error: Couldn't load a BSON backend:", @errs ) . "\n"; } *_encode_bson = $class->can("_encode_bson"); *_decode_bson = $class->can("_decode_bson"); *_backend_class = sub { $class }; # for debugging } # LOAD AFTER XS/PP, so that modules can pick up right version of helpers use BSON::Types (); # loads types for extjson inflation #--------------------------------------------------------------------------# # public attributes #--------------------------------------------------------------------------# #pod =attr error_callback #pod #pod This attribute specifies a function reference that will be called with #pod three positional arguments: #pod #pod =for :list #pod * an error string argument describing the error condition #pod * a reference to the problematic document or byte-string #pod * the method in which the error occurred (e.g. C or C) #pod #pod Note: for decoding errors, the byte-string is passed as a reference to avoid #pod copying possibly large strings. #pod #pod If not provided, errors messages will be thrown with C. #pod #pod =cut has error_callback => ( is => 'ro', isa => sub { die "not a code reference" if defined $_[0] && ! ref $_[0] eq 'CODE' }, ); #pod =attr invalid_chars #pod #pod A string containing ASCII characters that must not appear in keys. The default #pod is the empty string, meaning there are no invalid characters. #pod #pod =cut has invalid_chars => ( is => 'ro', isa => sub { die "not a string" if ! defined $_[0] || ref $_[0] }, ); #pod =attr max_length #pod #pod This attribute defines the maximum document size. The default is 0, which #pod disables any maximum. #pod #pod If set to a positive number, it applies to both encoding B decoding (the #pod latter is necessary for prevention of resource consumption attacks). #pod #pod =cut has max_length => ( is => 'ro', isa => sub { die "not a non-negative number" unless defined $_[0] && $_[0] >= 0 }, ); #pod =attr op_char #pod #pod This is a single character to use for special MongoDB-specific query #pod operators. If a key starts with C, the C character will #pod be replaced with "$". #pod #pod The default is "$", meaning that no replacement is necessary. #pod #pod =cut has op_char => ( is => 'ro', isa => sub { die "not a single character" if defined $_[0] && length $_[0] > 1 }, ); #pod =attr ordered #pod #pod If set to a true value, then decoding will return a reference to a tied #pod hash that preserves key order. Otherwise, a regular (unordered) hash #pod reference will be returned. #pod #pod B: #pod #pod =for :list #pod * When 'ordered' is true, users must not rely on the return value being any #pod particular tied hash implementation. It may change in the future for #pod efficiency. #pod * Turning this option on entails a significant speed penalty as tied hashes #pod are slower than regular Perl hashes. #pod #pod The default is false. #pod #pod =cut has ordered => ( is => 'ro', ); #pod =attr prefer_numeric #pod #pod When false, scalar values will be encoded as a number if they were #pod originally a number or were ever used in a numeric context. However, a #pod string that looks like a number but was never used in a numeric context #pod (e.g. "42") will be encoded as a string. #pod #pod If C is set to true, the encoder will attempt to coerce #pod strings that look like a number into a numeric value. If the string #pod doesn't look like a double or integer, it will be encoded as a string. #pod #pod B: the heuristics for determining whether something is a #pod string or number are less accurate on older Perls. See L #pod for wrapper classes that specify exact serialization types. #pod #pod The default is false. #pod #pod =cut has prefer_numeric => ( is => 'ro', ); #pod =attr wrap_dbrefs #pod #pod If set to true, during decoding, documents with the fields C<'$id'> and #pod C<'$ref'> (literal dollar signs, not variables) will be wrapped as #pod L objects. If false, they are decoded into ordinary hash #pod references (or ordered hashes, if C is true). #pod #pod The default is true. #pod #pod =cut has wrap_dbrefs => ( is => 'ro', ); #pod =attr wrap_numbers #pod #pod If set to true, during decoding, numeric values will be wrapped into #pod BSON type-wrappers: L, L or L. #pod While very slow, this can help ensure fields can round-trip if unmodified. #pod #pod The default is false. #pod #pod =cut has wrap_numbers => ( is => 'ro', ); #pod =attr wrap_strings #pod #pod If set to true, during decoding, string values will be wrapped into a BSON #pod type-wrappers, L. While very slow, this can help ensure #pod fields can round-trip if unmodified. #pod #pod The default is false. #pod #pod =cut has wrap_strings => ( is => 'ro', ); #pod =attr dt_type (Discouraged) #pod #pod Sets the type of object which is returned for BSON DateTime fields. The #pod default is C, which returns objects of type L. This is #pod overloaded to be the integer epoch value when used as a number or string, #pod so is somewhat backwards compatible with C in the L #pod driver. #pod #pod Other acceptable values are L (explicitly), L, #pod L, L, L. #pod #pod Because BSON::Time objects have methods to convert to DateTime, #pod Time::Moment or DateTime::Tiny, use of this field is discouraged. Users #pod should use these methods on demand. This option is provided for backwards #pod compatibility only. #pod #pod =cut has dt_type => ( is => 'ro', isa => sub { return if !defined($_[0]); die "not a string" if ref $_[0] }, ); sub BUILD { my ($self) = @_; $self->{wrap_dbrefs} = 1 unless defined $self->{wrap_dbrefs}; $self->{invalid_chars} = "" unless defined $self->{invalid_chars}; } #--------------------------------------------------------------------------# # public methods #--------------------------------------------------------------------------# #pod =method encode_one #pod #pod $byte_string = $codec->encode_one( $doc ); #pod $byte_string = $codec->encode_one( $doc, \%options ); #pod #pod Takes a "document", typically a hash reference, an array reference, or a #pod Tie::IxHash object and returns a byte string with the BSON representation of #pod the document. #pod #pod An optional hash reference of options may be provided. Valid options include: #pod #pod =for :list #pod * first_key – if C is defined, it and C #pod will be encoded first in the output BSON; any matching key found in the #pod document will be ignored. #pod * first_value - value to assign to C; will encode as Null if omitted #pod * error_callback – overrides codec default #pod * invalid_chars – overrides codec default #pod * max_length – overrides codec default #pod * op_char – overrides codec default #pod * prefer_numeric – overrides codec default #pod #pod =cut sub encode_one { my ( $self, $document, $options ) = @_; my $type = ref($document); Carp::croak "Can't encode scalars" unless $type; # qr// is blessed to 'Regexp'; if ( $type eq "Regexp" || !( blessed($document) || $type eq 'HASH' || $type eq 'ARRAY' ) ) { Carp::croak "Can't encode non-container of type '$type'"; } $document = BSON::Doc->new(@$document) if $type eq 'ARRAY'; my $merged_opts = { %$self, ( $options ? %$options : () ) }; my $bson = eval { _encode_bson( $document, $merged_opts ) }; # XXX this is a late max_length check -- it should be checked during # encoding after each key if ( $@ or ( $merged_opts->{max_length} && length($bson) > $merged_opts->{max_length} ) ) { my $msg = $@ || "Document exceeds maximum size $merged_opts->{max_length}"; if ( $merged_opts->{error_callback} ) { $merged_opts->{error_callback}->( $msg, $document, 'encode_one' ); } else { Carp::croak("During encode_one, $msg"); } } return $bson; } #pod =method decode_one #pod #pod $doc = $codec->decode_one( $byte_string ); #pod $doc = $codec->decode_one( $byte_string, \%options ); #pod #pod Takes a byte string with a BSON-encoded document and returns a #pod hash reference representing the decoded document. #pod #pod An optional hash reference of options may be provided. Valid options include: #pod #pod =for :list #pod * dt_type – overrides codec default #pod * error_callback – overrides codec default #pod * max_length – overrides codec default #pod * ordered - overrides codec default #pod * wrap_dbrefs - overrides codec default #pod * wrap_numbers - overrides codec default #pod * wrap_strings - overrides codec default #pod #pod =cut sub decode_one { my ( $self, $string, $options ) = @_; my $merged_opts = { %$self, ( $options ? %$options : () ) }; if ( $merged_opts->{max_length} && length($string) > $merged_opts->{max_length} ) { my $msg = "Document exceeds maximum size $merged_opts->{max_length}"; if ( $merged_opts->{error_callback} ) { $merged_opts->{error_callback}->( $msg, \$string, 'decode_one' ); } else { Carp::croak("During decode_one, $msg"); } } my $document = eval { _decode_bson( $string, $merged_opts ) }; if ( $@ ) { if ( $merged_opts->{error_callback} ) { $merged_opts->{error_callback}->( $@, \$string, 'decode_one' ); } else { Carp::croak("During decode_one, $@"); } } return $document; } #pod =method clone #pod #pod $copy = $codec->clone( ordered => 1 ); #pod #pod Constructs a copy of the original codec, but allows changing #pod attributes in the copy. #pod #pod =cut sub clone { my ($self, @args) = @_; my $class = ref($self); if ( @args == 1 && ref( $args[0] ) eq 'HASH' ) { return $class->new( %$self, %{$args[0]} ); } return $class->new( %$self, @args ); } #--------------------------------------------------------------------------# # public class methods #--------------------------------------------------------------------------# #pod =method create_oid #pod #pod $oid = BSON->create_oid; #pod #pod This class method returns a new L. This abstracts OID #pod generation away from any specific Object ID class and makes it an interface #pod on a BSON codec. Alternative BSON codecs should define a similar class #pod method that returns an Object ID of whatever type is appropriate. #pod #pod =cut sub create_oid { return BSON::OID->new } #pod =method inflate_extjson (DEPRECATED) #pod #pod This legacy method does not follow the L #pod specification. #pod #pod Use L instead. #pod #pod =cut sub inflate_extjson { my ( $self, $hash ) = @_; for my $k ( keys %$hash ) { my $v = $hash->{$k}; if ( substr( $k, 0, 1 ) eq '$' ) { croak "Dollar-prefixed key '$k' is not legal in top-level hash"; } my $type = ref($v); $hash->{$k} = $type eq 'HASH' ? $self->_inflate_hash($v) : $type eq 'ARRAY' ? $self->_inflate_array($v) : $type =~ $bools_re ? ( $v ? true : false ) : $v; } return $hash; } #pod =method perl_to_extjson #pod #pod use JSON::MaybeXS; #pod my $ext = BSON->perl_to_extjson($data, \%options); #pod my $json = encode_json($ext); #pod #pod Takes a perl data structure (i.e. hashref) and turns it into an #pod L #pod structure. Note that the structure will still have to be serialized. #pod #pod Possible options are: #pod #pod =for :list #pod * C A boolean indicating if "relaxed extended JSON" should #pod be generated. If not set, the default value is taken from the #pod C environment variable. #pod #pod =cut my $use_win32_specials = ($^O eq 'MSWin32' && $] lt "5.022"); my $is_inf = $use_win32_specials ? qr/^1.\#INF/i : qr/^inf/i; my $is_ninf = $use_win32_specials ? qr/^-1.\#INF/i : qr/^-inf/i; my $is_nan = $use_win32_specials ? qr/^-?1.\#(?:IND|QNAN)/i : qr/^-?nan/i; sub perl_to_extjson { my ($class, $data, $options) = @_; local $ENV{BSON_EXTJSON} = 1; local $ENV{BSON_EXTJSON_RELAXED} = $ENV{BSON_EXTJSON_RELAXED}; $ENV{BSON_EXTJSON_RELAXED} = $options->{relaxed}; if (not defined $data) { return undef; ## no critic } if (blessed($data) and $data->can('TO_JSON')) { my $json_data = $data->TO_JSON; return $json_data; } if (not ref $data) { if (looks_like_number($data)) { if ($ENV{BSON_EXTJSON_RELAXED}) { return $data; } if ($data =~ m{\A-?[0-9_]+\z}) { if ($data <= $max_int32) { return { '$numberInt' => "$data" }; } else { return { '$numberLong' => "$data" }; } } else { return { '$numberDouble' => 'Infinity' } if $data =~ $is_inf; return { '$numberDouble' => '-Infinity' } if $data =~ $is_ninf; return { '$numberDouble' => 'NaN' } if $data =~ $is_nan; my $value = "$data"; $value = $value / 1.0; return { '$numberDouble' => "$value" }; } } return $data; } if (boolean::isBoolean($data)) { return $data; } if (ref $data eq 'HASH') { for my $key (keys %$data) { my $value = $data->{$key}; $data->{$key} = $class->perl_to_extjson($value, $options); } return $data; } if (ref $data eq 'ARRAY') { for my $index (0 .. $#$data) { my $value = $data->[$index]; $data->[$index] = $class->perl_to_extjson($value, $options); } return $data; } if (blessed($data) and $data->isa('JSON::PP::Boolean')) { return $data; } if ( blessed($data) and ( $data->isa('Math::BigInt') or $data->isa('Math::BigFloat') ) ) { return $data; } die sprintf "Unsupported ref value (%s)", ref($data); } #pod =method extjson_to_perl #pod #pod use JSON::MaybeXS; #pod my $ext = decode_json($json); #pod my $data = $bson->extjson_to_perl($ext); #pod #pod Takes an #pod L #pod data structure and inflates it into a Perl data structure. Note that #pod you have to decode the JSON string manually beforehand. #pod #pod Canonically specified numerical values like C<{"$numberInt":"23"}> will #pod be inflated into their respective C wrapper types. Plain numeric #pod values will be left as-is. #pod #pod =cut sub extjson_to_perl { my ($class, $data) = @_; # top level keys are never extended JSON elements, so we wrap the # _extjson_to_perl inflater so it applies only to values, not the # original data structure for my $key (keys %$data) { my $value = $data->{$key}; $data->{$key} = $class->_extjson_to_perl($value); } return $data; } sub _extjson_to_perl { my ($class, $data) = @_; if (ref $data eq 'HASH') { if ( exists $data->{'$oid'} ) { return BSON::OID->new( oid => pack( "H*", $data->{'$oid'} ) ); } if ( exists $data->{'$numberInt'} ) { return BSON::Int32->new( value => $data->{'$numberInt'} ); } if ( exists $data->{'$numberLong'} ) { if (HAS_INT64) { return BSON::Int64->new( value => $data->{'$numberLong'} ); } else { return BSON::Int64->new( value => Math::BigInt->new($data->{'$numberLong'}) ); } } if ( exists $data->{'$binary'} ) { require MIME::Base64; if (exists $data->{'$type'}) { return BSON::Bytes->new( data => MIME::Base64::decode_base64($data->{'$binary'}), subtype => hex( $data->{'$type'} || 0 ), ); } else { my $value = $data->{'$binary'}; return BSON::Bytes->new( data => MIME::Base64::decode_base64($value->{base64}), subtype => hex( $value->{subType} || 0 ), ); } } if ( exists $data->{'$date'} ) { my $v = $data->{'$date'}; $v = ref($v) eq 'HASH' ? $class->_extjson_to_perl($v) : _iso8601_to_epochms($v); return BSON::Time->new( value => $v ); } if ( exists $data->{'$minKey'} ) { return BSON::MinKey->new; } if ( exists $data->{'$maxKey'} ) { return BSON::MaxKey->new; } if ( exists $data->{'$timestamp'} ) { return BSON::Timestamp->new( seconds => $data->{'$timestamp'}{t}, increment => $data->{'$timestamp'}{i}, ); } if ( exists $data->{'$regex'} and not ref $data->{'$regex'}) { return BSON::Regex->new( pattern => $data->{'$regex'}, ( exists $data->{'$options'} ? ( flags => $data->{'$options'} ) : () ), ); } if ( exists $data->{'$regularExpression'} ) { my $value = $data->{'$regularExpression'}; return BSON::Regex->new( pattern => $value->{pattern}, ( exists $value->{options} ? ( flags => $value->{options} ) : () ), ); } if ( exists $data->{'$code'} ) { return BSON::Code->new( code => $data->{'$code'}, ( exists $data->{'$scope'} ? ( scope => $class->_extjson_to_perl($data->{'$scope'}) ) : () ), ); } if ( exists $data->{'$undefined'} ) { return undef; ## no critic } if ( exists $data->{'$dbPointer'} ) { my $data = $data->{'$dbPointer'}; my $id = $data->{'$id'}; $id = $class->_extjson_to_perl($id) if ref($id) eq 'HASH'; return BSON::DBPointer->new( '$ref' => $data->{'$ref'}, '$id' => $id, ); } if ( exists $data->{'$ref'} ) { my $id = delete $data->{'$id'}; $id = $class->_extjson_to_perl($id) if ref($id) eq 'HASH'; return BSON::DBRef->new( '$ref' => delete $data->{'$ref'}, '$id' => $id, '$db' => delete $data->{'$db'}, %$data, # extra ); } if ( exists $data->{'$numberDecimal'} ) { return BSON::Decimal128->new( value => $data->{'$numberDecimal'} ); } # Following extended JSON is non-standard if ( exists $data->{'$numberDouble'} ) { if ( $data->{'$numberDouble'} eq '-0' && $] lt '5.014' && ! HAS_LD ) { $data->{'$numberDouble'} = '-0.0'; } return BSON::Double->new( value => $data->{'$numberDouble'} ); } if ( exists $data->{'$symbol'} ) { return BSON::Symbol->new(value => $data->{'$symbol'}); } for my $key (keys %$data) { my $value = $data->{$key}; $data->{$key} = $class->_extjson_to_perl($value); } return $data; } if (ref $data eq 'ARRAY') { for my $index (0 .. $#$data) { my $value = $data->[$index]; $data->[$index] = ref($value) ? $class->_extjson_to_perl($value) : $value; } return $data; } return $data; } #--------------------------------------------------------------------------# # legacy functional interface #--------------------------------------------------------------------------# #pod =func encode #pod #pod my $bson = encode({ bar => 'foo' }, \%options); #pod #pod This is the legacy, functional interface and is only exported on demand. #pod It takes a hashref and returns a BSON string. #pod It uses an internal codec singleton with default attributes. #pod #pod =func decode #pod #pod my $hash = decode( $bson, \%options ); #pod #pod This is the legacy, functional interface and is only exported on demand. #pod It takes a BSON string and returns a hashref. #pod It uses an internal codec singleton with default attributes. #pod #pod =cut { my $CODEC; sub encode { if ( defined $_[0] && ( $_[0] eq 'BSON' || ( blessed($_[0]) && $_[0]->isa('BSON') ) ) ) { Carp::croak("Error: 'encode' is a function, not a method"); } my $doc = shift; $CODEC = BSON->new unless defined $CODEC; if ( @_ == 1 && ref( $_[0] ) eq 'HASH' ) { return $CODEC->encode_one( $doc, $_[0] ); } elsif ( @_ % 2 == 0 ) { return $CODEC->encode_one( $doc, {@_} ); } else { Carp::croak("Options for 'encode' must be a hashref or key-value pairs"); } } sub decode { if ( defined $_[0] && ( $_[0] eq 'BSON' || ( blessed($_[0]) && $_[0]->isa('BSON') ) ) ) { Carp::croak("Error: 'decode' is a function, not a method"); } my $doc = shift; $CODEC = BSON->new unless defined $CODEC; my $args; if ( @_ == 1 && ref( $_[0] ) eq 'HASH' ) { $args = shift; } elsif ( @_ % 2 == 0 ) { $args = { @_ }; } else { Carp::croak("Options for 'decode' must be a hashref or key-value pairs"); } $args->{ordered} = delete $args->{ixhash} if exists $args->{ixhash} && !exists $args->{ordered}; return $CODEC->decode_one( $doc, $args ); } } #--------------------------------------------------------------------------# # private functions #--------------------------------------------------------------------------# sub _inflate_hash { my ( $class, $hash ) = @_; if ( exists $hash->{'$oid'} ) { return BSON::OID->new( oid => pack( "H*", $hash->{'$oid'} ) ); } if ( exists $hash->{'$numberInt'} ) { return BSON::Int32->new( value => $hash->{'$numberInt'} ); } if ( exists $hash->{'$numberLong'} ) { if (HAS_INT64) { return BSON::Int64->new( value => $hash->{'$numberLong'} ); } else { return BSON::Int64->new( value => Math::BigInt->new($hash->{'$numberLong'}) ); } } if ( exists $hash->{'$binary'} ) { require MIME::Base64; return BSON::Bytes->new( data => MIME::Base64::decode_base64($hash->{'$binary'}), subtype => hex( $hash->{'$type'} || 0 ) ); } if ( exists $hash->{'$date'} ) { my $v = $hash->{'$date'}; $v = ref($v) eq 'HASH' ? BSON->_inflate_hash($v) : _iso8601_to_epochms($v); return BSON::Time->new( value => $v ); } if ( exists $hash->{'$minKey'} ) { return BSON::MinKey->new; } if ( exists $hash->{'$maxKey'} ) { return BSON::MaxKey->new; } if ( exists $hash->{'$timestamp'} ) { return BSON::Timestamp->new( seconds => $hash->{'$timestamp'}{t}, increment => $hash->{'$timestamp'}{i}, ); } if ( exists $hash->{'$regex'} ) { return BSON::Regex->new( pattern => $hash->{'$regex'}, ( exists $hash->{'$options'} ? ( flags => $hash->{'$options'} ) : () ), ); } if ( exists $hash->{'$code'} ) { return BSON::Code->new( code => $hash->{'$code'}, ( exists $hash->{'$scope'} ? ( scope => $hash->{'$scope'} ) : () ), ); } if ( exists $hash->{'$undefined'} ) { return undef; ## no critic } if ( exists $hash->{'$ref'} ) { my $id = $hash->{'$id'}; $id = BSON->_inflate_hash($id) if ref($id) eq 'HASH'; return BSON::DBRef->new( '$ref' => $hash->{'$ref'}, '$id' => $id ); } if ( exists $hash->{'$numberDecimal'} ) { return BSON::Decimal128->new( value => $hash->{'$numberDecimal'} ); } # Following extended JSON is non-standard if ( exists $hash->{'$numberDouble'} ) { if ( $hash->{'$numberDouble'} eq '-0' && $] lt '5.014' && ! HAS_LD ) { $hash->{'$numberDouble'} = '-0.0'; } return BSON::Double->new( value => $hash->{'$numberDouble'} ); } if ( exists $hash->{'$symbol'} ) { return $hash->{'$symbol'}; } return $hash; } sub _inflate_array { my ($class, $array) = @_; if (@$array) { for my $i ( 0 .. $#$array ) { my $v = $array->[$i]; $array->[$i] = ref($v) eq 'HASH' ? BSON->_inflate_hash($v) : ref($v) eq 'ARRAY' ? _inflate_array($v) : $v; } } return $array; } my $iso8601_re = qr{ (\d{4}) - (\d{2}) - (\d{2}) T # date (\d{2}) : (\d{2}) : ( \d+ (?:\. \d+ )? ) # time (?: Z | ([+-] \d{2} :? (?: \d{2} )? ) )? # maybe TZ }x; sub _iso8601_to_epochms { my ($date) = shift; require Time::Local; my $zone_offset = 0;; if ( substr($date,-1,1) eq 'Z' ) { chop($date); } if ( $date =~ /\A$iso8601_re\z/ ) { my ($Y,$M,$D,$h,$m,$s,$z) = ($1,$2-1,$3,$4,$5,$6,$7); if (defined($z) && length($z)) { $z =~ tr[:][]; $z .= "00" if length($z) < 5; my $zd = substr($z,0,1); my $zh = substr($z,1,2); my $zm = substr($z,3,2); $zone_offset = ($zd eq '-' ? -1 : 1 ) * (3600 * $zh + 60 * $zm); } my $frac = $s - int($s); my $epoch = Time::Local::timegm(int($s), $m, $h, $D, $M, $Y) - $zone_offset; $epoch = HAS_INT64 ? 1000 * $epoch : Math::BigInt->new($epoch) * 1000; $epoch += HAS_INT64 ? $frac * 1000 : Math::BigFloat->new($frac) * 1000; return $epoch; } else { Carp::croak("Couldn't parse '\$date' field: $date\n"); } } 1; =pod =encoding UTF-8 =head1 NAME BSON - BSON serialization and deserialization =head1 VERSION version v1.12.1 =head1 END OF LIFE NOTICE Version v1.12.0 is the final feature release of the MongoDB BSON library. The library is now in a 12-month "sunset" period and will receive security patches and critical bug fixes only. The BSON library will be end-of-life and unsupported on August 13, 2020. =head1 SYNOPSIS use BSON; use BSON::Types ':all'; use boolean; my $codec = BSON->new; my $document = { _id => bson_oid(), creation_time => bson_time(), # now zip_code => bson_string("08544"), hidden => false, }; my $bson = $codec->encode_one( $document ); my $doc = $codec->decode_one( $bson ); =head1 DESCRIPTION This class implements a BSON encoder/decoder ("codec"). It consumes "documents" (typically hash references) and emits BSON strings and vice versa in accordance with the L. BSON is the primary data representation for L. While this module has several features that support MongoDB-specific needs and conventions, it can be used as a standalone serialization format. The codec may be customized through attributes on the codec option as well as encode/decode specific options on methods: my $codec = BSON->new( \%global_attributes ); my $bson = $codec->encode_one( $document, \%encode_options ); my $doc = $codec->decode_one( $bson , \%decode_options ); Because BSON is strongly-typed and Perl is not, this module supports a number of "type wrappers" – classes that wrap Perl data to indicate how they should serialize. The L module describes these and provides associated helper functions. See L for more details. When decoding, type wrappers are used for any data that has no native Perl representation. Optionally, all data may be wrapped for precise control of round-trip encoding. Please read the configuration attributes carefully to understand more about how to control encoding and decoding. At compile time, this module will select an implementation backend. It will prefer C (released separately) if available, or will fall back to L (bundled with this module). See L for a way to control the selection of the backend. =head1 ATTRIBUTES =head2 error_callback This attribute specifies a function reference that will be called with three positional arguments: =over 4 =item * an error string argument describing the error condition =item * a reference to the problematic document or byte-string =item * the method in which the error occurred (e.g. C or C) =back Note: for decoding errors, the byte-string is passed as a reference to avoid copying possibly large strings. If not provided, errors messages will be thrown with C. =head2 invalid_chars A string containing ASCII characters that must not appear in keys. The default is the empty string, meaning there are no invalid characters. =head2 max_length This attribute defines the maximum document size. The default is 0, which disables any maximum. If set to a positive number, it applies to both encoding B decoding (the latter is necessary for prevention of resource consumption attacks). =head2 op_char This is a single character to use for special MongoDB-specific query operators. If a key starts with C, the C character will be replaced with "$". The default is "$", meaning that no replacement is necessary. =head2 ordered If set to a true value, then decoding will return a reference to a tied hash that preserves key order. Otherwise, a regular (unordered) hash reference will be returned. B: =over 4 =item * When 'ordered' is true, users must not rely on the return value being any particular tied hash implementation. It may change in the future for efficiency. =item * Turning this option on entails a significant speed penalty as tied hashes are slower than regular Perl hashes. =back The default is false. =head2 prefer_numeric When false, scalar values will be encoded as a number if they were originally a number or were ever used in a numeric context. However, a string that looks like a number but was never used in a numeric context (e.g. "42") will be encoded as a string. If C is set to true, the encoder will attempt to coerce strings that look like a number into a numeric value. If the string doesn't look like a double or integer, it will be encoded as a string. B: the heuristics for determining whether something is a string or number are less accurate on older Perls. See L for wrapper classes that specify exact serialization types. The default is false. =head2 wrap_dbrefs If set to true, during decoding, documents with the fields C<'$id'> and C<'$ref'> (literal dollar signs, not variables) will be wrapped as L objects. If false, they are decoded into ordinary hash references (or ordered hashes, if C is true). The default is true. =head2 wrap_numbers If set to true, during decoding, numeric values will be wrapped into BSON type-wrappers: L, L or L. While very slow, this can help ensure fields can round-trip if unmodified. The default is false. =head2 wrap_strings If set to true, during decoding, string values will be wrapped into a BSON type-wrappers, L. While very slow, this can help ensure fields can round-trip if unmodified. The default is false. =head2 dt_type (Discouraged) Sets the type of object which is returned for BSON DateTime fields. The default is C, which returns objects of type L. This is overloaded to be the integer epoch value when used as a number or string, so is somewhat backwards compatible with C in the L driver. Other acceptable values are L (explicitly), L, L, L, L. Because BSON::Time objects have methods to convert to DateTime, Time::Moment or DateTime::Tiny, use of this field is discouraged. Users should use these methods on demand. This option is provided for backwards compatibility only. =head1 METHODS =head2 encode_one $byte_string = $codec->encode_one( $doc ); $byte_string = $codec->encode_one( $doc, \%options ); Takes a "document", typically a hash reference, an array reference, or a Tie::IxHash object and returns a byte string with the BSON representation of the document. An optional hash reference of options may be provided. Valid options include: =over 4 =item * first_key – if C is defined, it and C will be encoded first in the output BSON; any matching key found in the document will be ignored. =item * first_value - value to assign to C; will encode as Null if omitted =item * error_callback – overrides codec default =item * invalid_chars – overrides codec default =item * max_length – overrides codec default =item * op_char – overrides codec default =item * prefer_numeric – overrides codec default =back =head2 decode_one $doc = $codec->decode_one( $byte_string ); $doc = $codec->decode_one( $byte_string, \%options ); Takes a byte string with a BSON-encoded document and returns a hash reference representing the decoded document. An optional hash reference of options may be provided. Valid options include: =over 4 =item * dt_type – overrides codec default =item * error_callback – overrides codec default =item * max_length – overrides codec default =item * ordered - overrides codec default =item * wrap_dbrefs - overrides codec default =item * wrap_numbers - overrides codec default =item * wrap_strings - overrides codec default =back =head2 clone $copy = $codec->clone( ordered => 1 ); Constructs a copy of the original codec, but allows changing attributes in the copy. =head2 create_oid $oid = BSON->create_oid; This class method returns a new L. This abstracts OID generation away from any specific Object ID class and makes it an interface on a BSON codec. Alternative BSON codecs should define a similar class method that returns an Object ID of whatever type is appropriate. =head2 inflate_extjson (DEPRECATED) This legacy method does not follow the L specification. Use L instead. =head2 perl_to_extjson use JSON::MaybeXS; my $ext = BSON->perl_to_extjson($data, \%options); my $json = encode_json($ext); Takes a perl data structure (i.e. hashref) and turns it into an L structure. Note that the structure will still have to be serialized. Possible options are: =over 4 =item * C A boolean indicating if "relaxed extended JSON" should be generated. If not set, the default value is taken from the C environment variable. =back =head2 extjson_to_perl use JSON::MaybeXS; my $ext = decode_json($json); my $data = $bson->extjson_to_perl($ext); Takes an L data structure and inflates it into a Perl data structure. Note that you have to decode the JSON string manually beforehand. Canonically specified numerical values like C<{"$numberInt":"23"}> will be inflated into their respective C wrapper types. Plain numeric values will be left as-is. =head1 FUNCTIONS =head2 encode my $bson = encode({ bar => 'foo' }, \%options); This is the legacy, functional interface and is only exported on demand. It takes a hashref and returns a BSON string. It uses an internal codec singleton with default attributes. =head2 decode my $hash = decode( $bson, \%options ); This is the legacy, functional interface and is only exported on demand. It takes a BSON string and returns a hashref. It uses an internal codec singleton with default attributes. =for Pod::Coverage BUILD =head1 PERL-BSON TYPE MAPPING BSON has numerous data types and Perl does not. When B, each BSON type should result in a single, predictable Perl type. Where no native Perl type is appropriate, BSON decodes to an object of a particular class (a "type wrapper"). When B, for historical reasons, there may be many Perl representations that should encode to a particular BSON type. For example, all the popular "boolean" type modules on CPAN should encode to the BSON boolean type. Likewise, as this module is intended to supersede the type wrappers that have shipped with the L module, those type wrapper are supported by this codec. The table below describes the BSON/Perl mapping for both encoding and decoding. On the left are all the Perl types or classes this BSON codec knows how to serialize to BSON. The middle column is the BSON type for each class. The right-most column is the Perl type or class that the BSON type deserializes to. Footnotes indicate variations or special behaviors. Perl type/class -> BSON type -> Perl type/class ------------------------------------------------------------------- float[1] 0x01 DOUBLE float[2] BSON::Double ------------------------------------------------------------------- string[3] 0x02 UTF8 string[2] BSON::String ------------------------------------------------------------------- hashref 0x03 DOCUMENT hashref[4][5] BSON::Doc BSON::Raw MongoDB::BSON::Raw[d] Tie::IxHash ------------------------------------------------------------------- arrayref 0x04 ARRAY arrayref ------------------------------------------------------------------- BSON::Bytes 0x05 BINARY BSON::Bytes scalarref BSON::Binary[d] MongoDB::BSON::Binary[d] ------------------------------------------------------------------- n/a 0x06 UNDEFINED[d] undef ------------------------------------------------------------------- BSON::OID 0x07 OID BSON::OID BSON::ObjectId[d] MongoDB::OID[d] ------------------------------------------------------------------- boolean 0x08 BOOL boolean BSON::Bool[d] JSON::XS::Boolean JSON::PP::Boolean JSON::Tiny::_Bool Mojo::JSON::_Bool Cpanel::JSON::XS::Boolean Types::Serialiser::Boolean ------------------------------------------------------------------- BSON::Time 0x09 DATE_TIME BSON::Time DateTime DateTime::Tiny Time::Moment Mango::BSON::Time ------------------------------------------------------------------- undef 0x0a NULL undef ------------------------------------------------------------------- BSON::Regex 0x0b REGEX BSON::Regex qr// reference MongoDB::BSON::Regexp[d] ------------------------------------------------------------------- n/a 0x0c DBPOINTER[d] BSON::DBRef ------------------------------------------------------------------- BSON::Code[6] 0x0d CODE BSON::Code MongoDB::Code[6] ------------------------------------------------------------------- n/a 0x0e SYMBOL[d] string ------------------------------------------------------------------- BSON::Code[6] 0x0f CODEWSCOPE BSON::Code MongoDB::Code[6] ------------------------------------------------------------------- integer[7][8] 0x10 INT32 integer[2] BSON::Int32 ------------------------------------------------------------------- BSON::Timestamp 0x11 TIMESTAMP BSON::Timestamp MongoDB::Timestamp[d] ------------------------------------------------------------------- integer[7] 0x12 INT64 integer[2][9] BSON::Int64 Math::BigInt Math::Int64 ------------------------------------------------------------------- BSON::MaxKey 0x7F MAXKEY BSON::MaxKey MongoDB::MaxKey[d] ------------------------------------------------------------------- BSON::MinKey 0xFF MINKEY BSON::MinKey MongoDB::MinKey[d] [d] Deprecated or soon to be deprecated. [1] Scalar with "NV" internal representation or a string that looks like a float if the 'prefer_numeric' option is true. [2] If the 'wrap_numbers' option is true, numeric types will be wrapped as BSON::Double, BSON::Int32 or BSON::Int64 as appropriate to ensure round-tripping. If the 'wrap_strings' option is true, strings will be wrapped as BSON::String, likewise. [3] Scalar without "NV" or "IV" representation and not identified as a number by notes [1] or [7]. [4] If 'ordered' option is set, will return a tied hash that preserves order (deprecated 'ixhash' option still works). [5] If the document appears to contain a DBRef and a 'dbref_callback' exists, that callback is executed with the deserialized document. [6] Code is serialized as CODE or CODEWSCOPE depending on whether a scope hashref exists in BSON::Code/MongoDB::Code. [7] Scalar with "IV" internal representation or a string that looks like an integer if the 'prefer_numeric' option is true. [8] Only if the integer fits in 32 bits. [9] On 32-bit platforms, 64-bit integers are deserialized to Math::BigInt objects (even if subsequently wrapped into BSON::Int64 if 'wrap_scalars' is true). =head1 THREADS Threads are never recommended in Perl, but this module is thread safe. =head1 ENVIRONMENT =over 4 =item * PERL_BSON_BACKEND – if set at compile time, this will be treated as a module name. The module will be loaded and used as the BSON backend implementation. It must implement the same API as C. =item * BSON_EXTJSON - if set, serializing BSON type wrappers via C will produce Extended JSON v2 output. =item * BSON_EXTJSON_RELAXED - if producing Extended JSON output, if this is true, values will use the "Relaxed" form of Extended JSON, which sacrifices type round-tripping for improved human readability. =back =head1 SEMANTIC VERSIONING SCHEME Starting with BSON C, this module is using a "tick-tock" three-part version-tuple numbering scheme: C =over 4 =item * In stable releases, C will be incremented for incompatible API changes. =item * Even-value increments of C indicate stable releases with new functionality. C will be incremented for bug fixes. =item * Odd-value increments of C indicate unstable ("development") releases that should not be used in production. C increments have no semantic meaning; they indicate only successive development releases. Development releases may have API-breaking changes, usually indicated by C equal to "999". =back =head1 HISTORY AND ROADMAP This module was originally written by Stefan G. In 2014, he graciously transferred ongoing maintenance to MongoDB, Inc. The C helper functions in L were inspired by similar work in L by Sebastian Riedel. =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L git clone https://github.com/mongodb/mongo-perl-bson.git =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 CONTRIBUTORS =for stopwords Eric Daniels Finn Olivier Duclos Pat Gunn Petr Písař Robert Sedlacek Thomas Bloor Tobias Leich Wallace Reis Yury Zavarin Oleg Kostyuk =over 4 =item * Eric Daniels =item * Finn =item * Olivier Duclos =item * Pat Gunn =item * Petr Písař =item * Robert Sedlacek =item * Thomas Bloor =item * Tobias Leich =item * Wallace Reis =item * Yury Zavarin =item * Oleg Kostyuk =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Binary.pm000644 000765 000024 00000003767 13524525151 016066 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Binary; # ABSTRACT: Legacy BSON type wrapper for binary data (DEPRECATED) use version; our $VERSION = 'v1.12.1'; our $TYPE_SIMPLE = 0x00; our $TYPE_BYTES = 0x02; our $TYPE_UUID = 0x03; our $TYPE_MD5 = 0x05; our $TYPE_USER_DEFINED = 0x80; sub new { my ( $class, $data, $type ) = @_; $type ||= $TYPE_SIMPLE; my $self = bless { type => $type }, $class; $self->data($data); return $self; } sub data { my ( $self, $data ) = @_; if ( defined $data ) { $data = [ unpack( 'C*', $data ) ] unless ref $data eq 'ARRAY'; $self->{data} = $data; } return $self->{data}; } sub type { return $_[0]->{type}; } # alias for compatibility with BSON::Bytes sub subtype { return $_[0]->{type}; } sub to_s { my $self = shift; my @data = @{ $self->data }; return pack( 'ltype, @data ); } sub TO_JSON { my %data; tie( %data, 'Tie::IxHash' ); $data{base64} = $_[0]->to_s; $data{subType} = $_[0]->{type}; return { '$binary' => \%data }; } use overload '""' => \&to_s; 1; =pod =encoding UTF-8 =head1 NAME BSON::Binary - Legacy BSON type wrapper for binary data (DEPRECATED) =head1 VERSION version v1.12.1 =head1 DESCRIPTION This module has been deprecated as it was horribly inefficient (unpacking binary data to individual single-byte elements of an array!) and had a weird API that was not compatible with the existing MongoDB Binary wrapper implementation on CPAN. You are strongly encouraged to use L instead. =for Pod::Coverage new data type subtype to_s TO_JSON =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/OID.pm000644 000765 000024 00000025216 13524525151 015246 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::OID; # ABSTRACT: BSON type wrapper for Object IDs use version; our $VERSION = 'v1.12.1'; use Carp; use Config; use Scalar::Util 'looks_like_number'; use Sys::Hostname; use threads::shared; # NOP if threads.pm not loaded use Crypt::URandom (); use constant { HAS_INT64 => $Config{use64bitint}, INT64_MAX => 9223372036854775807, INT32_MAX => 2147483647, ZERO_FILL => ("\0" x 8), }; use Moo; #pod =attr oid #pod #pod A 12-byte (packed) Object ID (OID) string. If not provided, a new OID #pod will be generated. #pod #pod =cut has 'oid' => ( is => 'ro' ); use namespace::clean -except => 'meta'; # OID generation { my $_MAX_INC_VALUE = 0xFFFFFF; my $_MAX_INC_VALUE_PLUS_ONE = 0x01000000; my $_RANDOM_SIZE = 5; my $_inc : shared; { lock($_inc); $_inc = int( rand($_MAX_INC_VALUE) ); } # for testing purposes sub __reset_counter { lock($_inc); $_inc = $_MAX_INC_VALUE - 1; } my $_pid = $$; my $_random = Crypt::URandom::urandom($_RANDOM_SIZE); sub CLONE { $_random = Crypt::URandom::urandom($_RANDOM_SIZE) } #<<< sub _packed_oid { my $time = defined $_[0] ? $_[0] : time; $_random = Crypt::URandom::urandom($_RANDOM_SIZE) if $$ != $_pid; return pack( 'Na5a3', $time, $_random, substr( pack( 'N', do { lock($_inc); $_inc++; $_inc %= $_MAX_INC_VALUE_PLUS_ONE } ), 1, 3) ); } sub _packed_oid_special { my ($time, $fill) = @_; return pack('Na8', $time, $fill); } #>>> } sub BUILD { my ($self) = @_; $self->{oid} = _packed_oid() unless defined $self->{oid}; croak "Invalid 'oid' field: OIDs must be 12 bytes" unless length( $self->oid ) == 12; return; } #pod =method new #pod #pod my $oid = BSON::OID->new; #pod #pod my $oid = BSON::OID->new( oid => $twelve_bytes ); #pod #pod This is the preferred way to generate an OID. Without arguments, a #pod unique OID will be generated. With a 12-byte string, an object can #pod be created around an existing OID byte-string. #pod #pod =method from_epoch #pod #pod # generate a new OID #pod #pod my $oid = BSON::OID->from_epoch( $epoch, 0); # other bytes zeroed #pod my $oid = BSON::OID->from_epoch( $epoch, $eight_more_bytes ); #pod #pod # reset an existing OID #pod #pod $oid->from_epoch( $new_epoch, 0 ); #pod $oid->from_epoch( $new_epoch, $eight_more_bytes ); #pod #pod B You should not rely on this method for a source of unique IDs. #pod Use this method for query boundaries, only. #pod #pod An OID is a twelve-byte string. Typically, the first four bytes represent #pod integer seconds since the Unix epoch in big-endian format. The remaining #pod bytes ensure uniqueness. #pod #pod With this method, the first argument to this method is an epoch time (in #pod integer seconds). The second argument is the remaining eight-bytes to #pod append to the string. #pod #pod When called as a class method, it returns a new BSON::OID object. When #pod called as an object method, it mutates the existing internal OID value. #pod #pod As a special case, if the second argument is B and zero ("0"), #pod then the remaining bytes will be zeroed. #pod #pod my $oid = BSON::OID->from_epoch(1467545180, 0); #pod #pod This is particularly useful when looking for documents by their insertion #pod date: you can simply look for OIDs which are greater or lower than the one #pod generated with this method. #pod #pod For backwards compatibility with L, if called without a second #pod argument, the method generates the remainder of the fields "like usual". #pod This is equivalent to calling C<< BSON::OID->new >> and replacing the first #pod four bytes with the packed epoch value. #pod #pod # UNSAFE: don't do this unless you have to #pod #pod my $oid = BSON::OID->from_epoch(1467545180); #pod #pod If you insist on creating a unique OID with C, set the #pod remaining eight bytes in a way that guarantees thread-safe uniqueness, such #pod as from a reliable source of randomness (see L). #pod #pod use Crypt::Random 'urandom'; #pod my $oid = BSON::OID->from_epoch(1467545180, urandom(8)); #pod #pod =cut sub from_epoch { my ($self, $epoch, $fill) = @_; croak "BSON::OID::from_epoch expects an epoch in seconds, not '$epoch'" unless looks_like_number( $epoch ); $fill = ZERO_FILL if defined $fill && looks_like_number($fill) && $fill == 0; croak "BSON::OID expects the second argument to be missing, 0 or an 8-byte string" unless @_ == 2 || length($fill) == 8; my $oid = defined $fill ? _packed_oid_special($epoch, $fill) : _packed_oid($epoch); if (ref $self) { $self->{oid} = $oid; } else { $self = $self->new(oid => $oid); } return $self; } #pod =method hex #pod #pod Returns the C attributes as 24-byte hexadecimal value #pod #pod =cut sub hex { my ($self) = @_; return defined $self->{_hex} ? $self->{_hex} : ( $self->{_hex} = unpack( "H*", $self->{oid} ) ); } #pod =method get_time #pod #pod Returns a number corresponding to the portion of the C value that #pod represents seconds since the epoch. #pod #pod =cut sub get_time { return unpack( "N", substr( $_[0]->{oid}, 0, 4 ) ); } #pod =method TO_JSON #pod #pod Returns a string for this OID, with the OID given as 24 hex digits. #pod #pod If the C option is true, it will instead be compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$oid" : "012345678901234567890123"} #pod #pod =cut sub TO_JSON { return $_[0]->hex unless $ENV{BSON_EXTJSON}; return {'$oid' => $_[0]->hex }; } # For backwards compatibility *to_string = \&hex; *value = \&hex; sub _cmp { my ($left, $right, $swap) = @_; ($left, $right) = ($right, $left) if $swap; return "$left" cmp "$right"; } # Legacy MongoDB driver tests check for a PID matching $$, but the new OID # no longer has an embedded PID. To avoid breaking legacy tests, we make # this return the masked PID. sub _get_pid { return $$ & 0xFFFF } # Legacy BSON::XS tests expect to find a _generate_oid, so we provide # one for back-compatibility. sub _generate_oid { _packed_oid() }; use overload ( '""' => \&hex, "<=>" => \&_cmp, "cmp" => \&_cmp, fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::OID - BSON type wrapper for Object IDs =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; my $oid = bson_oid(); my $oid = bson_oid->from_epoch(1467543496, 0); # for queries only my $bytes = $oid->oid; my $hex = $oid->hex; =head1 DESCRIPTION This module provides a wrapper around a BSON L. =head1 ATTRIBUTES =head2 oid A 12-byte (packed) Object ID (OID) string. If not provided, a new OID will be generated. =head1 METHODS =head2 new my $oid = BSON::OID->new; my $oid = BSON::OID->new( oid => $twelve_bytes ); This is the preferred way to generate an OID. Without arguments, a unique OID will be generated. With a 12-byte string, an object can be created around an existing OID byte-string. =head2 from_epoch # generate a new OID my $oid = BSON::OID->from_epoch( $epoch, 0); # other bytes zeroed my $oid = BSON::OID->from_epoch( $epoch, $eight_more_bytes ); # reset an existing OID $oid->from_epoch( $new_epoch, 0 ); $oid->from_epoch( $new_epoch, $eight_more_bytes ); B You should not rely on this method for a source of unique IDs. Use this method for query boundaries, only. An OID is a twelve-byte string. Typically, the first four bytes represent integer seconds since the Unix epoch in big-endian format. The remaining bytes ensure uniqueness. With this method, the first argument to this method is an epoch time (in integer seconds). The second argument is the remaining eight-bytes to append to the string. When called as a class method, it returns a new BSON::OID object. When called as an object method, it mutates the existing internal OID value. As a special case, if the second argument is B and zero ("0"), then the remaining bytes will be zeroed. my $oid = BSON::OID->from_epoch(1467545180, 0); This is particularly useful when looking for documents by their insertion date: you can simply look for OIDs which are greater or lower than the one generated with this method. For backwards compatibility with L, if called without a second argument, the method generates the remainder of the fields "like usual". This is equivalent to calling C<< BSON::OID->new >> and replacing the first four bytes with the packed epoch value. # UNSAFE: don't do this unless you have to my $oid = BSON::OID->from_epoch(1467545180); If you insist on creating a unique OID with C, set the remaining eight bytes in a way that guarantees thread-safe uniqueness, such as from a reliable source of randomness (see L). use Crypt::Random 'urandom'; my $oid = BSON::OID->from_epoch(1467545180, urandom(8)); =head2 hex Returns the C attributes as 24-byte hexadecimal value =head2 get_time Returns a number corresponding to the portion of the C value that represents seconds since the epoch. =head2 TO_JSON Returns a string for this OID, with the OID given as 24 hex digits. If the C option is true, it will instead be compatible with MongoDB's L format, which represents it as a document as follows: {"$oid" : "012345678901234567890123"} =for Pod::Coverage op_eq to_string value generate_oid BUILD =head1 OVERLOAD The string operator is overloaded so any string operations will actually use the 24-character hex value of the OID. Fallback overloading is enabled. Both numeric comparison (C<< <=> >>) and string comparison (C) are overloaded to do string comparison of the 24-character hex value of the OID. If used with a non-BSON::OID object, be sure to provide a 24-character hex string or the results are undefined. =head1 THREADS This module is thread safe. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Time.pm000644 000765 000024 00000022607 13524525151 015532 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Time; # ABSTRACT: BSON type wrapper for date and time use version; our $VERSION = 'v1.12.1'; use Carp qw/croak/; use Config; use Time::HiRes qw/time/; use Scalar::Util qw/looks_like_number/; use if !$Config{use64bitint}, 'Math::BigInt'; use if !$Config{use64bitint}, 'Math::BigFloat'; use Moo; #pod =attr value #pod #pod A integer representing milliseconds since the Unix epoch. The default #pod is 0. #pod #pod =cut has 'value' => ( is => 'ro' ); use namespace::clean -except => 'meta'; sub BUILDARGS { my $class = shift; my $n = scalar(@_); my %args; if ( $n == 0 ) { if ( $Config{use64bitint} ) { $args{value} = time() * 1000; } else { $args{value} = Math::BigFloat->new(time()); $args{value}->bmul(1000); $args{value} = $args{value}->as_number('zero'); } } elsif ( $n == 1 ) { croak "argument to BSON::Time::new must be epoch seconds, not '$_[0]'" unless looks_like_number( $_[0] ); if ( !$Config{use64bitint} && ref($args{value}) ne 'Math::BigInt' ) { $args{value} = Math::BigFloat->new(shift); $args{value}->bmul(1000); $args{value} = $args{value}->as_number('zero'); } else { $args{value} = 1000 * shift; } } elsif ( $n % 2 == 0 ) { %args = @_; if ( defined $args{value} ) { croak "argument to BSON::Time::new must be epoch seconds, not '$args{value}'" unless looks_like_number( $args{value} ) || overload::Overloaded($args{value}); if ( !$Config{use64bitint} && ref($args{value}) ne 'Math::BigInt' ) { $args{value} = Math::BigInt->new($args{value}); } } else { if ( !$Config{use64bitint} && ref($args{value}) ne 'Math::BigInt' ) { $args{value} = Math::BigFloat->new(shift); $args{value}->bmul(1000); $args{value} = $args{value}->as_number('zero'); } else { $args{value} = 1000 * shift; } } } else { croak("Invalid number of arguments ($n) to BSON::Time::new"); } # normalize all to integer ms $args{value} = int( $args{value} ); return \%args; } #pod =method epoch #pod #pod Returns the number of seconds since the epoch (i.e. a floating-point value). #pod #pod =cut sub epoch { my $self = shift; if ( $Config{use64bitint} ) { return $self->value / 1000; } else { require Math::BigFloat; my $upgrade = Math::BigFloat->new($self->value->bstr); return 0 + $upgrade->bdiv(1000)->bstr; } } #pod =method as_iso8601 #pod #pod Returns the C as an ISO-8601 formatted string of the form #pod C. The fractional seconds will be omitted if #pod they are zero. #pod #pod =cut sub as_iso8601 { my $self = shift; my ($s, $m, $h, $D, $M, $Y) = gmtime($self->epoch); $M++; $Y+=1900; my $f = $self->{value} % 1000; return $f ? sprintf( "%4d-%02d-%02dT%02d:%02d:%02d.%03dZ", $Y, $M, $D, $h, $m, $s, $f ) : sprintf( "%4d-%02d-%02dT%02d:%02d:%02dZ", $Y, $M, $D, $h, $m, $s ); } #pod =method as_datetime #pod #pod Loads L and returns the C as a L object. #pod #pod =cut sub as_datetime { require DateTime; return DateTime->from_epoch( epoch => $_[0]->{value} / 1000 ); } #pod =method as_datetime_tiny #pod #pod Loads L and returns the C as a L #pod object. #pod #pod =cut sub as_datetime_tiny { my ($s, $m, $h, $D, $M, $Y) = gmtime($_[0]->epoch); $M++; $Y+=1900; require DateTime::Tiny; return DateTime::Tiny->new( year => $Y, month => $M, day => $D, hour => $h, minute => $m, second => $s ); } #pod =method as_mango_time #pod #pod Loads L and returns the C as a L #pod object. #pod #pod =cut sub as_mango_time { require Mango::BSON::Time; return Mango::BSON::Time->new( $_[0]->{value} ); } #pod =method as_time_moment #pod #pod Loads L and returns the C as a L object. #pod #pod =cut sub as_time_moment { require Time::Moment; return Time::Moment->from_epoch( $_[0]->{value} / 1000 ); } sub _num_cmp { my ( $self, $other ) = @_; if ( ref($other) eq ref($self) ) { return $self->{value} <=> $other->{value}; } return 0+ $self <=> 0+ $other; } sub _str_cmp { my ( $self, $other ) = @_; if ( ref($other) eq ref($self) ) { return $self->{value} cmp $other->{value}; } return "$self" cmp "$other"; } sub op_eq { my ( $self, $other ) = @_; return( ($self <=> $other) == 0 ); } use overload ( q{""} => \&epoch, q{0+} => \&epoch, q{<=>} => \&_num_cmp, q{cmp} => \&_str_cmp, fallback => 1, ); #pod =method TO_JSON #pod #pod Returns a string formatted by L. #pod #pod If the C option is true, it will instead be compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod #pod If the C environment variable is true and the #pod C environment variable is false, returns a hashref #pod compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$date" : { "$numberLong": "22337203685477580" } } #pod #pod If the C and C environment variables are #pod both true, then it will return a hashref with an ISO-8601 string for dates #pod after the Unix epoch and before the year 10,000 and a C<$numberLong> style #pod value otherwise. #pod #pod {"$date" : "2012-12-24T12:15:30.500Z"} #pod {"$date" : { "$numberLong": "-10000000" } } #pod #pod =cut sub TO_JSON { return $_[0]->as_iso8601 if ! $ENV{BSON_EXTJSON}; return { '$date' => { '$numberLong' => "$_[0]->{value}"} } if ! $ENV{BSON_EXTJSON_RELAXED}; # Relaxed form is human readable for positive epoch to year 10k my $year = (gmtime($_[0]->epoch))[5]; $year += 1900; if ($year >= 1970 and $year <= 9999) { return { '$date' => $_[0]->as_iso8601 }; } else { return { '$date' => { '$numberLong' => "$_[0]->{value}" } }; } } 1; =pod =encoding UTF-8 =head1 NAME BSON::Time - BSON type wrapper for date and time =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_time(); # now bson_time( $secs ); # floating point seconds since epoch =head1 DESCRIPTION This module provides a BSON type wrapper for a 64-bit date-time value in the form of milliseconds since the Unix epoch (UTC only). On a Perl without 64-bit integer support, the value must be a L object. =head1 ATTRIBUTES =head2 value A integer representing milliseconds since the Unix epoch. The default is 0. =head1 METHODS =head2 epoch Returns the number of seconds since the epoch (i.e. a floating-point value). =head2 as_iso8601 Returns the C as an ISO-8601 formatted string of the form C. The fractional seconds will be omitted if they are zero. =head2 as_datetime Loads L and returns the C as a L object. =head2 as_datetime_tiny Loads L and returns the C as a L object. =head2 as_mango_time Loads L and returns the C as a L object. =head2 as_time_moment Loads L and returns the C as a L object. =head2 TO_JSON Returns a string formatted by L. If the C option is true, it will instead be compatible with MongoDB's L format, which represents it as a document as follows: If the C environment variable is true and the C environment variable is false, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$date" : { "$numberLong": "22337203685477580" } } If the C and C environment variables are both true, then it will return a hashref with an ISO-8601 string for dates after the Unix epoch and before the year 10,000 and a C<$numberLong> style value otherwise. {"$date" : "2012-12-24T12:15:30.500Z"} {"$date" : { "$numberLong": "-10000000" } } =for Pod::Coverage op_eq BUILDARGS =head1 OVERLOADING Both numification (C<0+>) and stringification (C<"">) are overloaded to return the result of L. Numeric comparison and string comparison are overloaded based on those and fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Raw.pm000644 000765 000024 00000003477 13524525151 015371 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Raw; # ABSTRACT: BSON type wrapper for pre-encoded BSON documents use version; our $VERSION = 'v1.12.1'; use Moo; #pod =attr bson #pod #pod A string containing a BSON-encoded document. Default is C. #pod #pod =attr metadata #pod #pod A hash reference containing arbitrary metadata about the BSON document. #pod Default is C. #pod #pod =cut has [qw/bson metadata/] => ( is => 'ro' ); use namespace::clean -except => 'meta'; # Returns the first key of an encoded hash passed via BSON::Raw->new(bson=>$bson). # If the BSON document has no key, it will return C. sub _get_first_key { my ($self) = @_; return undef if length( $self->bson ) <= 5; ## no critic my ( undef, undef, $key ) = unpack( "lCZ*", $self->bson ); return $key; } 1; =pod =encoding UTF-8 =head1 NAME BSON::Raw - BSON type wrapper for pre-encoded BSON documents =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; my $ordered = bson_raw( $bson_bytes ); =head1 DESCRIPTION This module provides a BSON document wrapper for already-encoded BSON bytes. Generally, end-users should have no need for this; it is provided for optimization purposes for L or other client libraries. =head1 ATTRIBUTES =head2 bson A string containing a BSON-encoded document. Default is C. =head2 metadata A hash reference containing arbitrary metadata about the BSON document. Default is C. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Decimal128.pm000644 000765 000024 00000023050 13524525151 016416 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Decimal128; # ABSTRACT: BSON type wrapper for Decimal128 use version; our $VERSION = 'v1.12.1'; use Carp; use Math::BigInt; use Moo; #pod =attr value #pod #pod The Decimal128 value represented as string. If not provided, it will be #pod generated from the C attribute on demand. #pod #pod =cut has 'value' => ( is => 'lazy', ); #pod =attr bytes #pod #pod The Decimal128 value represented in L (BID) format. #pod If not provided, it will be generated from the C attribute on #pod demand. #pod #pod =cut has 'bytes' => ( is => 'lazy', ); use namespace::clean -except => 'meta'; use constant { PLIM => 34, # precision limit, i.e. max coefficient chars EMAX => 6144, # for 9.999999999999999999999999999999999E+6144 EMIN => -6143, # for 1.000000000000000000000000000000000E-6143 AEMAX => 6111, # EMAX - (PLIM - 1); largest encodable exponent AEMIN => -6176, # EMIN - (PLIM - 1); smallest encodable exponent BIAS => 6176, # offset for encoding exponents }; my $digits = qr/[0-9]+/; my $decimal_re = qr{ ( [-+]? ) # maybe a sign ( (?:$digits \. $digits? ) | (?: \.? $digits ) ) # decimal-part ( (?:e [-+]? $digits)? ) # maybe exponent }ix; sub _build_value { return _bid_to_string( $_[0]->{bytes} ); } sub _build_bytes { return _string_to_bid( $_[0]->{value} ); } sub BUILD { my $self = shift; croak "One and only one of 'value' or 'bytes' must be provided" unless 1 == grep { exists $self->{$_} } qw/value bytes/; # must check for errors and canonicalize value if provided if (exists $self->{value}) { $self->{value} = _bid_to_string( $self->bytes ); } return; } sub _bid_to_string { my $bid = shift; my $binary = unpack( "B*", scalar reverse($bid) ); my ( $coef, $e ); # sign bit my $pos = !substr( $binary, 0, 1 ); # detect special values from first 5 bits after sign bit my $special = substr( $binary, 1, 5 ); if ( $special eq "11111" ) { return "NaN"; } if ( $special eq "11110" ) { return $pos ? "Infinity" : "-Infinity"; } if ( substr( $binary, 1, 2 ) eq '11' ) { # Bits: 1*sign 2*ignored 14*exponent 111*significand. # Implicit 0b100 prefix in significand. $coef = "" . Math::BigInt->new( "0b100" . substr( $binary, 17 ) ); $e = unpack( "n", pack( "B*", "00" . substr( $binary, 3, 14 ) ) ) - BIAS; } else { # Bits: 1*sign 14*exponent 113*significand $coef = "" . Math::BigInt->new( "0b" . substr( $binary, 15 ) ); $e = unpack( "n", pack( "B*", "00" . substr( $binary, 1, 14 ) ) ) - BIAS; } # Out of range is treated as zero if ( length($coef) > PLIM ) { $coef = "0"; } # Shortcut on zero if ( $coef == 0 && $e == 0 ) { return $pos ? "0" : "-0"; } # convert to scientific form ( e.g. 123E+4 -> 1.23E6 ) my $adj_exp = $e + length($coef) - 1; # warn "# XXX COEF: $coef; EXP: $e; AEXP: $adj_exp\n"; # exponential notation if ( $e > 0 || $adj_exp < -6 ) { # insert decimal if more than one digit if ( length($coef) > 1 ) { substr( $coef, 1, 0, "." ); } return ( ( $pos ? "" : "-" ) . $coef . "E" . ( $adj_exp >= 0 ? "+" : "" ) . $adj_exp ); } # not exponential notation (integers or small negative exponents) else { # e == 0 means integer return $pos ? $coef : "-$coef" if $e == 0; # pad with leading zeroes if coefficient is too short if ( length($coef) < abs($e) ) { substr( $coef, 0, 0, "0" x ( abs($e) - length($coef) ) ); } # maybe coefficient is exact length? return $pos ? "0.$coef" : "-0.$coef" if length($coef) == abs($e); # otherwise length(coef) > abs($e), so insert dot after first digit substr( $coef, $e, 0, "." ); return $pos ? $coef : "-$coef"; } } my ( $bidNaN, $bidPosInf, $bidNegInf ) = map { scalar reverse pack( "B*", $_ . ( "0" x 118 ) ) } qw/ 011111 011110 111110 /; sub _croak { croak("Couldn't parse '$_[0]' as valid Decimal128") } sub _erange { croak("Value '$_[0]' is out of range for Decimal128") } sub _erounding { croak("Value '$_[0]' can't be rounded to Decimal128") } sub _string_to_bid { my $s = shift; # Check special values return $bidNaN if $s =~ /\A -? NaN \z/ix; return $bidPosInf if $s =~ /\A \+?Inf(?:inity)? \z/ix; return $bidNegInf if $s =~ /\A -Inf(?:inity)? \z/ix; # Parse string my ( $sign, $mant, $exp ) = $s =~ /\A $decimal_re \z/x; $sign = "" unless defined $sign; $exp = 0 unless defined $exp && length($exp); $exp =~ s{^e}{}i; # Throw error if unparseable _croak($s) unless length $exp && defined $mant; # Extract sign bit my $neg = defined($sign) && $sign eq '-' ? "1" : "0"; # Remove leading zeroes unless "0." $mant =~ s{^(?:0(?!\.))+}{}; # Locate decimal, remove it and adjust the exponent my $dot = index( $mant, "." ); $mant =~ s/\.//; $exp += $dot - length($mant) if $dot >= 0; # Remove leading zeros from mantissa (after decimal point removed) $mant =~ s/^0+//; $mant = "0" unless length $mant; # Apply exact rounding if necessary if ( length($mant) > PLIM ) { my $plim = PLIM; $mant =~ s{(.{$plim})(0+)$}{$1}; $exp += length($2) if defined $2 && length $2; } elsif ( $exp < AEMIN ) { $mant =~ s{(.*[1-9])(0+)$}{$1}; $exp += length($2) if defined $2 && length $2; } # Apply clamping if possible if ( $mant == 0 ) { if ( $exp > AEMAX ) { $mant = "0"; $exp = AEMAX; } elsif ( $exp < AEMIN ) { $mant = "0"; $exp = AEMIN; } } elsif ( $exp > AEMAX && $exp - AEMAX <= PLIM - length($mant) ) { $mant .= "0" x ( $exp - AEMAX ); $exp = AEMAX; } # Throw errors if result won't fit in Decimal128 _erounding($s) if length($mant) > PLIM; _erange($s) if $exp > AEMAX || $exp < AEMIN; # Get binary representation of coefficient my $coef = Math::BigInt->new($mant)->as_bin; $coef =~ s/^0b//; # Get 14-bit binary representation of biased exponent my $biased_exp = unpack( "B*", pack( "n", $exp + BIAS ) ); substr( $biased_exp, 0, 2, "" ); # Choose representation based on coefficient length my $coef_len = length($coef); if ( $coef_len <= 113 ) { substr( $coef, 0, 0, "0" x ( 113 - $coef_len ) ); return scalar reverse pack( "B*", $neg . $biased_exp . $coef ); } elsif ( $coef_len <= 114 ) { substr( $coef, 0, 3, "" ); return scalar reverse pack( "B*", $neg . "11" . $biased_exp . $coef ); } else { _erange($s); } } #pod =method TO_JSON #pod #pod Returns the value as a string. #pod #pod If the C option is true, it will instead #pod be compatible with MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$numberDecimal" : "2.23372036854775807E+57"} #pod #pod =cut sub TO_JSON { return "" . $_[0]->value unless $ENV{BSON_EXTJSON}; return { '$numberDecimal' => "" . ($_[0]->value) }; } use overload ( q{""} => sub { $_[0]->value }, fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::Decimal128 - BSON type wrapper for Decimal128 =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; # string representation $decimal = bson_decimal128( "1.23456789E+1000" ); # binary representation in BID format $decimal = BSON::Decimal128->new( bytes => $bid ) =head1 DESCRIPTION This module provides a BSON type wrapper for Decimal128 values. It may be initialized with either a numeric value in string form, or with a binary Decimal128 representation (16 bytes), but not both. Initialization from a string will throw an error if the string cannot be parsed as a Decimal128 or if the resulting number would not fit into 128 bits. If required, clamping or exact rounding will be applied to try to fit the value into 128 bits. =head1 ATTRIBUTES =head2 value The Decimal128 value represented as string. If not provided, it will be generated from the C attribute on demand. =head2 bytes The Decimal128 value represented in L (BID) format. If not provided, it will be generated from the C attribute on demand. =head1 METHODS =head2 TO_JSON Returns the value as a string. If the C option is true, it will instead be compatible with MongoDB's L format, which represents it as a document as follows: {"$numberDecimal" : "2.23372036854775807E+57"} =for Pod::Coverage BUILD =head1 OVERLOADING The stringification operator (C<"">) is overloaded to return a (normalized) string representation. Fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/MaxKey.pm000644 000765 000024 00000003617 13524525151 016032 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::MaxKey; # ABSTRACT: BSON type wrapper for MaxKey use version; our $VERSION = 'v1.12.1'; use Carp; my $singleton = bless \(my $x), __PACKAGE__; sub new { return $singleton; } #pod =method TO_JSON #pod #pod If the C option is true, returns a hashref compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$maxKey" : 1} #pod #pod If the C option is false, an error is thrown, as this value #pod can't otherwise be represented in JSON. #pod #pod =cut sub TO_JSON { if ( $ENV{BSON_EXTJSON} ) { return { '$maxKey' => 1 }; } croak( "The value '$_[0]' is illegal in JSON" ); } 1; =pod =encoding UTF-8 =head1 NAME BSON::MaxKey - BSON type wrapper for MaxKey =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_maxkey(); =head1 DESCRIPTION This module provides a BSON type wrapper for the special BSON "MaxKey" type. The object returned is a singleton. =head1 METHODS =head2 TO_JSON If the C option is true, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$maxKey" : 1} If the C option is false, an error is thrown, as this value can't otherwise be represented in JSON. =for Pod::Coverage new =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/ObjectId.pm000644 000765 000024 00000003252 13524525151 016312 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::ObjectId; # ABSTRACT: Legacy BSON type wrapper for Object IDs (DEPRECATED) use version; our $VERSION = 'v1.12.1'; use Carp; use BSON::OID; our @ISA = qw/BSON::OID/; sub new { my ( $class, $value ) = @_; my $self = bless {}, $class; if ( $value ) { $self->value( $value ); } else { $self->{oid} = BSON::OID::_packed_oid(); } return $self; } sub value { my ( $self, $new_value ) = @_; if ( defined $new_value ) { if ( length($new_value) == 12 ) { $self->{oid} = $new_value; } elsif ( length($new_value) == 24 && $self->is_legal($new_value) ) { $self->{oid} = pack("H*", $new_value); } else { croak("BSON::ObjectId must be a 12 byte or 24 char hex value"); } } return $self->{oid}; } sub is_legal { $_[1] =~ /^[0-9a-f]{24}$/i; } sub to_s { $_[0]->to_string } 1; =pod =encoding UTF-8 =head1 NAME BSON::ObjectId - Legacy BSON type wrapper for Object IDs (DEPRECATED) =head1 VERSION version v1.12.1 =head1 DESCRIPTION This module has been deprecated as it was not compatible with the official MongoDB BSON implementation on CPAN. You are strongly encouraged to use L instead. =for Pod::Coverage to_s is_legal new value =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/PP.pm000644 000765 000024 00000073050 13524525151 015151 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; no warnings 'recursion'; package BSON::PP; # ABSTRACT: Pure Perl BSON implementation use version; our $VERSION = 'v1.12.1'; use B; use Carp; use Config; use Scalar::Util qw/blessed looks_like_number refaddr reftype/; use List::Util qw/first/; use Tie::IxHash; use BSON::Types (); use boolean; use mro; use re 'regexp_pattern'; use constant { HAS_INT64 => $Config{use64bitint}, }; use if !HAS_INT64, "Math::BigInt"; # Max integer sizes my $max_int32 = 2147483647; my $min_int32 = -2147483648; my $max_int64 = HAS_INT64 ? 9223372036854775807 : Math::BigInt->new("9223372036854775807"); my $min_int64 = HAS_INT64 ? -9223372036854775808 : Math::BigInt->new("-9223372036854775808"); #<<< my $int_re = qr/^(?:(?:[+-]?)(?:[0123456789]+))$/; my $doub_re = qr/^(?:(?i)(?:NaN|-?Inf(?:inity)?)|(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))$/; #>>> my $bools_re = qr/::(?:Boolean|_Bool|Bool)\z/; use constant { BSON_TYPE_NAME => "CZ*", BSON_DOUBLE => "d<", BSON_STRING => "V/Z*", BSON_BOOLEAN => "C", BSON_REGEX => "Z*Z*", BSON_JSCODE => "", BSON_INT32 => "l<", BSON_UINT32 => "L<", BSON_INT64 => "q<", BSON_8BYTES => "a8", BSON_16BYTES => "a16", BSON_TIMESTAMP => "L "l<", BSON_REMAINING => 'a*', BSON_SKIP_4_BYTES => 'x4', BSON_OBJECTID => 'a12', BSON_BINARY_TYPE => 'C', BSON_CSTRING => 'Z*', BSON_MAX_DEPTH => 100, }; sub _printable { my $value = shift; $value =~ s/([^[:print:]])/sprintf("\\x%02x",ord($1))/ge; return $value; } sub _split_re { my $value = shift; if ( $] ge 5.010 ) { return re::regexp_pattern($value); } else { $value =~ s/^\(\?\^?//; $value =~ s/\)$//; my ( $opt, $re ) = split( /:/, $value, 2 ); $opt =~ s/\-\w+$//; return ( $re, $opt ); } } sub _ixhash_iterator { my $ixhash = shift; my $started = 0; return sub { my $k = $started ? $ixhash->NEXTKEY : do { $started++; $ixhash->FIRSTKEY }; return unless defined $k; return ($k, $ixhash->FETCH($k)); } } # relying on Perl's each() is prone to action-at-a-distance effects we # want to avoid, so we construct our own iterator for hashes sub _hashlike_iterator { my $hashlike = shift; my @keys = keys %$hashlike; @keys = sort @keys if $ENV{BSON_TEST_SORT_HASH}; return sub { my $k = shift @keys; return unless defined $k; return ($k, $hashlike->{$k}); } } # XXX could be optimized down to only one substr to trim/pad sub _bigint_to_int64 { my $bigint = shift; my $neg = $bigint < 0; if ( $neg ) { if ( $bigint < $min_int64 ) { return "\x80\x00\x00\x00\x00\x00\x00\x00"; } $bigint = abs($bigint) - ($max_int64 + 1); } elsif ( $bigint > $max_int64 ) { return "\x7f\xff\xff\xff\xff\xff\xff\xff"; } my $as_hex = $bigint->as_hex; # big-endian hex $as_hex =~ s{-?0x}{}; my $len = length($as_hex); substr( $as_hex, 0, 0, "0" x ( 16 - $len ) ) if $len < 16; # pad to quad length my $pack = pack( "H*", $as_hex ); $pack |= "\x80\x00\x00\x00\x00\x00\x00\x00" if $neg; return scalar reverse $pack; } sub _int64_to_bigint { my $bytes = reverse(shift); return Math::BigInt->new() if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x00"; if ( unpack("c", $bytes) < 0 ) { if ( $bytes eq "\x80\x00\x00\x00\x00\x00\x00\x00" ) { return -1 * Math::BigInt->new( "0x" . unpack("H*",$bytes) ); } else { return -1 * Math::BigInt->new( "0x" . unpack( "H*", ~$bytes ) ) - 1; } } else { return Math::BigInt->new( "0x" . unpack( "H*", $bytes ) ); } } sub _pack_int64 { my $value = shift; my $type = ref($value); # if no type, then on 64-big perl we can pack with 'q'; otherwise # we need to convert scalars to Math::BigInt and pack them that way. if ( ! $type ) { return pack(BSON_INT64,$value ) if HAS_INT64; $value = Math::BigInt->new($value); $type = 'Math::BigInt'; } if ( $type eq 'Math::BigInt' ) { return _bigint_to_int64($value); } elsif ( $type eq 'Math::Int64' ) { return Math::Int64::int64_to_native($value); } else { croak "Don't know how to encode $type '$value' as an Int64."; } } sub _reftype_check { my $doc = shift; my $type = ref($doc); my $reftype = reftype($doc); die "Can't encode non-container of type '$type'" unless $reftype eq 'HASH'; return; } sub _encode_bson { my ($doc, $opt) = @_; my $refaddr = refaddr($doc); die "circular reference detected" if $opt->{_circular}{$refaddr}++; $opt->{_depth} = 0 unless defined $opt->{_depth}; $opt->{_depth}++; if ($opt->{_depth} > BSON_MAX_DEPTH) { croak "Exceeded max object depth of ". BSON_MAX_DEPTH; } my $doc_type = ref($doc); if ( $doc_type eq 'BSON::Raw' || $doc_type eq 'MongoDB::BSON::_EncodedDoc' ) { delete $opt->{_circular}{$refaddr}; $opt->{_depth}--; return $doc->bson; } if ( $doc_type eq 'MongoDB::BSON::Raw' ) { delete $opt->{_circular}{$refaddr}; $opt->{_depth}--; return $$doc; } my $iter = $doc_type eq 'HASH' ? undef : $doc_type eq 'BSON::Doc' ? $doc->_iterator : $doc_type eq 'Tie::IxHash' ? _ixhash_iterator($doc) : $doc_type eq 'BSON::DBRef' ? _ixhash_iterator( $doc->_ordered ) : $doc_type eq 'MongoDB::DBRef' ? _ixhash_iterator( $doc->_ordered ) : do { _reftype_check($doc); undef }; $iter //= _hashlike_iterator($doc); my $op_char = defined($opt->{op_char}) ? $opt->{op_char} : ''; my $invalid = length( $opt->{invalid_chars} ) ? qr/[\Q$opt->{invalid_chars}\E]/ : undef; # Set up first key bookkeeping my $first_key_pending = !! defined($opt->{first_key}); my $first_key; my $bson = ''; my ($key, $value); while ( $first_key_pending or ( $key, $value ) = $iter->() ) { next if defined $first_key && $key eq $first_key; if ( $first_key_pending ) { $first_key = $key = delete $opt->{first_key}; $value = delete $opt->{first_value}; undef $first_key_pending; } last unless defined $key; croak "Key '" . _printable($key) . "' contains null character" unless -1 == index($key, "\0"); substr( $key, 0, 1 ) = '$' if length($op_char) && substr( $key, 0, 1 ) eq $op_char; if ( $invalid && $key =~ $invalid ) { croak( sprintf( "key '%s' has invalid character(s) '%s'", $key, $opt->{invalid_chars} ) ); } my $utf8_key = $key; utf8::encode($utf8_key); my $type = ref $value; # If the type is a subtype of BSON::*, use that instead if ( blessed $value ) { if ($type !~ /\ABSON::\w+\z/) { my $parent = first { /\ABSON::\w+\z/ } reverse @{mro::get_linear_isa($type)}; $type = $parent if defined $parent; } } # Null if ( !defined $value ) { $bson .= pack( BSON_TYPE_NAME, 0x0A, $utf8_key ); } # REFERENCES/OBJECTS elsif ( length $type ) { # Array if ( $type eq 'ARRAY' || $type eq 'BSON::Array' ) { my $i = 0; tie( my %h, 'Tie::IxHash' ); %h = map { $i++ => $_ } @$value; $bson .= pack( BSON_TYPE_NAME, 0x04, $utf8_key ) . _encode_bson( \%h, $opt ); } # special-cased deprecated DBPointer elsif ($type eq 'BSON::DBPointer') { my %data; tie %data, 'Tie::IxHash'; $data{'$ref'} = $value->{'ref'}; $data{'$id'} = $value->{id}; $bson .= pack( BSON_TYPE_NAME, 0x03, $utf8_key ) . _encode_bson(\%data, $opt); } # Document elsif ($type eq 'HASH' || $type eq 'BSON::Doc' || $type eq 'BSON::Raw' || $type eq 'MongoDB::BSON::_EncodedDoc' || $type eq 'Tie::IxHash' || $type eq 'MongoDB::BSON::Raw' || $type eq 'BSON::DBRef' || $type eq 'MongoDB::DBRef') { $bson .= pack( BSON_TYPE_NAME, 0x03, $utf8_key ) . _encode_bson($value, $opt); } # Regex elsif ( $type eq 'Regexp' ) { my ( $re, $flags ) = _split_re($value); $bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $utf8_key, $re, join( "", sort grep /^(i|m|x|l|s|u)$/, split( //, $flags ) )); } elsif ( $type eq 'BSON::Regex' || $type eq 'MongoDB::BSON::Regexp' ) { my ( $re, $flags ) = @{$value}{qw/pattern flags/}; $bson .= pack( BSON_TYPE_NAME.BSON_REGEX, 0x0B, $utf8_key, $re, $flags) ; } # ObjectId elsif ( $type eq 'BSON::OID' || $type eq 'BSON::ObjectId' ) { $bson .= pack( BSON_TYPE_NAME.BSON_OBJECTID, 0x07, $utf8_key, $value->oid ); } elsif ( $type eq 'MongoDB::OID' ) { $bson .= pack( BSON_TYPE_NAME."H*", 0x07, $utf8_key, $value->value ); } # Datetime elsif ( $type eq 'BSON::Time' ) { $bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $value->value ); } elsif ( $type eq 'Time::Moment' ) { $bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( int( $value->epoch * 1000 + $value->millisecond ) ); } elsif ( $type eq 'DateTime' ) { if ( $value->time_zone->name eq 'floating' ) { warn("saving floating timezone as UTC"); } $bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( int( $value->hires_epoch * 1000 ) ); } elsif ( $type eq 'DateTime::Tiny' ) { require Time::Local; my $epoch = Time::Local::timegm( $value->second, $value->minute, $value->hour, $value->day, $value->month - 1, $value->year, ); $bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $epoch * 1000 ); } elsif ( $type eq 'Mango::BSON::Time' ) { $bson .= pack( BSON_TYPE_NAME, 0x09, $utf8_key ) . _pack_int64( $value->{time} ); } # Timestamp elsif ( $type eq 'BSON::Timestamp' ) { $bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $utf8_key, $value->increment, $value->seconds ); } elsif ( $type eq 'MongoDB::Timestamp' ){ $bson .= pack( BSON_TYPE_NAME.BSON_TIMESTAMP, 0x11, $utf8_key, $value->inc, $value->sec ); } # MinKey elsif ( $type eq 'BSON::MinKey' || $type eq 'MongoDB::MinKey' ) { $bson .= pack( BSON_TYPE_NAME, 0xFF, $utf8_key ); } # MaxKey elsif ( $type eq 'BSON::MaxKey' || $type eq 'MongoDB::MaxKey' ) { $bson .= pack( BSON_TYPE_NAME, 0x7F, $utf8_key ); } # Binary (XXX need to add string ref support) elsif ($type eq 'SCALAR' || $type eq 'BSON::Bytes' || $type eq 'BSON::Binary' || $type eq 'MongoDB::BSON::Binary' ) { my $data = $type eq 'SCALAR' ? $$value : $type eq 'BSON::Bytes' ? $value->data : $type eq 'MongoDB::BSON::Binary' ? $value->data : pack( "C*", @{ $value->data } ); my $subtype = $type eq 'SCALAR' ? 0 : $value->subtype; my $len = length($data); if ( $subtype == 2 ) { $bson .= pack( BSON_TYPE_NAME . BSON_INT32 . BSON_BINARY_TYPE . BSON_INT32 . BSON_REMAINING, 0x05, $utf8_key, $len + 4, $subtype, $len, $data ); } else { $bson .= pack( BSON_TYPE_NAME . BSON_INT32 . BSON_BINARY_TYPE . BSON_REMAINING, 0x05, $utf8_key, $len, $subtype, $data ); } } # Code elsif ( $type eq 'BSON::Code' || $type eq 'MongoDB::Code' ) { my $code = $value->code; utf8::encode($code); $code = pack(BSON_STRING,$code); if ( ref( $value->scope ) eq 'HASH' ) { my $scope = _encode_bson( $value->scope, $opt ); $bson .= pack( BSON_TYPE_NAME.BSON_CODE_W_SCOPE, 0x0F, $utf8_key, (4 + length($scope) + length($code)) ) . $code . $scope; } else { $bson .= pack( BSON_TYPE_NAME, 0x0D, $utf8_key) . $code; } } # Boolean elsif ( $type eq 'boolean' || $type =~ $bools_re ) { $bson .= pack( BSON_TYPE_NAME.BSON_BOOLEAN, 0x08, $utf8_key, ( $value ? 1 : 0 ) ); } # String (explicit) elsif ( $type eq 'BSON::String' || $type eq 'BSON::Symbol') { $value = $value->value; utf8::encode($value); $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); } elsif ( $type eq 'MongoDB::BSON::String' ) { $value = $$value; utf8::encode($value); $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); } # Int64 (XXX and eventually BigInt) elsif ( $type eq 'BSON::Int64' || $type eq 'Math::BigInt' || $type eq 'Math::Int64' ) { if ( $value > $max_int64 || $value < $min_int64 ) { croak("BSON can only handle 8-byte integers. Key '$key' is '$value'"); } # unwrap BSON::Int64; it could be Math::BigInt, etc. if ( $type eq 'BSON::Int64' ) { $value = $value->value; } $bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value); } elsif ( $type eq 'BSON::Int32' ) { $bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value->value ); } # Double (explicit) elsif ( $type eq 'BSON::Double' ) { $bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value/1.0 ); } # Decimal128 elsif ( $type eq 'BSON::Decimal128' ) { $bson .= pack( BSON_TYPE_NAME.BSON_16BYTES, 0x13, $utf8_key, $value->bytes ); } # Unsupported type else { croak("For key '$key', can't encode value of type '$type'"); } } # SCALAR else { # If a numeric value exists based on internal flags, use it; # otherwise, if prefer_numeric is true and it looks like a # number, then coerce to a number of the right type; # otherwise, leave it as a string my $flags = B::svref_2object(\$value)->FLAGS; if ( $flags & B::SVf_NOK() ) { $bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value ); } elsif ( $flags & B::SVf_IOK() ) { # Force numeric; fixes dual-vars comparison bug on old Win32s $value = 0+$value; if ( $value > $max_int64 || $value < $min_int64 ) { croak("BSON can only handle 8-byte integers. Key '$key' is '$value'"); } elsif ( $value > $max_int32 || $value < $min_int32 ) { $bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value); } else { $bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value ); } } elsif ( $opt->{prefer_numeric} && looks_like_number($value) ) { # Looks like int: type heuristic based on size if ( $value =~ $int_re ) { if ( $value > $max_int64 || $value < $min_int64 ) { croak("BSON can only handle 8-byte integers. Key '$key' is '$value'"); } elsif ( $value > $max_int32 || $value < $min_int32 ) { $bson .= pack( BSON_TYPE_NAME, 0x12, $utf8_key ) . _pack_int64($value); } else { $bson .= pack( BSON_TYPE_NAME . BSON_INT32, 0x10, $utf8_key, $value ); } } # Looks like double elsif ( $value =~ $doub_re ) { $bson .= pack( BSON_TYPE_NAME.BSON_DOUBLE, 0x01, $utf8_key, $value ); } # looks_like_number true, but doesn't match int/double # regexes, so as a last resort we leave as string else { utf8::encode($value); $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); } } else { # Not coercing or didn't look like a number utf8::encode($value); $bson .= pack( BSON_TYPE_NAME.BSON_STRING, 0x02, $utf8_key, $value ); } } } delete $opt->{_circular}{$refaddr}; $opt->{_depth}--; return pack( BSON_INT32, length($bson) + 5 ) . $bson . "\0"; } my %FIELD_SIZES = ( 0x01 => 8, 0x02 => 5, 0x03 => 5, 0x04 => 5, 0x05 => 5, 0x06 => 0, 0x07 => 12, 0x08 => 1, 0x09 => 8, 0x0A => 0, 0x0B => 2, 0x0C => 17, 0x0D => 5, 0x0E => 5, 0x0F => 11, 0x10 => 4, 0x11 => 8, 0x12 => 8, 0x13 => 16, 0x7F => 0, 0xFF => 0, ); my $ERR_UNSUPPORTED = "unsupported BSON type \\x%X for key '%s'. Are you using the latest version of BSON.pm?"; my $ERR_TRUNCATED = "premature end of BSON field '%s' (type 0x%x)"; my $ERR_LENGTH = "BSON field '%s' (type 0x%x) has invalid length: wanted %d, got %d"; my $ERR_MISSING_NULL = "BSON field '%s' (type 0x%x) missing null terminator"; my $ERR_BAD_UTF8 = "BSON field '%s' (type 0x%x) contains invalid UTF-8"; my $ERR_NEG_LENGTH = "BSON field '%s' (type 0x%x) contains negative length"; my $ERR_BAD_OLDBINARY = "BSON field '%s' (type 0x%x, subtype 0x02) is invalid"; sub __dump_bson { my $bson = unpack("H*", shift); my @pairs = $bson=~ m/(..)/g; return join(" ", @pairs); } sub _decode_bson { my ($bson, $opt) = @_; if ( !defined $bson ) { croak("Decode argument must not be undef"); } $opt->{_depth} = 0 unless defined $opt->{_depth}; $opt->{_depth}++; if ($opt->{_depth} > BSON_MAX_DEPTH) { croak "Exceeded max object depth of ". BSON_MAX_DEPTH; } my $blen= length($bson); my $len = unpack( BSON_INT32, $bson ); if ( length($bson) != $len ) { croak("Incorrect length of the bson string (got $blen, wanted $len)"); } if ( chop($bson) ne "\x00" ) { croak("BSON document not null terminated"); } $bson = substr $bson, 4; my @array = (); my %hash = (); tie( %hash, 'Tie::IxHash' ) if $opt->{ordered}; my ($type, $key, $value); while ($bson) { ( $type, $key, $bson ) = unpack( BSON_TYPE_NAME.BSON_REMAINING, $bson ); utf8::decode($key); # Check type and truncation my $min_size = $FIELD_SIZES{$type}; if ( !defined $min_size ) { croak( sprintf( $ERR_UNSUPPORTED, $type, $key ) ); } if ( length($bson) < $min_size ) { croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); } # Double if ( $type == 0x01 ) { ( $value, $bson ) = unpack( BSON_DOUBLE.BSON_REMAINING, $bson ); $value = BSON::Double->new( value => $value ) if $opt->{wrap_numbers}; } # String and Symbol (deprecated); Symbol will be convert to String elsif ( $type == 0x02 || $type == 0x0E ) { ( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson ); if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) { croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); } ( $value, $bson ) = unpack( "a$len" . BSON_REMAINING, $bson ); chop($value); # remove trailing \x00 if ( !utf8::decode($value) ) { croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); } $value = BSON::String->new( value => $value ) if $opt->{wrap_strings}; } # Document and Array elsif ( $type == 0x03 || $type == 0x04 ) { my $len = unpack( BSON_INT32, $bson ); $value = _decode_bson( substr( $bson, 0, $len ), { %$opt, _decode_array => $type == 0x04} ); if ( $opt->{wrap_dbrefs} && $type == 0x03 && exists $value->{'$id'} && exists $value->{'$ref'} ) { $value = BSON::DBRef->new( %$value ); } $bson = substr( $bson, $len, length($bson) - $len ); } # Binary elsif ( $type == 0x05 ) { my ( $len, $btype ) = unpack( BSON_INT32 . BSON_BINARY_TYPE, $bson ); substr( $bson, 0, 5, '' ); if ( $len < 0 ) { croak( sprintf( $ERR_NEG_LENGTH, $key, $type ) ); } if ( $len > length($bson) ) { croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); } my $binary = substr( $bson, 0, $len, '' ); if ( $btype == 2 ) { if ( $len < 4 ) { croak( sprintf( $ERR_BAD_OLDBINARY, $key, $type ) ); } my $sublen = unpack( BSON_INT32, $binary ); if ( $sublen != length($binary) - 4 ) { croak( sprintf( $ERR_BAD_OLDBINARY, $key, $type ) ); } substr( $binary, 0, 4, '' ); } $value = BSON::Bytes->new( subtype => $btype, data => $binary ); } # Undef (deprecated) elsif ( $type == 0x06 ) { $value = undef; } # ObjectId elsif ( $type == 0x07 ) { ( my $oid, $bson ) = unpack( BSON_OBJECTID.BSON_REMAINING, $bson ); $value = BSON::OID->new(oid => $oid); } # Boolean elsif ( $type == 0x08 ) { ( my $bool, $bson ) = unpack( BSON_BOOLEAN.BSON_REMAINING, $bson ); croak("BSON boolean must be 0 or 1. Key '$key' is $bool") unless $bool == 0 || $bool == 1; $value = boolean( $bool ); } # Datetime elsif ( $type == 0x09 ) { if ( HAS_INT64 ) { ($value, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson); } else { ($value, $bson) = unpack(BSON_8BYTES.BSON_REMAINING,$bson); $value = _int64_to_bigint($value); } $value = BSON::Time->new( value => $value ); my $dt_type = $opt->{dt_type}; if ( defined $dt_type && $dt_type ne 'BSON::Time' ) { $value = $dt_type eq 'Time::Moment' ? $value->as_time_moment : $dt_type eq 'DateTime' ? $value->as_datetime : $dt_type eq 'DateTime::Tiny' ? $value->as_datetime_tiny : $dt_type eq 'Mango::BSON::Time' ? $value->as_mango_time : croak("Unsupported dt_type '$dt_type'"); } } # Null elsif ( $type == 0x0A ) { $value = undef; } # Regex elsif ( $type == 0x0B ) { ( my $re, my $op, $bson ) = unpack( BSON_CSTRING.BSON_CSTRING.BSON_REMAINING, $bson ); $value = BSON::Regex->new( pattern => $re, flags => $op ); } # DBPointer (deprecated) elsif ( $type == 0x0C ) { ( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson ); if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) { croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); } ( my ($ref), $bson ) = unpack( "a$len" . BSON_REMAINING, $bson ); chop($ref); # remove trailing \x00 if ( !utf8::decode($ref) ) { croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); } ( my ($oid), $bson ) = unpack( BSON_OBJECTID . BSON_REMAINING, $bson ); $value = BSON::DBRef->new( '$ref' => $ref, '$id' => BSON::OID->new( oid => $oid ) ); } # Code elsif ( $type == 0x0D ) { ( $len, $bson ) = unpack( BSON_INT32 . BSON_REMAINING, $bson ); if ( length($bson) < $len || substr( $bson, $len - 1, 1 ) ne "\x00" ) { croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); } ( $value, $bson ) = unpack( "a$len" . BSON_REMAINING, $bson ); chop($value); # remove trailing \x00 if ( !utf8::decode($value) ) { croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); } $value = BSON::Code->new( code => $value ); } # Code with scope elsif ( $type == 0x0F ) { my $len = unpack( BSON_INT32, $bson ); # validate length if ( $len < 0 ) { croak( sprintf( $ERR_NEG_LENGTH, $key, $type ) ); } if ( $len > length($bson) ) { croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); } if ( $len < 5 ) { croak( sprintf( $ERR_LENGTH, $key, $type, 5, $len ) ); } # extract code and scope and chop off leading length my $codewscope = substr( $bson, 0, $len, '' ); substr( $codewscope, 0, 4, '' ); # extract code ( i.e. string ) my $strlen = unpack( BSON_INT32, $codewscope ); substr( $codewscope, 0, 4, '' ); if ( length($codewscope) < $strlen || substr( $codewscope, -1, 1 ) ne "\x00" ) { croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); } my $code = substr($codewscope, 0, $strlen, '' ); chop($code); # remove trailing \x00 if ( !utf8::decode($code) ) { croak( sprintf( $ERR_BAD_UTF8, $key, $type ) ); } if ( length($codewscope) < 5 ) { croak( sprintf( $ERR_TRUNCATED, $key, $type ) ); } # extract scope my $scopelen = unpack( BSON_INT32, $codewscope ); if ( length($codewscope) < $scopelen || substr( $codewscope, $scopelen - 1, 1 ) ne "\x00" ) { croak( sprintf( $ERR_MISSING_NULL, $key, $type ) ); } my $scope = _decode_bson( $codewscope, { %$opt, _decode_array => 0} ); $value = BSON::Code->new( code => $code, scope => $scope ); } # Int32 elsif ( $type == 0x10 ) { ( $value, $bson ) = unpack( BSON_INT32.BSON_REMAINING, $bson ); $value = BSON::Int32->new( value => $value ) if $opt->{wrap_numbers}; } # Timestamp elsif ( $type == 0x11 ) { ( my $sec, my $inc, $bson ) = unpack( BSON_UINT32.BSON_UINT32.BSON_REMAINING, $bson ); $value = BSON::Timestamp->new( $inc, $sec ); } # Int64 elsif ( $type == 0x12 ) { if ( HAS_INT64 ) { ($value, $bson) = unpack(BSON_INT64.BSON_REMAINING,$bson); } else { ($value, $bson) = unpack(BSON_8BYTES.BSON_REMAINING,$bson); $value = _int64_to_bigint($value); } $value = BSON::Int64->new( value => $value ) if $opt->{wrap_numbers}; } # Decimal128 elsif ( $type == 0x13 ) { ( my $bytes, $bson ) = unpack( BSON_16BYTES.BSON_REMAINING, $bson ); $value = BSON::Decimal128->new( bytes => $bytes ); } # MinKey elsif ( $type == 0xFF ) { $value = BSON::MinKey->new; } # MaxKey elsif ( $type == 0x7F ) { $value = BSON::MaxKey->new; } # ??? else { # Should have already been caught in the minimum length check, # but just in case not: croak( sprintf( $ERR_UNSUPPORTED, $type, $key ) ); } if ( $opt->{_decode_array} ) { push @array, $value; } else { $hash{$key} = $value; } } $opt->{_depth}--; return $opt->{_decode_array} ? \@array : \%hash; } 1; =pod =encoding UTF-8 =head1 NAME BSON::PP - Pure Perl BSON implementation =head1 VERSION version v1.12.1 =head1 DESCRIPTION This module contains the pure-Perl implementation for BSON encoding and decoding. There is no public API. Use the L module and it will choose the best implementation for you. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Int64.pm000644 000765 000024 00000012657 13524525151 015544 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Int64; # ABSTRACT: BSON type wrapper for Int64 use version; our $VERSION = 'v1.12.1'; use Carp; use Config; use Moo; #pod =attr value #pod #pod A numeric scalar. It will be coerced to an integer. The default is 0. #pod #pod =cut has 'value' => ( is => 'ro' ); use if !$Config{use64bitint}, "Math::BigInt"; use namespace::clean -except => 'meta'; # With long doubles or a 32-bit integer perl, we're able to directly check # if a value exceeds the maximum bounds of an int64_t. On a 64-bit Perl # with only regular doubles, the loss of precision for doubles makes an # exact check against the negative boundary impossible from pure-Perl. # (The positive boundary isn't an issue because Perl will upgrade # internally to uint64_t to do the comparision). Fortunately, we can take # advantage of a quirk in pack(), where a float that is in the ambiguous # negative zone or that is too negative to fit will get packed like the # smallest negative int64_t. BEGIN { my $max_int64 = $Config{use64bitint} ? 9223372036854775807 : Math::BigInt->new("9223372036854775807"); my $min_int64 = $Config{use64bitint} ? -9223372036854775808 : Math::BigInt->new("-9223372036854775808"); if ( $Config{nvsize} == 16 || ! $Config{use64bitint} ) { *BUILD = sub { my $self = shift; my $value = defined $self->{value} ? int($self->{value}) : 0; if ( $value > $max_int64 ) { $value = $max_int64; } elsif ( $value < $min_int64 ) { $value = $min_int64; } return $self->{value} = $value; } } else { my $packed_min_int64 = pack("q<", $min_int64); *BUILD = sub { my $self = shift; my $value = defined $self->{value} ? int($self->{value}) : 0; if ( $value >= 0 && $value > $max_int64 ) { $value = $max_int64; } elsif ( $value < 0 && pack("q<", $value) eq $packed_min_int64 ) { $value = $min_int64; } return $self->{value} = $value; } } } #pod =method TO_JSON #pod #pod On a 64-bit perl, returns the value as an integer. On a 32-bit Perl, it #pod will be returned as a Math::BigInt object, which will #pod fail to serialize unless a C method is defined #pod for that or in package C. #pod #pod If the C environment variable is true and the #pod C environment variable is false, returns a hashref #pod compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$numberLong" : "223372036854775807"} #pod #pod =cut sub TO_JSON { return int($_[0]->{value}) if ! $ENV{BSON_EXTJSON} || $ENV{BSON_EXTJSON_RELAXED}; return { '$numberLong' => "$_[0]->{value}" }; } use overload ( # Unary q{""} => sub { "$_[0]->{value}" }, q{0+} => sub { $_[0]->{value} }, q{~} => sub { ~( $_[0]->{value} ) }, # Binary ( map { $_ => eval "sub { return \$_[0]->{value} $_ \$_[1] }" } qw( + * ) ), ## no critic ( map { $_ => eval ## no critic "sub { return \$_[2] ? \$_[1] $_ \$_[0]->{value} : \$_[0]->{value} $_ \$_[1] }" } qw( - / % ** << >> x <=> cmp & | ^ ) ), ( map { $_ => eval "sub { return $_(\$_[0]->{value}) }" } ## no critic qw( cos sin exp log sqrt int ) ), q{atan2} => sub { return $_[2] ? atan2( $_[1], $_[0]->{value} ) : atan2( $_[0]->{value}, $_[1] ); }, # Special fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::Int64 - BSON type wrapper for Int64 =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_int64( $number ); =head1 DESCRIPTION This module provides a BSON type wrapper for a numeric value that would be represented in BSON as a 64-bit integer. If the value won't fit in a 64-bit integer, an error will be thrown. On a Perl without 64-bit integer support, the value must be a L object. =head1 ATTRIBUTES =head2 value A numeric scalar. It will be coerced to an integer. The default is 0. =head1 METHODS =head2 TO_JSON On a 64-bit perl, returns the value as an integer. On a 32-bit Perl, it will be returned as a Math::BigInt object, which will fail to serialize unless a C method is defined for that or in package C. If the C environment variable is true and the C environment variable is false, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$numberLong" : "223372036854775807"} =for Pod::Coverage BUILD =head1 OVERLOADING The numification operator, C<0+> is overloaded to return the C, the full "minimal set" of overloaded operations is provided (per L documentation) and fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Bool.pm000644 000765 000024 00000002277 13524525151 015530 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Bool; # ABSTRACT: Legacy BSON type wrapper for Booleans (DEPRECATED) use version; our $VERSION = 'v1.12.1'; use boolean 0.45 (); our @ISA = qw/boolean/; sub new { my ( $class, $bool ) = @_; return bless \(my $dummy = $bool ? 1 : 0), $class; } sub value { ${$_[0]} ? 1 : 0; } sub true { return $_[0]->new(1); } sub false { return $_[0]->new(0); } sub op_eq { return !! $_[0] == !! $_[1]; } 1; =pod =encoding UTF-8 =head1 NAME BSON::Bool - Legacy BSON type wrapper for Booleans (DEPRECATED) =head1 VERSION version v1.12.1 =head1 DESCRIPTION This module has been deprecated as it was not compatible with other common boolean implementations on CPAN. You are strongly encouraged to use L directly instead. =for Pod::Coverage new value true false op_eq =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Types.pm000644 000765 000024 00000034543 13524525151 015742 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Types; # ABSTRACT: Helper functions to wrap BSON type classes use version; our $VERSION = 'v1.12.1'; use base 'Exporter'; our @EXPORT_OK = qw( bson_bool bson_bytes bson_code bson_dbref bson_decimal128 bson_doc bson_array bson_double bson_int32 bson_int64 bson_maxkey bson_minkey bson_oid bson_raw bson_regex bson_string bson_time bson_timestamp ); our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] ); use Carp; use boolean; # bson_bool use BSON::Bytes; # bson_bytes use BSON::Code; # bson_code use BSON::DBRef; # bson_dbref use BSON::Decimal128; # bson_decimal128 use BSON::Doc; # bson_doc use BSON::Array; # bson_array use BSON::Double; # bson_double use BSON::Int32; # bson_int32 use BSON::Int64; # bson_int64 use BSON::MaxKey; # bson_maxkey use BSON::MinKey; # bson_minkey use BSON::OID; # bson_oid use BSON::Raw; # bson_raw use BSON::Regex; # bson_regex use BSON::String; # bson_string use BSON::Time; # bson_time use BSON::Timestamp; # bson_timestamp use BSON::Symbol; use BSON::DBPointer; # deprecated, but load anyway use BSON::Bool; use BSON::Binary; use BSON::ObjectId; #pod =func bson_bytes #pod #pod $bytes = bson_bytes( $byte_string ); #pod $bytes = bson_bytes( $byte_string, $subtype ); #pod #pod This function returns a L object wrapping the provided string. #pod A numeric subtype may be provided as a second argument, but this is not #pod recommended for new applications. #pod #pod =cut sub bson_bytes { return BSON::Bytes->new( data => ( defined( $_[0] ) ? $_[0] : '' ), subtype => ( $_[1] || 0 ), ); } #pod =func bson_code #pod #pod $code = bson_code( $javascript ); #pod $code = bson_code( $javascript, $hashref ); #pod #pod This function returns a L object wrapping the provided Javascript #pod code. An optional hashref representing variables in scope for the function #pod may be given as well. #pod #pod =cut sub bson_code { return BSON::Code->new unless defined $_[0]; return BSON::Code->new( code => $_[0] ) unless defined $_[1]; return BSON::Code->new( code => $_[0], scope => $_[1] ); } #pod =func bson_dbref #pod #pod $dbref = bson_dbref( $object_id, $collection_name ); #pod #pod This function returns a L object wrapping the provided Object ID #pod and collection name. #pod #pod =cut sub bson_dbref { croak "Arguments to bson_dbref must an id and collection name" unless @_ == 2; return BSON::DBRef->new( id => $_[0], ref => $_[1] ); } #pod =func bson_decimal128 #pod #pod $decimal = bson_decimal128( "0.12" ); #pod $decimal = bson_decimal128( "1.23456789101112131415116E-412" ); #pod #pod This function returns a L object wrapping the provided #pod decimal B. Unlike floating point values, this preserves exact #pod decimal precision. #pod #pod =cut sub bson_decimal128 { return BSON::Decimal128->new( value => defined $_[0] ? $_[0] : 0 ) } #pod =func bson_doc #pod #pod $doc = bson_doc( first => "hello, second => "world" ); #pod #pod This function returns a L object, which preserves the order #pod of the provided key-value pairs. #pod #pod =cut sub bson_doc { return BSON::Doc->new( @_ ); } #pod =func bson_array #pod #pod $doc = bson_array(...); #pod #pod This function returns a L object, which preserves the order #pod of the provided list of elements. #pod #pod =cut sub bson_array { return BSON::Array->new( @_ ); } #pod =func bson_double #pod #pod $double = bson_double( 1.0 ); #pod #pod This function returns a L object wrapping a native #pod double value. This ensures it serializes to BSON as a double rather #pod than a string or integer given Perl's lax typing for scalars. #pod #pod =cut sub bson_double { return BSON::Double->new( value => $_[0] ) } #pod =func bson_int32 #pod #pod $int32 = bson_int32( 42 ); #pod #pod This function returns a L object wrapping a native #pod integer value. This ensures it serializes to BSON as an Int32 rather #pod than a string or double given Perl's lax typing for scalars. #pod #pod =cut sub bson_int32 { return BSON::Int32->new unless defined $_[0]; return BSON::Int32->new( value => $_[0] ) } #pod =func bson_int64 #pod #pod $int64 = bson_int64( 0 ); # 64-bit zero #pod #pod This function returns a L object, wrapping a native #pod integer value. This ensures it serializes to BSON as an Int64 rather #pod than a string or double given Perl's lax typing for scalars. #pod #pod =cut sub bson_int64 { return BSON::Int64->new unless defined $_[0]; return BSON::Int64->new( value => $_[0] ) } #pod =func bson_maxkey #pod #pod $maxkey = bson_maxkey(); #pod #pod This function returns a singleton representing the "maximum key" #pod BSON type. #pod #pod =cut sub bson_maxkey { return BSON::MaxKey->new; } #pod =func bson_minkey #pod #pod $minkey = bson_minkey(); #pod #pod This function returns a singleton representing the "minimum key" #pod BSON type. #pod #pod =cut sub bson_minkey { return BSON::MinKey->new; } #pod =func bson_oid #pod #pod $oid = bson_oid(); # generate a new one #pod $oid = bson_oid( $bytes ); # from 12-byte packed OID #pod $oid = bson_oid( $hex ); # from 24 hex characters #pod #pod This function returns a L object wrapping a 12-byte MongoDB Object #pod ID. With no arguments, a new, unique Object ID is generated instead. If #pod 24 hexadecimal characters are given, they will be packed into a 12-byte #pod Object ID. #pod #pod =cut sub bson_oid { return BSON::OID->new unless defined $_[0]; return BSON::OID->new( oid => $_[0] ) if length( $_[0] ) == 12; return BSON::OID->new( oid => pack( "H*", $_[0] ) ) if $_[0] =~ m{\A[0-9a-f]{24}\z}i; croak "Arguments to bson_oid must be 12 packed bytes or 24 bytes of hex"; } #pod =func bson_raw #pod #pod $raw = bson_raw( $bson_encoded ); #pod #pod This function returns a L object wrapping an already BSON-encoded #pod document. #pod #pod =cut sub bson_raw { return BSON::Raw->new( bson => $_[0] ); } #pod =func bson_regex #pod #pod $regex = bson_regex( $pattern ); #pod $regex = bson_regex( $pattern, $flags ); #pod #pod This function returns a L object wrapping a PCRE pattern and #pod optional flags. #pod #pod =cut sub bson_regex { return BSON::Regex->new unless defined $_[0]; return BSON::Regex->new( pattern => $_[0] ) unless defined $_[1]; return BSON::Regex->new( pattern => $_[0], flags => $_[1] ); } #pod =func bson_string #pod #pod $string = bson_string( "08544" ); #pod #pod This function returns a L object, wrapping a native #pod string value. This ensures it serializes to BSON as a UTF-8 string rather #pod than an integer or double given Perl's lax typing for scalars. #pod #pod =cut sub bson_string { return BSON::String->new( value => $_[0] ); } #pod =func bson_time #pod #pod $time = bson_time( $seconds_from_epoch ); #pod #pod This function returns a L object representing a UTC date and #pod time to millisecond precision. The argument must be given as a number of #pod seconds relative to the Unix epoch (positive or negative). The number may #pod be a floating point value for fractional seconds. If no argument is #pod provided, the current time from L is used. #pod #pod =cut sub bson_time { return BSON::Time->new unless defined $_[0]; # Old constructor format handles floating point math right on # 32-bit platforms. return BSON::Time->new( $_[0] ); } #pod =func bson_timestamp #pod #pod $timestamp = bson_timestamp( $seconds_from_epoch, $increment ); #pod #pod This function returns a L object. It is not recommended #pod for general use. #pod #pod =cut sub bson_timestamp { return BSON::Timestamp->new unless defined $_[0]; return BSON::Timestamp->new( seconds => $_[0] ) unless defined $_[1]; return BSON::Timestamp->new( seconds => $_[0], increment => $_[1] ); } #pod =func bson_bool (DISCOURAGED) #pod #pod # for consistency with other helpers #pod $bool = bson_bool( $expression ); #pod #pod # preferred for efficiency #pod use boolean; #pod $bool = boolean( $expression ); #pod #pod This function returns a L object (true or false) based on the #pod provided expression (or false if no expression is provided). It is #pod provided for consistency so that all BSON types have a corresponding helper #pod function. #pod #pod For efficiency, use C directly, instead. #pod #pod =cut sub bson_bool { return boolean($_[0]); } 1; =pod =encoding UTF-8 =head1 NAME BSON::Types - Helper functions to wrap BSON type classes =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; $int32 = bson_int32(42); $double = bson_double(3.14159); $decimal = bson_decimal("24.01"); $time = bson_time(); # now ... =head1 DESCRIPTION This module provides helper functions for BSON type wrappers. Type wrappers use objects corresponding to BSON types to represent data that would have ambiguous type or don't have a native Perl representation For example, because Perl scalars can represent strings, integers or floating point numbers, the serialization rules depend on various heuristics. By wrapping a Perl scalar with a class, such as L, users can specify exactly how a scalar should serialize to BSON. =head1 FUNCTIONS =head2 bson_bytes $bytes = bson_bytes( $byte_string ); $bytes = bson_bytes( $byte_string, $subtype ); This function returns a L object wrapping the provided string. A numeric subtype may be provided as a second argument, but this is not recommended for new applications. =head2 bson_code $code = bson_code( $javascript ); $code = bson_code( $javascript, $hashref ); This function returns a L object wrapping the provided Javascript code. An optional hashref representing variables in scope for the function may be given as well. =head2 bson_dbref $dbref = bson_dbref( $object_id, $collection_name ); This function returns a L object wrapping the provided Object ID and collection name. =head2 bson_decimal128 $decimal = bson_decimal128( "0.12" ); $decimal = bson_decimal128( "1.23456789101112131415116E-412" ); This function returns a L object wrapping the provided decimal B. Unlike floating point values, this preserves exact decimal precision. =head2 bson_doc $doc = bson_doc( first => "hello, second => "world" ); This function returns a L object, which preserves the order of the provided key-value pairs. =head2 bson_array $doc = bson_array(...); This function returns a L object, which preserves the order of the provided list of elements. =head2 bson_double $double = bson_double( 1.0 ); This function returns a L object wrapping a native double value. This ensures it serializes to BSON as a double rather than a string or integer given Perl's lax typing for scalars. =head2 bson_int32 $int32 = bson_int32( 42 ); This function returns a L object wrapping a native integer value. This ensures it serializes to BSON as an Int32 rather than a string or double given Perl's lax typing for scalars. =head2 bson_int64 $int64 = bson_int64( 0 ); # 64-bit zero This function returns a L object, wrapping a native integer value. This ensures it serializes to BSON as an Int64 rather than a string or double given Perl's lax typing for scalars. =head2 bson_maxkey $maxkey = bson_maxkey(); This function returns a singleton representing the "maximum key" BSON type. =head2 bson_minkey $minkey = bson_minkey(); This function returns a singleton representing the "minimum key" BSON type. =head2 bson_oid $oid = bson_oid(); # generate a new one $oid = bson_oid( $bytes ); # from 12-byte packed OID $oid = bson_oid( $hex ); # from 24 hex characters This function returns a L object wrapping a 12-byte MongoDB Object ID. With no arguments, a new, unique Object ID is generated instead. If 24 hexadecimal characters are given, they will be packed into a 12-byte Object ID. =head2 bson_raw $raw = bson_raw( $bson_encoded ); This function returns a L object wrapping an already BSON-encoded document. =head2 bson_regex $regex = bson_regex( $pattern ); $regex = bson_regex( $pattern, $flags ); This function returns a L object wrapping a PCRE pattern and optional flags. =head2 bson_string $string = bson_string( "08544" ); This function returns a L object, wrapping a native string value. This ensures it serializes to BSON as a UTF-8 string rather than an integer or double given Perl's lax typing for scalars. =head2 bson_time $time = bson_time( $seconds_from_epoch ); This function returns a L object representing a UTC date and time to millisecond precision. The argument must be given as a number of seconds relative to the Unix epoch (positive or negative). The number may be a floating point value for fractional seconds. If no argument is provided, the current time from L is used. =head2 bson_timestamp $timestamp = bson_timestamp( $seconds_from_epoch, $increment ); This function returns a L object. It is not recommended for general use. =head2 bson_bool (DISCOURAGED) # for consistency with other helpers $bool = bson_bool( $expression ); # preferred for efficiency use boolean; $bool = boolean( $expression ); This function returns a L object (true or false) based on the provided expression (or false if no expression is provided). It is provided for consistency so that all BSON types have a corresponding helper function. For efficiency, use C directly, instead. =for Pod::Coverage BUILD =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Symbol.pm000644 000765 000024 00000001547 13524525151 016101 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Symbol; # ABSTRACT: BSON type wrapper for symbol data (DEPRECATED) our $VERSION = 'v1.12.1'; use Moo 2.002004; use namespace::clean -except => 'meta'; extends 'BSON::String'; 1; =pod =encoding UTF-8 =head1 NAME BSON::Symbol - BSON type wrapper for symbol data (DEPRECATED) =head1 VERSION version v1.12.1 =head1 DESCRIPTION This module wraps the deprecated BSON "symbol" type. You are strongly encouraged to use ordinary string data instead. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Code.pm000644 000765 000024 00000007130 13524525151 015500 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Code; # ABSTRACT: BSON type wrapper for Javascript code use version; our $VERSION = 'v1.12.1'; use Carp (); use Tie::IxHash; use Moo; #pod =attr code #pod #pod A string containing Javascript code. Defaults to the empty string. #pod #pod =attr scope #pod #pod An optional hash reference containing variables in the scope of C. #pod Defaults to C. #pod #pod =cut has [ qw/code scope/ ] => ( is => 'ro' ); use namespace::clean -except => 'meta'; #pod =method length #pod #pod Returns the length of the C attribute. #pod #pod =cut sub length { length( $_[0]->code ); } # Support legacy constructor shortcut sub BUILDARGS { my ($class) = shift; my %args; if ( @_ && $_[0] !~ /^[c|s]/ ) { $args{code} = $_[0]; $args{scope} = $_[1] if defined $_[1]; } else { Carp::croak( __PACKAGE__ . "::new called with an odd number of elements\n" ) unless @_ % 2 == 0; %args = @_; } return \%args; } sub BUILD { my ($self) = @_; $self->{code} = '' unless defined $self->{code}; Carp::croak( __PACKAGE__ . " scope must be hash reference, not $self->{scope}") if exists($self->{scope}) && ref($self->{scope}) ne 'HASH'; return; } #pod =method TO_JSON #pod #pod If the C option is true, returns a hashref compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$code" : ""} #pod {"$code" : "", "$scope" : { ... } } #pod #pod If the C option is false, an error is thrown, as this value #pod can't otherwise be represented in JSON. #pod #pod =cut sub TO_JSON { require BSON; if ( $ENV{BSON_EXTJSON} ) { my %data; tie( %data, 'Tie::IxHash' ); $data{'$code'} = $_[0]->{code}; $data{'$scope'} = BSON->perl_to_extjson($_[0]->{scope}) if defined $_[0]->{scope}; return \%data; } Carp::croak( "The value '$_[0]' is illegal in JSON" ); } 1; =pod =encoding UTF-8 =head1 NAME BSON::Code - BSON type wrapper for Javascript code =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; $code = bson_code( $javascript ); $code = bson_code( $javascript, $scope ); =head1 DESCRIPTION This module provides a BSON type wrapper for the "Javascript code" type and the "Javascript with Scope" BSON types. =head1 ATTRIBUTES =head2 code A string containing Javascript code. Defaults to the empty string. =head2 scope An optional hash reference containing variables in the scope of C. Defaults to C. =head1 METHODS =head2 length Returns the length of the C attribute. =head2 TO_JSON If the C option is true, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$code" : ""} {"$code" : "", "$scope" : { ... } } If the C option is false, an error is thrown, as this value can't otherwise be represented in JSON. =for Pod::Coverage BUILD BUILDARGS =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/DBRef.pm000644 000765 000024 00000016114 13524525151 015552 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::DBRef; # ABSTRACT: BSON type wrapper for MongoDB DBRefs use version; our $VERSION = 'v1.12.1'; use Tie::IxHash; use Moo 2.002004; use namespace::clean -except => 'meta'; use BSON (); #pod =attr id #pod #pod Required. The C<_id> value of the referenced document. If the #pod C<_id> is an ObjectID, then you must use a L object. #pod #pod =cut # no type constraint since an _id can be anything has id => ( is => 'ro', required => 1 ); #pod =attr ref #pod #pod Required. The name of the collection in which the referenced document #pod lives. Either a L object or a string containing the #pod collection name. The object will be coerced to string form. #pod #pod This may also be specified in the constructor as C<'$ref'>. #pod #pod =cut has 'ref' => ( is => 'ro', required => 1, coerce => sub { CORE::ref($_[0]) eq 'MongoDB::Collection' ? $_[0]->name : $_[0] }, isa => sub { die "must be a non-empty string" unless defined($_[0]) && length($_[0]) }, ); #pod =attr db #pod #pod Optional. The database in which the referenced document lives. Either a #pod L object or a string containing the database name. The #pod object will be coerced to string form. #pod #pod Not all other language drivers support the C<$db> field, so using this #pod field is not recommended. #pod #pod This may also be specified in the constructor as C<'$db'>. #pod #pod =cut has db => ( is => 'ro', coerce => sub { CORE::ref($_[0]) eq 'MongoDB::DataBase' ? $_[0]->name : $_[0] }, isa => sub { return if ! defined($_[0]); die "must be a non-empty string" unless length($_[0]) }, ); #pod =attr extra #pod #pod Optional. A hash reference of additional fields in the DBRef document. #pod Not all MongoDB drivers support this feature and you B rely on #pod it. This attribute exists solely to ensure DBRefs generated by drivers that #pod do allow extra fields will round-trip correctly. #pod #pod B #pod #pod =cut has extra => ( is => 'ro', isa => sub { return if ! defined($_[0]); die "must be a hashref" unless eval { scalar %{$_[0]}; 1 } }, default => sub { {} }, ); around BUILDARGS => sub { my $orig = shift; my $class = shift; my $hr = $class->$orig(@_); return { id => ( exists( $hr->{'$id'} ) ? delete $hr->{'$id'} : exists( $hr->{id} ) ? delete $hr->{id} : undef ), 'ref' => ( exists( $hr->{'$ref'} ) ? delete $hr->{'$ref'} : exists( $hr->{'ref'}) ? delete $hr->{'ref'} : undef ), db => ( exists( $hr->{'$db'} ) ? delete $hr->{'$db'} : exists( $hr->{db} ) ? delete $hr->{db} : undef ), extra => $hr, }; }; sub _ordered { my $self = shift; return Tie::IxHash->new( '$ref' => $self->ref, '$id' => $self->id, ( defined($self->db) ? ( '$db' => $self->db ) : () ), %{ $self->extra }, ); } #pod =method TO_JSON #pod #pod If the C option is true, returns a hashref compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod { "$ref": "", "$id": "" } #pod #pod If the C option is false, an error is thrown, as this value #pod can't otherwise be represented in JSON. #pod #pod =cut sub TO_JSON { my $self = shift; if ( $ENV{BSON_EXTJSON} ) { my $id = $self->id; if (ref $id) { $id = $id->TO_JSON; } else { $id = BSON->perl_to_extjson($id); } my %data; tie( %data, 'Tie::IxHash' ); $data{'$ref'} = $self->ref; $data{'$id'} = $id; $data{'$db'} = $self->db if defined $self->db; my $extra = $self->extra; $data{$_} = $extra->{$_} for keys %$extra; return \%data; } Carp::croak( "The value '$self' is illegal in JSON" ); } 1; =pod =encoding UTF-8 =head1 NAME BSON::DBRef - BSON type wrapper for MongoDB DBRefs =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; my $dbref = bson_dbref( $oid, $collection_name ); =head1 DESCRIPTION This module provides a BSON type wrapper for L. A DBRef is a special document format which references another document in the database. DBRefs are not the same as foreign keys and do not provide any referential integrity or constraint checking. For example, a DBRef may point to a document that no longer exists (or never existed.) Use of DBRefs is discouraged, so this module is provided for backwards compatibility. L<"Manual references"|https://docs.mongodb.com/manual/reference/database-references/#document-references> are preferred when there is a need to reference other documents. =head1 ATTRIBUTES =head2 id Required. The C<_id> value of the referenced document. If the C<_id> is an ObjectID, then you must use a L object. =head2 ref Required. The name of the collection in which the referenced document lives. Either a L object or a string containing the collection name. The object will be coerced to string form. This may also be specified in the constructor as C<'$ref'>. =head2 db Optional. The database in which the referenced document lives. Either a L object or a string containing the database name. The object will be coerced to string form. Not all other language drivers support the C<$db> field, so using this field is not recommended. This may also be specified in the constructor as C<'$db'>. =head2 extra Optional. A hash reference of additional fields in the DBRef document. Not all MongoDB drivers support this feature and you B rely on it. This attribute exists solely to ensure DBRefs generated by drivers that do allow extra fields will round-trip correctly. B =head1 METHODS =head2 TO_JSON If the C option is true, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: { "$ref": "", "$id": "" } If the C option is false, an error is thrown, as this value can't otherwise be represented in JSON. =for Pod::Coverage BUILDARGS =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Int32.pm000644 000765 000024 00000006761 13524525151 015536 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Int32; # ABSTRACT: BSON type wrapper for Int32 use version; our $VERSION = 'v1.12.1'; use Carp; use Moo; #pod =attr value #pod #pod A numeric scalar. It will be coerced to an integer. The default is 0. #pod #pod =cut has 'value' => ( is => 'ro' ); use namespace::clean -except => 'meta'; my $max_int32 = 2147483647; my $min_int32 = -2147483648; sub BUILD { my $self = shift; # coerce to IV internally $self->{value} = defined( $self->{value} ) ? int( $self->{value} ) : 0; if ( $self->{value} > $max_int32 || $self->{value} < $min_int32 ) { croak("The value '$self->{value}' can't fit in a signed Int32"); } } #pod =method TO_JSON #pod #pod Returns the value as an integer. #pod #pod If the C environment variable is true and the #pod C environment variable is false, returns a hashref #pod compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$numberInt" : "42"} #pod #pod =cut sub TO_JSON { return int($_[0]->{value}) if ! $ENV{BSON_EXTJSON} || $ENV{BSON_EXTJSON_RELAXED}; return { '$numberInt' => "$_[0]->{value}" }; } use overload ( # Unary q{""} => sub { "$_[0]->{value}" }, q{0+} => sub { $_[0]->{value} }, q{~} => sub { ~( $_[0]->{value} ) }, # Binary ( map { $_ => eval "sub { return \$_[0]->{value} $_ \$_[1] }" } qw( + * ) ), ## no critic ( map { $_ => eval ## no critic "sub { return \$_[2] ? \$_[1] $_ \$_[0]->{value} : \$_[0]->{value} $_ \$_[1] }" } qw( - / % ** << >> x <=> cmp & | ^ ) ), ( map { $_ => eval "sub { return $_(\$_[0]->{value}) }" } ## no critic qw( cos sin exp log sqrt int ) ), q{atan2} => sub { return $_[2] ? atan2( $_[1], $_[0]->{value} ) : atan2( $_[0]->{value}, $_[1] ); }, # Special fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::Int32 - BSON type wrapper for Int32 =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_int32( $number ); =head1 DESCRIPTION This module provides a BSON type wrapper for a numeric value that would be represented in BSON as a 32-bit integer. If the value won't fit in a 32-bit integer, an error will be thrown. =head1 ATTRIBUTES =head2 value A numeric scalar. It will be coerced to an integer. The default is 0. =head1 METHODS =head2 TO_JSON Returns the value as an integer. If the C environment variable is true and the C environment variable is false, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$numberInt" : "42"} =for Pod::Coverage BUILD =head1 OVERLOADING The numification operator, C<0+> is overloaded to return the C, the full "minimal set" of overloaded operations is provided (per L documentation) and fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/DBPointer.pm000644 000765 000024 00000002762 13524525151 016462 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::DBPointer; # ABSTRACT: Legacy BSON type wrapper for DBPointer data (DEPRECATED) our $VERSION = 'v1.12.1'; use Moo 2.002004; use Tie::IxHash; use namespace::clean -except => 'meta'; extends 'BSON::DBRef'; sub TO_JSON { my $self = shift; if ( $ENV{BSON_EXTJSON} ) { my $id = $self->id; if (ref $id) { $id = $id->TO_JSON; } else { $id = BSON->perl_to_extjson($id); } my %data; tie( %data, 'Tie::IxHash' ); $data{'$ref'} = $self->ref; $data{'$id'} = $id; $data{'$db'} = $self->db if defined $self->db; my $extra = $self->extra; $data{$_} = $extra->{$_} for keys %$extra; return \%data; } Carp::croak( "The value '$self' is illegal in JSON" ); } 1; =pod =encoding UTF-8 =head1 NAME BSON::DBPointer - Legacy BSON type wrapper for DBPointer data (DEPRECATED) =head1 VERSION version v1.12.1 =head1 DESCRIPTION This module wraps the deprecated BSON "DBPointer" type. You are strongly encouraged to use L instead. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Doc.pm000644 000765 000024 00000003011 13524525151 015325 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Doc; # ABSTRACT: BSON type wrapper for ordered documents use version; our $VERSION = 'v1.12.1'; use Carp qw/croak/; use Tie::IxHash; sub new { my ( $class, @args ) = @_; croak "BSON::Doc::new requires key/value pairs" if @args % 2 != 0; my $key_count =()= keys %{{@args}}; croak "Duplicate keys not allowed in BSON::Doc" if $key_count * 2 != @args; return bless \@args, $class; } sub _as_tied_hash { my $self = shift; tie my %h, 'Tie::IxHash', @$self; return \%h; } sub _iterator { my $self = shift; my $index = 0; return sub { return if $index > $#{$self}; my ($k,$v) = @{$self}[$index, $index+1]; $index += 2; return ($k,$v); } } 1; =pod =encoding UTF-8 =head1 NAME BSON::Doc - BSON type wrapper for ordered documents =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; my $ordered = bson_doc( first => 1, second => 2 ); =head1 DESCRIPTION This module provides a BSON type wrapper representing a document preserves key-value order. It is currently read-only. =for Pod::Coverage new =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Array.pm000644 000765 000024 00000002214 13524525151 015702 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Array; # ABSTRACT: BSON type wrapper for a list of elements use version; our $VERSION = 'v1.12.1'; sub new { my ( $class, @args ) = @_; return bless [@args], $class; } 1; =pod =encoding UTF-8 =head1 NAME BSON::Array - BSON type wrapper for a list of elements =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; my $array = bson_array(...); =head1 DESCRIPTION This module provides a BSON type wrapper representing a list of elements. It is currently read-only. Wrapping is usually not necessary as an ordinary array reference is usually sufficient. This class is helpful for cases where an array reference could be ambiguously interpreted as a top-level document container. =for Pod::Coverage new =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Bytes.pm000644 000765 000024 00000006354 13524525151 015723 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Bytes; # ABSTRACT: BSON type wrapper for binary byte strings use version; our $VERSION = 'v1.12.1'; use MIME::Base64 (); use Tie::IxHash; use Moo; #pod =attr data #pod #pod A scalar, interpreted as bytes. (I.e. "character" data should be encoded #pod to bytes.) It defaults to the empty string. #pod #pod =attr subtype #pod #pod A numeric BSON subtype between 0 and 255. This defaults to 0 and generally #pod should not be modified. Subtypes 128 to 255 are "user-defined". #pod #pod =cut has [qw/data subtype/] => ( is => 'ro', ); use namespace::clean -except => 'meta'; sub BUILD { my ($self) = @_; $self->{data} = '' unless defined $self->{data}; $self->{subtype} = 0 unless defined $self->{subtype}; } #pod =method TO_JSON #pod #pod Returns Base64 encoded string equivalent to the data attribute. #pod #pod If the C option is true, it will instead be compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$binary" : { "base64": "", "subType" : ""} } #pod #pod =cut sub TO_JSON { return MIME::Base64::encode_base64($_[0]->{data}, "") unless $ENV{BSON_EXTJSON}; my %data; tie( %data, 'Tie::IxHash' ); $data{base64} = MIME::Base64::encode_base64($_[0]->{data}, ""); $data{subType} = sprintf("%02x",$_[0]->{subtype}); return { '$binary' => \%data, }; } use overload ( q{""} => sub { $_[0]->{data} }, fallback => 1, ); # backwards compatibility alias *type = \&subtype; 1; =pod =encoding UTF-8 =head1 NAME BSON::Bytes - BSON type wrapper for binary byte strings =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; $bytes = bson_bytes( $bytestring ); $bytes = bson_bytes( $bytestring, $subtype ); =head1 DESCRIPTION This module provides a BSON type wrapper for binary data represented as a string of bytes. =head1 ATTRIBUTES =head2 data A scalar, interpreted as bytes. (I.e. "character" data should be encoded to bytes.) It defaults to the empty string. =head2 subtype A numeric BSON subtype between 0 and 255. This defaults to 0 and generally should not be modified. Subtypes 128 to 255 are "user-defined". =head1 METHODS =head2 TO_JSON Returns Base64 encoded string equivalent to the data attribute. If the C option is true, it will instead be compatible with MongoDB's L format, which represents it as a document as follows: {"$binary" : { "base64": "", "subType" : ""} } =for Pod::Coverage BUILD type =head1 OVERLOADING The stringification operator (C<"">) is overloaded to return the binary data and fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Timestamp.pm000644 000765 000024 00000010645 13524525151 016576 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Timestamp; # ABSTRACT: BSON type wrapper for timestamps use version; our $VERSION = 'v1.12.1'; use Carp (); use Tie::IxHash; use Moo; #pod =attr seconds #pod #pod A value representing seconds since the Unix epoch. The default is #pod current value of C. #pod #pod =attr increment #pod #pod A numeric value to disambiguate timestamps in the same second. The #pod default is 0. #pod #pod =cut has [qw/seconds increment/] => ( is => 'ro' ); use namespace::clean -except => 'meta'; my $max_int32 = 2147483647; my $max_uint32 = 4_294_967_295; # Support back-compat 'sec' and inc' and legacy constructor shortcut sub BUILDARGS { my ($class) = shift; my %args; if ( @_ && $_[0] !~ /^[s|i]/ ) { $args{seconds} = $_[0]; $args{increment} = $_[1]; } else { Carp::croak( __PACKAGE__ . "::new called with an odd number of elements\n" ) unless @_ % 2 == 0; %args = @_; $args{seconds} = $args{sec} if exists $args{sec} && !exists $args{seconds}; $args{increment} = $args{inc} if exists $args{inc} && !exists $args{increment}; } $args{seconds} = time unless defined $args{seconds}; $args{increment} = 0 unless defined $args{increment}; $args{$_} = int( $args{$_} ) for qw/seconds increment/; return \%args; } sub BUILD { my ($self) = @_; for my $attr (qw/seconds increment/) { my $v = $self->$attr; Carp::croak("BSON::Timestamp '$attr' must be uint32") unless $v >= 0 && $v <= $max_uint32; } return; } # For backwards compatibility { no warnings 'once'; *sec = \&seconds; *inc = \&increment; } #pod =method TO_JSON #pod #pod If the C option is true, returns a hashref compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$timestamp" : { "t":, "i": }} #pod #pod If the C option is false, an error is thrown, as this value #pod can't otherwise be represented in JSON. #pod #pod =cut sub TO_JSON { if ( $ENV{BSON_EXTJSON} ) { my %data; tie %data, 'Tie::IxHash'; $data{t} = int($_[0]->{seconds}); $data{i} = int($_[0]->{increment}); return { '$timestamp' => \%data }; } Carp::croak( "The value '$_[0]' is illegal in JSON" ); } sub _cmp { my ( $l, $r, $swap ) = @_; if ( !defined($l) || !defined($r) ) { Carp::carp "Use of uninitialized value in BSON::Timestamp comparison (<=>); will be treated as 0,0"; } $l //= { seconds => 0, increment => 0 }; $r //= { seconds => 0, increment => 0 }; ($r, $l) = ($l, $r) if $swap; my $cmp = ( $l->{seconds} <=> $r->{seconds} ) || ( $l->{increment} <=> $r->{increment} ); return $cmp; } use overload ( '<=>' => \&_cmp, fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::Timestamp - BSON type wrapper for timestamps =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_timestamp( $seconds ); bson_timestamp( $seconds, $increment ); =head1 DESCRIPTION This module provides a BSON type wrapper for a BSON timestamp value. Generally, it should not be used by end-users, but is provided for backwards compatibility. =head1 ATTRIBUTES =head2 seconds A value representing seconds since the Unix epoch. The default is current value of C. =head2 increment A numeric value to disambiguate timestamps in the same second. The default is 0. =head1 METHODS =head2 TO_JSON If the C option is true, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$timestamp" : { "t":, "i": }} If the C option is false, an error is thrown, as this value can't otherwise be represented in JSON. =for Pod::Coverage BUILD BUILDARGS sec inc =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/String.pm000644 000765 000024 00000005644 13524525151 016104 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::String; # ABSTRACT: BSON type wrapper for strings use version; our $VERSION = 'v1.12.1'; use Moo; #pod =attr value #pod #pod A scalar value, which will be stringified during construction. The default #pod is the empty string. #pod #pod =cut has 'value' => ( is => 'ro' ); use namespace::clean -except => 'meta'; sub BUILDARGS { my $class = shift; my $n = scalar(@_); my %args; if ( $n == 0 ) { $args{value} = ''; } elsif ( $n == 1 ) { $args{value} = shift; } elsif ( $n % 2 == 0 ) { %args = @_; $args{value} = '' unless defined $args{value}; } else { croak("Invalid number of arguments ($n) to BSON::String::new"); } # normalize all to internal PV type $args{value} = "$args{value}"; return \%args; } #pod =method TO_JSON #pod #pod Returns value as a string. #pod #pod =cut sub TO_JSON { return "$_[0]->{value}" } use overload ( # Unary q{bool} => sub { !! $_[0]->{value} }, q{""} => sub { $_[0]->{value} }, q{0+} => sub { 0+ $_[0]->{value} }, q{~} => sub { ~( $_[0]->{value} ) }, # Binary ( map { $_ => eval "sub { return \$_[0]->{value} $_ \$_[1] }" } qw( + * ) ), ## no critic ( map { $_ => eval ## no critic "sub { return \$_[2] ? \$_[1] $_ \$_[0]->{value} : \$_[0]->{value} $_ \$_[1] }" } qw( - / % ** << >> x <=> cmp & | ^ ) ), ( map { $_ => eval "sub { return $_(\$_[0]->{value}) }" } ## no critic qw( cos sin exp log sqrt int ) ), q{atan2} => sub { return $_[2] ? atan2( $_[1], $_[0]->{value} ) : atan2( $_[0]->{value}, $_[1] ); }, # Special fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::String - BSON type wrapper for strings =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_string( $string ); =head1 DESCRIPTION This module provides a BSON type wrapper for a string value. Since Perl does not distinguish between numbers and strings, this module provides an explicit string type for a scalar value. =head1 ATTRIBUTES =head2 value A scalar value, which will be stringified during construction. The default is the empty string. =head1 METHODS =head2 TO_JSON Returns value as a string. =for Pod::Coverage BUILDARGS =head1 OVERLOADING The stringification operator (C<"">) is overloaded to return the C, the full "minimal set" of overloaded operations is provided (per L documentation) and fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Double.pm000644 000765 000024 00000012574 13524525151 016050 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Double; # ABSTRACT: BSON type wrapper for Double use version; our $VERSION = 'v1.12.1'; use Carp; #pod =attr value #pod #pod A numeric scalar (or the special strings "Inf", "-Inf" or "NaN"). This #pod will be coerced to Perl's numeric type. The default is 0.0. #pod #pod =cut use Moo; has 'value' => ( is => 'ro' ); use namespace::clean -except => 'meta'; use constant { nInf => unpack("d<",pack("H*","000000000000f0ff")), pInf => unpack("d<",pack("H*","000000000000f07f")), NaN => unpack("d<",pack("H*","000000000000f8ff")), }; sub BUILD { my $self = shift; # coerce to NV internally $self->{value} = defined( $self->{value} ) ? $self->{value} / 1.0 : 0.0; } #pod =method TO_JSON #pod #pod Returns a double. #pod #pod If the C environment variable is true and the #pod C environment variable is false, returns a hashref #pod compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$numberDouble" : "42.0"} #pod #pod If C is false and the value is 'Inf', '-Inf' or 'NaN' #pod (which are illegal in regular JSON), then an exception is thrown. #pod #pod =cut my $use_win32_specials = ($^O eq 'MSWin32' && $] lt "5.022"); my $win32_specials = qr/-?1.\#IN[DF]/i; my $unix_specials = qr/-?(?:inf|nan)/i; my $illegal = $use_win32_specials ? qr/^$win32_specials/ : qr/^$unix_specials/; my $is_inf = $use_win32_specials ? qr/^1.\#INF/i : qr/^inf/i; my $is_ninf = $use_win32_specials ? qr/^-1.\#INF/i : qr/^-inf/i; my $is_nan = $use_win32_specials ? qr/^-?1.\#(?:IND|QNAN)/i : qr/^-?nan/i; sub TO_JSON { my $copy = "$_[0]->{value}"; # avoid changing value to PVNV if ($ENV{BSON_EXTJSON} && $ENV{BSON_EXTJSON_RELAXED}) { return { '$numberDouble' => 'Infinity' } if $copy =~ $is_inf; return { '$numberDouble' => '-Infinity' } if $copy =~ $is_ninf; return { '$numberDouble' => 'NaN' } if $copy =~ $is_nan; } if ($ENV{BSON_EXTJSON} && !$ENV{BSON_EXTJSON_RELAXED}) { return { '$numberDouble' => 'Infinity' } if $copy =~ $is_inf; return { '$numberDouble' => '-Infinity' } if $copy =~ $is_ninf; return { '$numberDouble' => 'NaN' } if $copy =~ $is_nan; my $value = $_[0]->{value}/1.0; return { '$numberDouble' => "$value" }; } croak( "The value '$copy' is illegal in JSON" ) if $copy =~ $illegal; return $_[0]->{value}/1.0; } use overload ( # Unary q{""} => sub { "$_[0]->{value}" }, q{0+} => sub { $_[0]->{value} }, q{~} => sub { ~( $_[0]->{value} ) }, # Binary ( map { $_ => eval "sub { return \$_[0]->{value} $_ \$_[1] }" } qw( + * ) ), ## no critic ( map { $_ => eval ## no critic "sub { return \$_[2] ? \$_[1] $_ \$_[0]->{value} : \$_[0]->{value} $_ \$_[1] }" } qw( - / % ** << >> x <=> cmp & | ^ ) ), ( map { $_ => eval "sub { return $_(\$_[0]->{value}) }" } ## no critic qw( cos sin exp log sqrt int ) ), q{atan2} => sub { return $_[2] ? atan2( $_[1], $_[0]->{value} ) : atan2( $_[0]->{value}, $_[1] ); }, # Special fallback => 1, ); 1; =pod =encoding UTF-8 =head1 NAME BSON::Double - BSON type wrapper for Double =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; my $bytes = bson_double( $number ); =head1 DESCRIPTION This module provides a BSON type wrapper for a numeric value that would be represented in BSON as a double. =head1 ATTRIBUTES =head2 value A numeric scalar (or the special strings "Inf", "-Inf" or "NaN"). This will be coerced to Perl's numeric type. The default is 0.0. =head1 METHODS =head2 TO_JSON Returns a double. If the C environment variable is true and the C environment variable is false, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$numberDouble" : "42.0"} If C is false and the value is 'Inf', '-Inf' or 'NaN' (which are illegal in regular JSON), then an exception is thrown. =for Pod::Coverage BUILD nInf pInf NaN =head1 INFINITY AND NAN Some Perls may not support converting "Inf" or "NaN" strings to their double equivalent. They are available as functions from the L module, but as a lighter alternative to POSIX, the following functions are available: =over 4 =item * BSON::Double::pInf() – positive infinity =item * BSON::Double::nInf() – negative infinity =item * BSON::Double::NaN() – not-a-number =back =head1 OVERLOADING The numification operator, C<0+> is overloaded to return the C, the full "minimal set" of overloaded operations is provided (per L documentation) and fallback overloading is enabled. =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/MinKey.pm000644 000765 000024 00000003617 13524525151 016030 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::MinKey; # ABSTRACT: BSON type wrapper for MinKey use version; our $VERSION = 'v1.12.1'; use Carp; my $singleton = bless \(my $x), __PACKAGE__; sub new { return $singleton; } #pod =method TO_JSON #pod #pod If the C option is true, returns a hashref compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$minKey" : 1} #pod #pod If the C option is false, an error is thrown, as this value #pod can't otherwise be represented in JSON. #pod #pod =cut sub TO_JSON { if ( $ENV{BSON_EXTJSON} ) { return { '$minKey' => 1 }; } croak( "The value '$_[0]' is illegal in JSON" ); } 1; =pod =encoding UTF-8 =head1 NAME BSON::MinKey - BSON type wrapper for MinKey =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; bson_minkey(); =head1 DESCRIPTION This module provides a BSON type wrapper for the special BSON "MinKey" type. The object returned is a singleton. =head1 METHODS =head2 TO_JSON If the C option is true, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$minKey" : 1} If the C option is false, an error is thrown, as this value can't otherwise be represented in JSON. =for Pod::Coverage new =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/lib/BSON/Regex.pm000644 000765 000024 00000011477 13524525151 015711 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package BSON::Regex; # ABSTRACT: BSON type wrapper for regular expressions use version; our $VERSION = 'v1.12.1'; use Carp (); use Tie::IxHash; use Moo; #pod =attr pattern #pod #pod A B containing a PCRE regular expression pattern (not a C object #pod and without slashes). Default is the empty string. #pod #pod =cut #pod =attr flags #pod #pod A string with regular expression flags. Flags will be sorted and #pod duplicates will be removed during object construction. Supported flags #pod include C. Invalid flags will cause an exception. #pod Default is the empty string. #pod #pod =cut has [qw/pattern flags/] => ( is => 'ro' ); use namespace::clean -except => 'meta'; my %ALLOWED_FLAGS = map { $_ => 1 } qw/i m x l s u/; sub BUILD { my $self = shift; $self->{pattern} = '' unless defined($self->{pattern}); $self->{flags} = '' unless defined($self->{flags}); if ( length $self->{flags} ) { my %seen; my @flags = grep { !$seen{$_}++ } split '', $self->{flags}; foreach my $f (@flags) { Carp::croak("Regex flag $f is not supported") if not exists $ALLOWED_FLAGS{$f}; } # sort flags $self->{flags} = join '', sort @flags; } } #pod =method try_compile #pod #pod my $qr = $regexp->try_compile; #pod #pod Tries to compile the C and C into a reference to a regular #pod expression. If the pattern or flags can't be compiled, a #pod exception will be thrown. #pod #pod B: Executing a regular expression can evaluate arbitrary #pod code if the L 'eval' pragma is in force. You are strongly advised #pod to read L and never to use untrusted input with C. #pod #pod =cut sub try_compile { my ($self) = @_; my ( $p, $f ) = @{$self}{qw/pattern flags/}; my $re = length($f) ? eval { qr/(?$f:$p)/ } : eval { qr/$p/ }; Carp::croak("error compiling regex 'qr/$p/$f': $@") if $@; return $re; } #pod =method TO_JSON #pod #pod If the C option is true, returns a hashref compatible with #pod MongoDB's L #pod format, which represents it as a document as follows: #pod #pod {"$regularExpression" : { pattern: "", "options" : ""} } #pod #pod If the C option is false, an error is thrown, as this value #pod can't otherwise be represented in JSON. #pod #pod =cut sub TO_JSON { if ( $ENV{BSON_EXTJSON} ) { my %data; tie( %data, 'Tie::IxHash' ); $data{pattern} = $_[0]->{pattern}; $data{options} = $_[0]->{flags}; return { '$regularExpression' => \%data, }; } Carp::croak( "The value '$_[0]' is illegal in JSON" ); } 1; =pod =encoding UTF-8 =head1 NAME BSON::Regex - BSON type wrapper for regular expressions =head1 VERSION version v1.12.1 =head1 SYNOPSIS use BSON::Types ':all'; $regex = bson_regex( $pattern ); $regex = bson_regex( $pattern, $flags ); =head1 DESCRIPTION This module provides a BSON type wrapper for a PCRE regular expression and optional flags. =head1 ATTRIBUTES =head2 pattern A B containing a PCRE regular expression pattern (not a C object and without slashes). Default is the empty string. =head2 flags A string with regular expression flags. Flags will be sorted and duplicates will be removed during object construction. Supported flags include C. Invalid flags will cause an exception. Default is the empty string. =head1 METHODS =head2 try_compile my $qr = $regexp->try_compile; Tries to compile the C and C into a reference to a regular expression. If the pattern or flags can't be compiled, a exception will be thrown. B: Executing a regular expression can evaluate arbitrary code if the L 'eval' pragma is in force. You are strongly advised to read L and never to use untrusted input with C. =head2 TO_JSON If the C option is true, returns a hashref compatible with MongoDB's L format, which represents it as a document as follows: {"$regularExpression" : { pattern: "", "options" : ""} } If the C option is false, an error is thrown, as this value can't otherwise be represented in JSON. =for Pod::Coverage BUILD =head1 AUTHORS =over 4 =item * David Golden =item * Stefan G. =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut __END__ # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/xt/author/000755 000765 000024 00000000000 13524525151 014715 5ustar00davidstaff000000 000000 BSON-v1.12.1/xt/release/000755 000765 000024 00000000000 13524525151 015033 5ustar00davidstaff000000 000000 BSON-v1.12.1/xt/release/distmeta.t000644 000765 000024 00000000172 13524525151 017032 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); BSON-v1.12.1/xt/author/critic.t000644 000765 000024 00000000201 13524525151 016350 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; all_critic_ok(); BSON-v1.12.1/xt/author/minimum-version.t000644 000765 000024 00000000155 13524525151 020241 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; use Test::MinimumVersion; all_minimum_version_ok( qq{5.010001} ); BSON-v1.12.1/xt/author/test-version.t000644 000765 000024 00000000637 13524525151 017552 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 1.09 use Test::Version; my @imports = qw( version_all_ok ); my $params = { is_strict => 0, has_version => 1, multiple => 0, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; BSON-v1.12.1/xt/author/00-compile.t000644 000765 000024 00000003654 13524525151 016757 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 use Test::More; plan tests => 26; my @module_files = ( 'BSON.pm', 'BSON/Array.pm', 'BSON/Binary.pm', 'BSON/Bool.pm', 'BSON/Bytes.pm', 'BSON/Code.pm', 'BSON/DBPointer.pm', 'BSON/DBRef.pm', 'BSON/Decimal128.pm', 'BSON/Doc.pm', 'BSON/Double.pm', 'BSON/Int32.pm', 'BSON/Int64.pm', 'BSON/MaxKey.pm', 'BSON/MinKey.pm', 'BSON/OID.pm', 'BSON/ObjectId.pm', 'BSON/PP.pm', 'BSON/Raw.pm', 'BSON/Regex.pm', 'BSON/String.pm', 'BSON/Symbol.pm', 'BSON/Time.pm', 'BSON/Timestamp.pm', 'BSON/Types.pm' ); # fake home for cpan-testers use File::Temp; local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 ); my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { +require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); BSON-v1.12.1/xt/author/pod-syntax.t000644 000765 000024 00000000252 13524525151 017207 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); BSON-v1.12.1/xt/author/portability.t000644 000765 000024 00000000322 13524525151 017441 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; eval 'use Test::Portability::Files'; plan skip_all => 'Test::Portability::Files required for testing portability' if $@; options(test_one_dot => 0); run_tests(); BSON-v1.12.1/xt/author/pod-spell.t000644 000765 000024 00000001353 13524525151 017003 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007005 use Test::Spelling 0.12; use Pod::Wordlist; add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ Array BSON Binary Bloor Bool Bytes Code DBPointer DBRef Daniels David Decimal128 Doc Double Duclos Eric Finn Golden Gunn Inc Int32 Int64 Kostyuk Leich MaxKey MinKey MongoDB OID OIDs ObjectID ObjectId Oleg Olivier PCRE PP Pat Petr Písař Raw Regex Reis Riedel Robert Sedlacek Stefan String Symbol Thomas Time Timestamp Tobias Types VERSIONING Wallace Yury Zavarin and bson codec codecs cub david dbrefs email eric ixhash lib minimalist numification odc oid pgunn ppisar rs sharding tbsliver tock toyou1995 wallace yury BSON-v1.12.1/xt/author/pod-coverage.t000644 000765 000024 00000000334 13524525151 017455 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); BSON-v1.12.1/t/mapping/000755 000765 000024 00000000000 13524525151 014656 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/corpus/000755 000765 000024 00000000000 13524525151 014536 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/backend.t000644 000765 000024 00000001613 13524525151 015000 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; $ENV{PERL_BSON_BACKEND} = "PPSubclass"; eval { require BSON }; is( $@, '', "BSON loads with PERL_BSON_BACKEND set" ); is( BSON->can("_encode_bson"), PPSubclass->can("_encode_bson"), "correct encoder sub" ); is( BSON->can("_decode_bson"), PPSubclass->can("_decode_bson"), "correct decoder sub" ); my $h = { a => 1 }; is_deeply( BSON::decode( BSON::encode($h) ), $h, "round trip works with codec subclass" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/wrapper_apis.t000644 000765 000024 00000004210 13524525151 016101 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; # Undeprecated BSON type wrappers need to be API compatible with previous # versions and with MongoDB::* equivalents. Added 'TO_JSON' for all # wrapper classes to ensure they all serialize. my %apis = ( "BSON::Bool" => { "BSON::Bool" => [ qw/true false value op_eq TO_JSON/ ], }, "BSON::Bytes" => { "BSON::Bytes" => [ qw/TO_JSON/ ], "MongoDB::BSON::Binary" => [ qw/data subtype/ ], }, "BSON::Code" => { "BSON::Code" => [ qw/code scope length TO_JSON/ ], "MongoDB::Code" => [ qw/code scope/ ], }, "BSON::Double" => { "BSON::Double" => [ qw/TO_JSON/ ], }, "BSON::Int32" => { "BSON::Int32" => [ qw/TO_JSON/ ], }, "BSON::Int64" => { "BSON::Int64" => [ qw/TO_JSON/ ], }, "BSON::MaxKey" => { "BSON::MaxKey" => [ qw/TO_JSON/ ], }, "BSON::MinKey" => { "BSON::MinKey" => [ qw/TO_JSON/ ], }, "BSON::OID" => { "BSON::OID" => [ qw/TO_JSON/ ], "MongoDB::OID" => [ qw/value to_string get_time TO_JSON/ ], }, "BSON::Regex" => { "BSON::Regex" => [ qw/TO_JSON/ ], "MongoDB::BSON::Regexp" => [ qw/pattern flags try_compile/ ], }, "BSON::String" => { "BSON::String" => [ qw/value TO_JSON/ ], }, "BSON::Time" => { "BSON::Time" => [ qw/value epoch op_eq TO_JSON/ ], }, "BSON::Timestamp" => { "BSON::Timestamp" => [ qw/seconds increment TO_JSON/ ], "MongoDB::Timestamp" => [ qw/sec inc/ ], }, ); for my $k ( sort keys %apis ) { for my $t ( sort keys %{$apis{$k}} ) { can_ok( $k, @{$apis{$k}{$t}} ); } } done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/legacy/000755 000765 000024 00000000000 13524525151 014467 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/common/000755 000765 000024 00000000000 13524525151 014513 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/raw.t000644 000765 000024 00000001336 13524525151 014204 0ustar00davidstaff000000 000000 use 5.0001; use strict; use warnings; use Test::More 0.96; use Math::BigInt; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use Tie::IxHash; use JSON::MaybeXS; use BSON qw/encode decode/; use BSON::Raw; my ($bson, $expect, $hash); # encode then get first key with unpack $bson = $expect = encode( Tie::IxHash->new( 1234 => 314159, 1235 => 300 ) ); my $object = BSON::Raw->new(bson=>$bson); my $return_key = $object->_get_first_key; is($return_key, "1234"); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/00-report-prereqs.t000644 000765 000024 00000013476 13524525151 016632 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( JSON::PP JSON::XS CPanel::JSON::XS ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do './t/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; my $cpan_meta_error; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( $cpan_meta_error || @dep_errors ) { diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; } if ( $cpan_meta_error ) { my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; } if ( @dep_errors ) { diag join("\n", "\nThe following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: BSON-v1.12.1/t/lib/000755 000765 000024 00000000000 13524525151 013771 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/pvtlib/000755 000765 000024 00000000000 13524525151 014523 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/00-report-prereqs.dd000644 000765 000024 00000010701 13524525151 016742 0ustar00davidstaff000000 000000 do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '6.17', 'perl' => '5.010001' } }, 'develop' => { 'requires' => { 'Dist::Zilla' => '5', 'Dist::Zilla::Plugin::Meta::Contributors' => '0', 'Dist::Zilla::Plugin::ReleaseStatus::FromVersion' => '0', 'Dist::Zilla::Plugin::RemovePrereqs' => '0', 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.072', 'File::Spec' => '0', 'File::Temp' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Pod::Coverage::TrustPod' => '0', 'Pod::Wordlist' => '0', 'Software::License::Apache_2_0' => '0', 'Test::CPAN::Meta' => '0', 'Test::MinimumVersion' => '0', 'Test::More' => '0', 'Test::Perl::Critic' => '0', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Portability::Files' => '0', 'Test::Spelling' => '0.12', 'Test::Version' => '1' } }, 'runtime' => { 'requires' => { 'B' => '0', 'Carp' => '0', 'Crypt::URandom' => '0', 'Exporter' => '0', 'List::Util' => '0', 'MIME::Base64' => '0', 'Math::BigFloat' => '0', 'Math::BigInt' => '0', 'Moo' => '2.002004', 'Scalar::Util' => '0', 'Sys::Hostname' => '0', 'Tie::IxHash' => '0', 'Time::HiRes' => '0', 'Time::Local' => '0', 'base' => '0', 'boolean' => '0.45', 'constant' => '0', 'if' => '0', 'mro' => '0', 'namespace::clean' => '0', 'overload' => '0', 'perl' => '5.010001', 're' => '0', 'strict' => '0', 'threads::shared' => '0', 'version' => '0', 'warnings' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'Data::Dumper' => '0', 'Devel::Peek' => '0', 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'JSON::MaybeXS' => '0', 'JSON::PP' => '2.97001', 'Path::Tiny' => '0.054', 'Test::Deep' => '0', 'Test::Fatal' => '0', 'Test::More' => '0.96', 'lib' => '0', 'perl' => '5.010001', 'utf8' => '0' } } }; $x; }BSON-v1.12.1/t/regression/000755 000765 000024 00000000000 13524525151 015403 5ustar00davidstaff000000 000000 BSON-v1.12.1/t/regression/boolean_copy.t000644 000765 000024 00000001224 13524525151 020240 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; use boolean; my $c = BSON->new; # PERL-575 boolean values were references to each other, so if two were created # identically, then changing one would change the other. my $a = { "okay" => false, "name" => "fred0" }; my $b = { "okay" => false, "name" => "fred1" }; my $a_bin = $c->encode_one( $a ); my $b_bin = $c->encode_one( $b ); my @docs = ( map{ $c->decode_one( $_ ) } ( $a_bin, $b_bin ) ); is( exception { $_->{okay} = $_->{okay}->TO_JSON for @docs }, undef, "replacing one boolean doesn't affect another" ); done_testing; BSON-v1.12.1/t/regression/scalar_ref_value.t000644 000765 000024 00000000644 13524525151 021071 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; use boolean; my $c = BSON->new; # PERL-489 Providing a reference to a scalar was giving the memory reference not # the scalar my $value = 42.2; $value = "hello"; is( exception { $c->encode_one( { value => \$value } ) }, undef, "encoding ref to PVNV is not fatal", ); done_testing; BSON-v1.12.1/t/regression/undef_round_trip.t000644 000765 000024 00000001477 13524525151 021147 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; use Tie::IxHash; my $c = BSON->new; # PERL-543 deflation to BSON then back (via database?) caused undef to be an empty string subtest 'tied Tie::IxHash' => sub { my %h; tie( %h, 'Tie::IxHash', h => undef ); my $bin = $c->encode_one( \%h ); my $doc = $c->decode_one( $bin ); is $doc->{h}, undef, 'round trip undef'; }; subtest 'OO Tie::IxHash' => sub { my $h = Tie::IxHash->new( h => undef ); my $bin = $c->encode_one( $h ); my $doc = $c->decode_one( $bin ); is $doc->{h}, undef, 'round trip undef'; }; subtest 'standard hash' => sub { my %doc = ( h => undef ); my $bin = $c->encode_one( \%doc ); my $doc = $c->decode_one( $bin ); is $doc->{h}, undef, 'round trip undef'; }; done_testing; BSON-v1.12.1/t/pvtlib/CleanEnv.pm000644 000765 000024 00000000556 13524525151 016562 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package CleanEnv; # Tiny equivalent of Devel::Hide to disable BSON::XS use lib map { my ( $m, $c ) = ( $_, qq{die "Can't locate $_ (hidden)\n"} ); sub { return unless $_[1] eq $m; open my $fh, "<", \$c; return $fh } } qw{BSON/XS.pm}; # Keep environment from interfering with tests $ENV{PERL_BSON_BACKEND} = ""; 1; BSON-v1.12.1/t/pvtlib/PPSubclass.pm000644 000765 000024 00000000131 13524525151 017073 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; package PPSubclass; use base qw/BSON::PP/; 1; BSON-v1.12.1/t/lib/TestUtils.pm000644 000765 000024 00000006246 13524525151 016277 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; use Test::More 0.96; # Hijack the JSON::PP::USE_B constant to enable svtype detection BEGIN { no warnings 'redefine'; require constant; my $orig = constant->can('import'); local *constant::import = sub { if ($_[1] eq 'USE_B') { pop(@_); push(@_, 1) } goto &$orig; }; require JSON::PP; die "TOO LATE" unless JSON::PP::USE_B(); } use B; use Carp qw/croak/; use Config; use JSON::PP (); use base 'Exporter'; our @EXPORT = qw/ sv_type packed_is bytes_are to_extjson to_myjson try_or_fail normalize_json INT64 INT32 FLOAT /; use constant { INT64 => 'q<', INT32 => 'l<', FLOAT => 'd<', }; my $json_codec = JSON::PP ->new ->ascii ->allow_bignum ->allow_blessed ->convert_blessed; sub normalize_json { my $decoded = $json_codec->decode(shift); return $json_codec->encode($decoded); } sub to_extjson { my $data = BSON->perl_to_extjson($_[0], { relaxed => $_[1] }); return $json_codec->encode($data); } sub to_myjson { local $ENV{BSON_EXTJSON} = 0; return $json_codec->encode( shift ); } sub sv_type { my $v = shift; my $b_obj = B::svref_2object( \$v ); my $type = ref($b_obj); $type =~ s/^B:://; return $type; } sub packed_is { croak("Not enough args for packed_is()") unless @_ >= 3; my ( $template, $got, $exp, $label ) = @_; $label = '' unless defined $label; local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok; if ( $template eq INT64 && ! $Config{use64bitint} ) { if ( !ref($got) && !ref($exp) ) { # regular scalar will fit in 32 bits, so downgrade the template $template = INT32; } else { # something is a reference, so must be BigInt or equivalent $ok = ok( $got eq $exp, $label ); diag "Got: $got, Expected: $exp" unless $ok; return $ok; } } $ok = ok( pack( $template, $got ) eq pack( $template, $exp ), $label ); diag "Got: $got, Expected: $exp" unless $ok; return $ok; } sub bytes_are { croak("Not enough args for bytes_are()") unless @_ >= 2; my ( $got, $exp, $label ) = @_; $label = '' unless defined $label; local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok = ok( $got eq $exp, $label ); diag "Got:\n", unpack( "H*", $got ), "\nExpected:\n", unpack( "H*", $exp ) unless $ok; return $ok; } sub try_or_fail { my ($code, $label) = @_; eval { $code->() }; if ( my $err = $@ ) { fail($label); diag "Error:\n$err"; return; } return 1; } # Based on Deep::Hash::Utils nest sub create_nest { my ($depth) = @_; my $orig = my $hr = {}; my @numbers = ( 1 .. $depth ); while (my $key = shift @numbers) { $hr->{$key} = @numbers ? {} : undef; $hr = $hr->{$key}; } return $orig; } 1; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/lib/CorpusTest.pm000644 000765 000024 00000027462 13524525151 016455 0ustar00davidstaff000000 000000 use 5.010001; use strict; use warnings; use Test::More 0.96; use Test::Deep qw/!blessed/; # Hijack the JSON::PP::USE_B constant to enable svtype detection BEGIN { no warnings 'redefine'; require constant; my $orig = constant->can('import'); local *constant::import = sub { if ($_[1] eq 'USE_B') { pop(@_); push(@_, 1) } goto &$orig; }; require JSON::PP; die "TOO LATE" unless JSON::PP::USE_B(); } use JSON::PP 2.97001; use BSON; use BSON::Types ':all'; use Config; use Path::Tiny 0.054; # better basename use Data::Dumper; # from t/lib use TestUtils; use constant { IS_JSON_PP => 1, }; use base 'Exporter'; our @EXPORT = qw/test_corpus_file/; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; # overridden to allow Tie::IxHash hashes to be created by JSON::PP my $orig = JSON::PP->can("object") or die "Unable to find JSON::PP::object to override"; do { no warnings 'redefine'; *JSON::PP::object = sub { tie my %hash, 'Tie::IxHash'; my $value = $orig->(\%hash); return $value; }; }; my $JSON = JSON::PP ->new ->ascii ->allow_bignum ->allow_blessed ->convert_blessed; sub test_corpus_file { my ($file) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my $f = path( "corpus", $file ); my $base = $f->basename; my $json = eval { decode_json( $f->slurp ) }; if ( my $err = $@ ) { fail("$base failed to load"); diag($err); return; } subtest 'JSON::PP Tie::IxHash injection' => sub { my $data = $JSON->decode('{"x":23}'); ok defined(tied %$data), 'JSON::PP returns tied objects'; }; _validity_tests($json); _decode_error_tests($json); _parse_error_tests($json); } sub _validity_tests { my ($json) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; # suppress caching that throws off Test::Deep local $BSON::Types::NoCache = 1; my $bson_type = $json->{bson_type}; my $deprecated = $json->{deprecated}; for my $case ( @{ $json->{valid} } ) { subtest 'case: '.$case->{description} => sub { local $Data::Dumper::Useqq = 1; my $wrap = $bson_type =~ /\A(?:0x00|0x01|0x10|0x12)\z/; my $codec = BSON->new( prefer_numeric => 1, wrap_numbers => $wrap, ordered => 1 ); my $lossy = $case->{lossy}; my $canonical_bson = $case->{canonical_bson}; my $converted_bson = $case->{converted_bson}; my $degenerate_bson = $case->{degenerate_bson}; $canonical_bson = pack('H*', $canonical_bson); $converted_bson = pack('H*', $converted_bson) if defined $converted_bson; $degenerate_bson = pack('H*', $degenerate_bson) if defined $degenerate_bson; my $canonical_json = $case->{canonical_extjson}; my $converted_json = $case->{converted_extjson}; my $degenerate_json = $case->{degenerate_extjson}; my $relaxed_json = $case->{relaxed_extjson}; $canonical_json = _normalize( $canonical_json, '$desc: normalizing canonical extjson', ); $converted_json = _normalize( $converted_json, '$desc: normalizing converted extjson', ); $degenerate_json = _normalize( $degenerate_json, '$desc: normalizing degenerate extjson', ); $relaxed_json = _normalize( $relaxed_json, '$desc: normalizing relaxed extjson', ); ## ## for cB input (canonical BSON) ## bytes_are( _native_to_bson($codec, _bson_to_native($codec, $canonical_bson), ), $deprecated ? $converted_bson : $canonical_bson, 'native_to_bson(bson_to_native(cB)) = cB', ); is( _normalize_numbers( _native_to_canonical_extended_json($codec, _bson_to_native($codec, $canonical_bson), ) ), _normalize_numbers( $deprecated ? $converted_json : $canonical_json, ), 'native_to_canonical_extended_json(bson_to_native(cB)) = cEJ', ); is( _normalize_numbers( _native_to_relaxed_extended_json($codec, _bson_to_native($codec, $canonical_bson), ) ), _normalize_numbers($relaxed_json), 'native_to_relaxed_extended_json(bson_to_native(cB)) = rEJ', ) unless not defined $relaxed_json; ## ## for cEJ input (canonical Extended JSON) ## is( _normalize_numbers( _native_to_canonical_extended_json($codec, _extjson_to_native($codec, $canonical_json), ) ), _normalize_numbers( $deprecated ? $converted_json : $canonical_json, ), 'native_to_canonical_extended_json(json_to_native(cEJ)) = cEJ', ); bytes_are( _native_to_bson($codec, _extjson_to_native($codec, $canonical_json), ), $deprecated ? $converted_bson : $canonical_bson, 'native_to_bson(json_to_native(cEJ)) = cB' ) unless $lossy; ## ## for dB input (degenerate BSON) ## if (defined $degenerate_bson) { bytes_are( _native_to_bson($codec, _bson_to_native($codec, $degenerate_bson), ), $canonical_bson, 'native_to_bson(bson_to_native(dB)) = cB', ) } ## ## for dEJ input (degenerate Extended JSON) ## if (defined $degenerate_json) { is( _normalize_numbers( _native_to_canonical_extended_json($codec, _extjson_to_native($codec, $degenerate_json), ) ), _normalize_numbers( $deprecated ? $converted_json : $canonical_json, ), 'native_to_canonical_extended_json(json_to_native(dEJ)) = cEJ', ); bytes_are( _native_to_bson($codec, _extjson_to_native($codec, $degenerate_json), ), $deprecated ? $converted_bson : $canonical_bson, 'native_to_bson(json_to_native(dEJ)) = cB' ) unless $lossy; } ## ## for rEJ input (relaxed Extended JSON) ## if (defined $relaxed_json) { is( _normalize_numbers( _native_to_relaxed_extended_json($codec, _extjson_to_native($codec, $relaxed_json), ) ), _normalize_numbers($relaxed_json), 'native_to_relaxed_extended_json(json_to_native(rEJ)) = rEJ', ); } }; } return; } sub _normalize { my ($json, $desc) = @_; return unless defined $json; try_or_fail( sub { $json = to_myjson( $JSON->decode( $json ) ); }, $desc ) or next; return $json; } sub _normalize_numbers { my ($value) = @_; return undef unless defined $value; $value =~ s{"0.0"}{"0"}g; $value =~ s{"-0.0"}{"0"}g; $value =~ s{"-0"}{"0"}g; $value =~ s{"1.0"}{"1"}g; $value =~ s{"-1.0"}{"-1"}g; $value =~ s[{"d":-0.0}][{"d":0}]g; $value =~ s[{"d":-0}][{"d":0}]g; $value =~ s[{"d":0.0}][{"d":0}]g; $value =~ s[(-?)1\.2345\d+(?:[eE]\+\d+)?][${1}1234567890...]g; $value =~ s[-1234567890123456768][-1234567890...]g; $value =~ s[1234567890123456768][1234567890...]g; # Power8 specific normalization $value =~ s[-1234567890123456770][-1234567890...]g; $value =~ s[1234567890123456770][1234567890...]g; return $value; } sub _native_to_bson { my ($codec, $native) = @_; my $bson; try_or_fail( sub { $bson = $codec->encode_one($native) }, q{Couldn't convert from native Perl to BSON}, ) or return undef; return $bson; } sub _bson_to_native { my ($codec, $bson) = @_; my $native; try_or_fail( sub { $native = $codec->decode_one($bson) }, q{Couldn't convert from BSON to native Perl}, ) or return undef; return $native; } sub _extjson_to_native { my ($codec, $extjson) = @_; my $native_extjson; try_or_fail( sub { $native_extjson = $JSON->decode($extjson) }, q{Couldn't decode JSON to native ExtJSON}, ) or return undef; my $native; try_or_fail( sub { $native = $codec->extjson_to_perl($native_extjson) }, q{Couldn't convert from native ExtJSON to native Perl}, ) or return undef; return $native; } sub _native_to_relaxed_extended_json { my ($codec, $native) = @_; my $native_extjson; try_or_fail( sub { $native_extjson = $codec->perl_to_extjson($native, {relaxed => 1}) }, q{Couldn't convert from native Perl to native relaxed ExtJSON}, ) or return undef; my $extjson; try_or_fail( sub { $extjson = $JSON->encode($native_extjson) }, q{Couldn't encode native ExtJSON as JSON}, ) or return undef; return $extjson; } sub _native_to_canonical_extended_json { my ($codec, $native) = @_; my $native_extjson; try_or_fail( sub { $native_extjson = $codec->perl_to_extjson($native, {relaxed => 0}) }, q{Couldn't convert from native Perl to native canonical ExtJSON}, ) or return undef; my $extjson; try_or_fail( sub { $extjson = $JSON->encode($native_extjson) }, q{Couldn't encode native ExtJSON as JSON}, ) or return undef; return $extjson; } sub _decode_error_tests { my ($json) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; return unless $json->{decodeErrors}; for my $case ( @{ $json->{decodeErrors} } ) { my $desc = $case->{description}; my $bson = pack( "H*", $case->{bson} ); eval { BSON::decode($bson) }; ok( length($@), "Decode error: $desc:" ); } } my %PARSER = ( '0x00' => sub { bson_doc(shift) }, '0x13' => sub { bson_decimal128(shift) }, ); sub _parse_error_tests { my ($json) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my $parser = $PARSER{$json->{bson_type}}; if ( $json->{parseErrors} && !$parser ) { BAIL_OUT("No parseError parser available for $json->{bson_type}"); } for my $case ( @{ $json->{parseErrors} } ) { eval { $parser->($case->{string}) }; ok( $@, "$case->{description}: parse should throw an error " ) or diag "Input was: $case->{string}"; } } 1; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/lib/TestTie.pm000644 000765 000024 00000000462 13524525151 015712 0ustar00davidstaff000000 000000 package # hide from PAUSE TestTie::Scalar; @ISA = qw(Tie::Scalar); sub TIESCALAR { my $class = shift; my $instance = @_ ? shift : undef; return bless \$instance => $class; } sub FETCH { return ${$_[0]}; } sub STORE { ${$_[0]} = $_[1]; } sub DESTROY { undef ${$_[0]}; } 1; BSON-v1.12.1/t/common/bson_array.t000644 000765 000024 00000001737 13524525151 017047 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use Test::Deep; use BSON; use BSON::Types ':all'; my $c = BSON->new; my $pipeline = [ { '$replaceRoot' => { 'newRoot' => '$t' } }, { '$addFields' => { 'foo' => 1 } } ]; my $b_array = bson_array(@$pipeline); ok(ref $b_array eq 'BSON::Array', 'bson_array'); is_deeply( $c->decode_one( $c->encode_one({ u => $b_array }) ), $c->decode_one( $c->encode_one({ u => $pipeline }) ), 'encode bson array' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/tied.t000644 000765 000024 00000001161 13524525151 015624 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestTie; use BSON; # PERL-737 encoding of simple tied var ok(my $c = BSON->new, 'got codec object'); my ($number, $str) = (5, 'hello'); my $var; tie $var, 'TestTie::Scalar'; $var = $number; my $varnum_bin = $c->encode_one({ mytied => $var }); ok( $c->decode_one($varnum_bin)->{'mytied'} == $number, 'round trip for tie var' ); $var = $str; my $varstr_bin = $c->encode_one({ mytied => $var }); is( $c->decode_one($varstr_bin)->{'mytied'}, $str, 'round trip for tie var' ); done_testing; BSON-v1.12.1/t/common/cycle.t000644 000765 000024 00000002321 13524525151 015775 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON; use BSON::Types ':all'; my $c = BSON->new; my $q = {}; $q->{'q'} = $q; eval { $c->encode_one($q); }; like( $@, qr/circular ref/, "circular hashref" ); my %test; tie %test, 'Tie::IxHash'; $test{t} = \%test; eval { $c->encode_one( \%test ); }; like( $@, qr/circular ref/, "circular tied hashref" ); my $tie = Tie::IxHash->new; $tie->Push( "t" => $tie ); eval { $c->encode_one($tie); }; like( $@, qr/circular ref/, "circular Tie::IxHash object" ); # Multiple deep cycles my $inner1 = { Z1 => { X => 1 } }; my $inner2 = { Z2 => { Y => 2 } }; $inner1->{inner2} = $inner2; $inner2->{inner1} = $inner1; my $outer = { A => $inner1, B => $inner2 }; eval { $c->encode_one($outer); }; like( $@, qr/circular ref/, "circular deep object" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/number_heuristics.t000644 000765 000024 00000004777 13524525151 020451 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use B; use BSON; use BSON::Types ':all'; use Devel::Peek; use Scalar::Util qw/dualvar/; my $pn0 = BSON->new( prefer_numeric => 0 ); my $pn1 = BSON->new( prefer_numeric => 1 ); my $dec = BSON->new( wrap_numbers => 1, wrap_strings => 1 ); sub _flags { my $value = shift; return B::svref_2object( \$value )->FLAGS; } sub w_iv { _flags(shift) & B::SVf_IOK } sub wo_iv { _flags(shift) & ~B::SVf_IOK } sub w_nv { _flags(shift) & B::SVf_NOK } sub wo_nv { _flags(shift) & ~B::SVf_NOK } sub w_pv { _flags(shift) & B::SVf_POK } sub w_pviv { w_pv( $_[0] ) && w_iv( $_[0] ) } sub w_pvnv { w_pv( $_[0] ) && w_nv( $_[0] ) } sub w_pvonly { w_pv( $_[0] ) && !( w_iv( $_[0] ) || w_nv( $_[0] ) ) } sub _dump { my $x = shift; my $dump; open my $fh, ">", \$dump; local *STDERR = $fh; Dump($x); return $dump; } sub _rt { my ( $encoder, $x ) = @_; return $dec->decode_one( $encoder->encode_one($x) ); } # LABEL, INPUT, FLAGS, OUTPUT W/O PREFER_NUMERIC, OUTPUT W/ PREFER_NUMERIC # # Uses 'dualvar()' to construct duals because other forms of NV->PVNV # conversion don't consistently set POK on all Perl versions. my @cases = ( [ 'Pure int', 42, \&w_iv, 'BSON::Int32', 'BSON::Int32' ], [ 'String int', "42", \&w_pvonly, 'BSON::String', 'BSON::Int32' ], [ 'Dual int', dualvar( 42, "42" ), \&w_pviv, 'BSON::Int32', 'BSON::Int32' ], [ 'Pure double', 3.14, \&w_nv, 'BSON::Double', 'BSON::Double' ], [ 'String double', "3.14", \&w_pvonly, 'BSON::String', 'BSON::Double' ], [ 'Dual double', dualvar( 3.14, "3.14" ), \&w_pvnv, 'BSON::Double', 'BSON::Double' ], ); for my $c (@cases) { my ( $label, $x, $type_chk, $y0, $y1 ) = @$c; ok( $type_chk->($x), "$label: SvTYPE(s)" ) or diag _dump($x); my $doc = { x => $x }; for my $enc ( [ "prefer_numeric=0", $pn0, $y0 ], [ "prefer_numeric=1", $pn1, $y1 ] ) { my $rt_x = _rt( $enc->[1], $doc )->{x}; is( ref($rt_x), $enc->[2], "$label: $enc->[0]" ); like( $rt_x->value, qr/\Q$x\E/, "$label: value matches $x" ); } } done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/errors.t000644 000765 000024 00000006610 13524525151 016217 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; { my $obj = bless {}, "Some::Random::Class"; eval { encode( { a => $obj } ) }; like( $@, qr/For key 'a', can't encode value of type 'Some::Random::Class'/, "encoding unknown type is fatal" ); } { my $bson = encode( { a => 1.1 } ); # swap the type byte to an unknown one substr($bson,4,1,"\xEE"); eval { decode($bson) }; like( $@, qr/unsupported BSON type \\xEE for key 'a'\. Are you using the latest version/, "decoding unknown type is fatal" ); } { no warnings 'once'; my $glob = *foo; eval { encode( \$glob ) }; like( $@, qr/Can't encode non-container of type 'GLOB'/, "encoding non-container is fatal" ); } { my $with_null= "Hello\0World"; eval { encode( { $with_null => 123 } ) }; like( $@, qr/Key 'Hello\\x00World' contains null character/, "encoding embedded null is fatal" ); } { eval { encode( "Hello world" ) }; like( $@, qr/Can't encode scalars/, "encoding scalar is fatal" ); } { eval { encode( qr/abc/ ) }; like( $@, qr/Can't encode non-container of type '.*'/, "encoding non-container is fatal" ); } { my $str = "123"; my $obj = bless \$str, "Some::Object"; eval { encode( $obj ) }; like( $@, qr/Can't encode non-container of type 'Some::Object'/, "encoding hash-type object is fatal" ); } subtest nesting => sub { my $err; eval { encode( create_nest(100) ) }; $err = $@; is( $err, '', "No error encoding 100 levels of hash" ); eval { encode( create_nest(101) ) }; $err = $@; like( $err, qr/Exceeded max object depth of 100/, "Hit the specified max depth encoding documents at 101 levels of hash" ) or diag($err); eval { encode( { 0 => [ map { create_nest(98) } 1 .. 5 ] } ) }; $err = $@; is( $err, '', "No error at 100 levels of hash+array+hash" ); eval { encode( { 0 => [ map { create_nest(99) } 1 .. 5 ] } ) }; $err = $@; like( $err, qr/Exceeded max object depth of 100/, "Hit the specified max depth encoding documents at 101 levels of hash+array+hash" ) or diag($err); # synthesize 10 and 101 levels of BSON my $bson_100 = encode( create_nest(100) ); my $bson_101 = pack("l [ map { BSON::Raw->new(bson => encode({ b => 1 }, $opt)) } 1 .. 100 ] }, $opt ); }; $err = $@; is( $err, '', "No error encoding 100 Raw docs with same options" ); }; done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/options.t000644 000765 000024 00000013537 13524525151 016404 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON; use BSON::Types ':all'; sub _BSON { BSON->new(@_) } subtest "error_callback" => sub { my $bad = "\x05\x00\x00\x00\x01"; my @errs; my $obj = _BSON( error_callback => sub { push @errs, [@_] } ); $obj->decode_one($bad); is( 0+ @errs, 1, "error_callback ran" ); # 'error reading' is from BSON::XS like( $errs[0][0], qr/error reading|not null terminated/i, "error_callback arg 0" ); is( ${ $errs[0][1] }, $bad, "error_callback arg 1" ); is( $errs[0][2], 'decode_one', "error_callback arg 2" ); }; subtest "invalid_char" => sub { my $obj = _BSON( invalid_chars => '.' ); eval { $obj->encode_one( { "example.com" => 1 } ) }; like( $@, qr/key 'example\.com' has invalid character\(s\) '\.'/, "invalid char throws exception" ); $obj = _BSON( invalid_chars => '.$' ); eval { $obj->encode_one( { "example.c\$om" => 1 } ) }; like( $@, qr/key 'example\.c\$om' has invalid character\(s\) '\.\$'/, "multi-invalid chars throws exception" ); }; subtest "max_length" => sub { my $obj = _BSON( max_length => 20 ); my $hash = { "example.com" => "a" x 100 }; my $encoded = _BSON->encode_one($hash); eval { $obj->encode_one($hash) }; like( $@, qr/encode_one.*Document exceeds maximum size 20/, "max_length exceeded during encode_one" ); eval { $obj->decode_one($encoded) }; like( $@, qr/decode_one.*Document exceeds maximum size 20/, "max_length exceeded during decode_one" ); }; subtest "op-char" => sub { my $obj = _BSON( op_char => '-' ); my $hash = { -inc => { x => 1 } }; my $expect = { '$inc' => { x => 1 } }; my $got = $obj->decode_one( $obj->encode_one($hash) ); is_deeply( $got, $expect, "op-char converts to '\$'" ) or diag explain $got; }; subtest "prefer_numeric" => sub { my $hash = { x => "42" }; my $pn0 = _BSON( prefer_numeric => 0 ); my $pn1 = _BSON( prefer_numeric => 1 ); my $dec = _BSON( wrap_numbers => 1, wrap_strings => 1 ); is( ref( $dec->decode_one( $pn1->encode_one($hash) )->{x} ), 'BSON::Int32', 'prefer_numeric => 1' ); is( ref( $dec->decode_one( $pn0->encode_one($hash) )->{x} ), 'BSON::String', 'prefer_numeric => 0' ); }; subtest "first_key" => sub { my @doc = ( x => 42, y => 23, z => { a => 1, b => 2 } ); my $obj = _BSON( ordered => 1 ); my $got = $obj->decode_one( $obj->encode_one( bson_doc(@doc), { first_key => 'y', first_value => 32 } ) ); my ( $k, $v ) = each %$got; is( $k, 'y', "first_key put first" ); is( $v, 32, "first_value overrode existing value" ); ok( !exists $got->{z}{_id}, "first_key doesn't propagate" ); # empty doc with first_key $got = $obj->decode_one( $obj->encode_one( bson_doc(), { first_key => 'y', first_value => 32 } ) ); ( $k, $v ) = each %$got; is( $k, 'y', "first_key put first" ); is( $v, 32, "first_value overrode existing value" ); }; subtest "dt_type" => sub { my $now = time; # undef { my $obj = _BSON( dt_type => undef ); my $bson = $obj->encode_one( { A => bson_time() } ); my $hash = $obj->decode_one($bson); is( ref( $hash->{A} ), 'BSON::Time', "dt_type = undef" ); } # BSON::Time { my $obj = _BSON( dt_type => "BSON::Time" ); my $bson = $obj->encode_one( { A => bson_time() } ); my $hash = $obj->decode_one($bson); is( ref( $hash->{A} ), 'BSON::Time', "dt_type = BSON::Time" ); } # DateTime SKIP: { eval { require DateTime }; skip( "DateTime not installed", 1 ) unless $INC{'DateTime.pm'}; my $obj = _BSON( dt_type => "DateTime" ); my $bson = $obj->encode_one( { A => bson_time() } ); my $hash = $obj->decode_one($bson); is( ref( $hash->{A} ), 'DateTime', "dt_type = DateTime" ); } # DateTime::Tiny SKIP: { eval { require DateTime::Tiny }; skip( "DateTime::Tiny not installed", 1 ) unless $INC{'DateTime/Tiny.pm'}; my $obj = _BSON( dt_type => "DateTime::Tiny" ); my $bson = $obj->encode_one( { A => bson_time() } ); my $hash = $obj->decode_one($bson); is( ref( $hash->{A} ), 'DateTime::Tiny', "dt_type = DateTime::Tiny" ); } # Time::Moment SKIP: { eval { require Time::Moment }; skip( "Time::Moment not installed", 1 ) unless $INC{'Time/Moment.pm'}; my $obj = _BSON( dt_type => "Time::Moment" ); my $bson = $obj->encode_one( { A => bson_time() } ); my $hash = $obj->decode_one($bson); is( ref( $hash->{A} ), 'Time::Moment', "dt_type = Time::Moment" ); } # Mango::BSON::Time SKIP: { eval { require Mango::BSON::Time }; skip( "Mango::BSON::Time not installed", 1 ) unless $INC{'Mango/BSON/Time.pm'}; my $obj = _BSON( dt_type => "Mango::BSON::Time" ); my $bson = $obj->encode_one( { A => bson_time() } ); my $hash = $obj->decode_one($bson); is( ref( $hash->{A} ), 'Mango::BSON::Time', "dt_type = Mango::BSON::Time" ); } # unknown { my $obj = _BSON( dt_type => 'BOGUS' ); my $bson = $obj->encode_one( { A => bson_time() } ); eval { $obj->decode_one($bson) }; like( $@, qr/unsupported dt_type/i, "dt_type = BOGUS" ); } }; done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/top-array.t000644 000765 000024 00000001270 13524525151 016616 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON; use BSON::Types ':all'; my $c = BSON->new; my $from_array = $c->encode_one( [ a => 23 ] ); my $from_hash = $c->encode_one( { a => 23 } ); bytes_are( $from_array, $from_hash, "encode_one( [...] )" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/create_oid.t000644 000765 000024 00000002425 13524525151 017001 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; use BSON::OID; subtest 'test timestamp field' => sub { my %test_ts_data = ( 2147483648 => "\x80" . ("\x00" x 11), 4294967295 => ("\xFF" x 4) . ("\x00" x 8) ); while ( my ($time, $test_oid) = each %test_ts_data) { my $oid = BSON::OID->new(oid => $test_oid); ok( $time == $oid->get_time ); } }; sub check_counter { my ($oid, $counter) = @_; my $inc = unpack( 'a3', substr( $oid->{'oid'}, 9, 3 ) ); is($inc, substr( pack('N', $counter), 1, 3 ), 'check the oid has the given counter' ); } subtest 'test counter' => sub { ok(my $oid = BSON->create_oid); isa_ok($oid, 'BSON::OID'); ok($oid->__reset_counter); # Set internal counter to 0XFFFFFE check_counter( BSON->create_oid, 0xFFFFFF ); check_counter( BSON->create_oid, 0x000000 ); }; done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/common/dualvar.t000644 000765 000024 00000001161 13524525151 016335 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util 'dualvar'; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; # PERL-737 encoding of dual vars # should look have an NV representation and be encoded as numbers ok(my $c = BSON->new, 'got codec object'); my ($number, $str) = (5, 'hello'); my $dualvar = dualvar($number, $str); ok($dualvar == $number, 'dual var is a number'); is($dualvar, $str, 'dual var is a string'); my $dualvar_bin = $c->encode_one({ dual => $dualvar }); ok( $c->decode_one($dualvar_bin)->{'dual'} == $number, 'round trip for dual var' ); done_testing; BSON-v1.12.1/t/legacy/02-oid.t000644 000765 000024 00000003251 13524525151 015647 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use constant COVERTEST => ( $ENV{HARNESS_PERL_SWITCHES} || "" ) =~ /Devel::Cover/; BEGIN { use Config; use if !COVERTEST && $Config{useithreads}, 'threads'; use if !COVERTEST && $Config{useithreads}, 'threads::shared'; } use Config; use Test::More tests => 45; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $o1 = BSON::ObjectId->new(); ok( $o1->is_legal($o1), 'oid generate' ); my $o2 = BSON::ObjectId->new( "$o1" ); is( $o1, $o2, 'oid from string' ); my $o3 = BSON::ObjectId->new('4e2766e6e1b8325d02000028'); is_deeply( [ unpack( 'C*', $o3->value ) ], [ 0x4e, 0x27, 0x66, 0xe6, 0xe1, 0xb8, 0x32, 0x5d, 0x02, 0x00, 0x00, 0x28 ], 'oid value' ); my $o4 = BSON::ObjectId->new( $o3->value ); is( "$o4", "$o3", 'value' ); my $try = eval { my $o5 = BSON::ObjectId->new('abcde'); 1 }; isnt( $try, 1, 'Dies 1' ); $try = eval { my $o5 = BSON::ObjectId->new('12345678901234567890123$'); 1 }; isnt( $try, 1, 'Dies 2' ); SKIP: { skip "No threads during coverage testing", 39 if COVERTEST; skip "No threads", 39 unless $Config{useithreads}; skip "Threads not supported before 5.8.5", 39 if $] lt "5.008005"; my @threads = map { threads->create( sub { [ map { BSON::ObjectId->new } 0 .. 3 ]; } ); } 0 .. 9; my @oids = map { @{ $_->join } } @threads; my @inc = sort { $a <=> $b } map { hex } map { substr $_, 18 } @oids; # just counters my $prev = shift @inc; while (@inc) { my $next = shift @inc; ok( $next - $prev == 1, "thread counter sequential ($next)" ); $prev = $next; } }; BSON-v1.12.1/t/legacy/01-bool.t000644 000765 000024 00000000455 13524525151 016031 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 5; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; ok(BSON::Bool->new(1)); ok(!BSON::Bool->new(0)); ok(BSON::Bool->true); ok(!BSON::Bool->false); my $t = BSON::Bool->true; my $f = BSON::Bool->false; ok( $t && !$f ); BSON-v1.12.1/t/legacy/12-exception.t000644 000765 000024 00000000604 13524525151 017072 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; if ( eval("use Test::Exception; 1") ) { plan tests => 2; } else { plan skip_all => 'No Test::Exception installed' } use BSON qw/encode decode/; dies_ok( sub{ decode("something") }, "Incorrect BSON"); dies_ok( sub{ decode("\5\0\0\0 1234\0") }, "Unsupported type" ) BSON-v1.12.1/t/legacy/08-string.t000644 000765 000024 00000000703 13524525151 016407 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 103; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $am = "We're all living in America!"; my $s = BSON::String->new($am); isa_ok( $s, 'BSON::String' ); is($s->value, $am, 'Value'); is("$s", $am, 'Overload'); for (1 .. 50) { my $i = int(rand(1_000_000)); my $s = BSON::String->new($i); isa_ok( $s, 'BSON::String' ); is("$s", "$i", "Number $i"); } BSON-v1.12.1/t/legacy/04-binary.t000644 000765 000024 00000001100 13524525151 016351 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 8; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $bin = BSON::Binary->new( [ 1, 2, 3, 4, 5 ] ); isa_ok( $bin, 'BSON::Binary' ); is_deeply( $bin->data, [ 1, 2, 3, 4, 5 ] ); is( $bin->type, 0 ); is_deeply( [ unpack 'C*', $bin->to_s ], [ 5, 0, 0, 0, 0, 1, 2, 3, 4, 5 ] ); $bin = BSON::Binary->new( "\1\2\3\4\5", 5 ); isa_ok( $bin, 'BSON::Binary' ); is_deeply( $bin->data, [ 1, 2, 3, 4, 5 ] ); is( $bin->type, 5 ); is_deeply( [ unpack 'C*', $bin->to_s ], [ 5, 0, 0, 0, 5, 1, 2, 3, 4, 5 ] ); BSON-v1.12.1/t/legacy/05-code.t000644 000765 000024 00000000740 13524525151 016011 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 5; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $js = q[ function a(b,c) { if (b) { alert(c) } } ]; my $scope = { a => 6, b => 'foo' }; my $code = BSON::Code->new( $js ); isa_ok( $code, 'BSON::Code' ); is($code->code, $js); $code = BSON::Code->new( $js, $scope ); isa_ok( $code, 'BSON::Code' ); is($code->code, $js); is_deeply( $code->scope, $scope ); BSON-v1.12.1/t/legacy/03-time.t000644 000765 000024 00000000732 13524525151 016034 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 7; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $n = time; my $t = BSON::Time->new($n); isa_ok( $t, 'BSON::Time' ); is( $t->value, $n * 1000 ); sleep 1; my $t2 = BSON::Time->new; isa_ok( $t2, 'BSON::Time' ); ok( $t2->value ); isnt( $t2->value, $t->value ); my $t3 = BSON::Time->new($n); is( $t3, $t ); my $try = eval { $t = BSON::Time->new('abcde'); 1 }; isnt($try, 1, 'Dies ok'); BSON-v1.12.1/t/legacy/06-timestamp.t000644 000765 000024 00000000421 13524525151 017077 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $ts = BSON::Timestamp->new(0x1234, 0x5678); isa_ok( $ts, 'BSON::Timestamp' ); is( $ts->seconds, 0x1234 ); is( $ts->increment, 0x5678 ); BSON-v1.12.1/t/legacy/07-minmaxkey.t000644 000765 000024 00000000365 13524525151 017106 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use BSON; my $k = BSON::MinKey->new; isa_ok( $k, 'BSON::MinKey' ); $k = BSON::MaxKey->new; isa_ok( $k, 'BSON::MaxKey' ); BSON-v1.12.1/t/legacy/11-random.t000644 000765 000024 00000004440 13524525151 016355 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; my $RUNS = $ENV{AUTOMATED_TESTING} || $ENV{AUTHOR_TESTING} ? 500 : 50; # Number of random documents to create my $DEEP = 2; # Max depth level of embedded hashes my $KEYS = 20; # Number of keys per hash use Config; use Test::More 0.86; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; plan tests => $RUNS; use BSON qw/encode decode/; srand; my $level = 0; my @codex = ( \&int32, \&doub, \&str, \&hash, \&arr, \&dt, \&bin, \&re, \&oid, \&min, \&max, \&ts, \&null, \&bool, \&code ); # If Perl is 64-bit then add 64 integers if ( $Config{'use64bitint'} ) { push @codex, \&int64; } for my $count ( 1 .. $RUNS ) { my $ar = hash($KEYS); my $bson = eval { encode($ar) }; if ( my $err = $@ ) { chomp $err; fail("Encoding error: $err"); } else { my $ar1 = decode($bson); is_deeply( $ar, $ar1 ) or diag explain $ar1; } } sub int32 { return int( rand( 2**31-1 ) ) * ( int( rand(2) ) ? -1 : 1 ); } sub int64 { return int( rand( 2**63-1 ) ) * ( int( rand(2) ) ? -1 : 1 ); } sub doub { return rand() * 2**63-1 * ( int( rand(2) ) ? -1 : 1 ); } sub str { my $len = int( rand(255) ) + 1; my @a = map { ( 'A' .. 'Z', 'a' .. 'z', ' ', '0' .. '9' )[ rand( 26 + 26 + 11 ) ] } 1 .. $len; return BSON::String->new( join( '', @a ) ); } sub dt { BSON::Time->new( abs( int32() ) ) } sub bin { BSON::Bytes->new( str(), int( rand(5) ) ) } sub re { BSON::Regex->new( pattern => '\w\a+\s$', flags => 'i') } sub oid { BSON::ObjectId->new } sub min { BSON::MinKey->new } sub max { BSON::MaxKey->new } sub ts { BSON::Timestamp->new( abs( int32() ), abs( int32() ) ) } sub null { undef } sub bool { BSON::Bool->new( int( rand(2) ) ) } sub code { BSON::Code->new( str(), hash() ) } sub rnd { my $sub = $codex[ int( rand(@codex) ) ]; return $sub->($level); } sub arr { return [] if $level > $DEEP; $level++; my $len = int( rand(20) ) + 1; my @a = (); for ( 1 .. $len ) { push @a, rnd( $level + 1 ); } $level--; return \@a; } sub hash { return {} if $level > $DEEP; $level++; my $hash = {}; for my $idx ( 1 .. $KEYS ) { $hash->{"key_$idx"} = rnd( $level + 1 ); } $level--; return $hash; } BSON-v1.12.1/t/legacy/10-bson.t000644 000765 000024 00000041063 13524525151 016037 0ustar00davidstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 17; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use Test::Deep; use Tie::IxHash; use Math::BigInt; require re; use BSON qw/encode decode/; my $a; tie( my %h, 'Tie::IxHash' ); tie( my %h1, 'Tie::IxHash' ); tie( my %h2, 'Tie::IxHash' ); sub _dump_bson { my $bson = unpack("H*",shift); $bson =~ s/(..)/$1 /g; return $bson; } sub _delta_ok { my ($lhs, $rhs, $label) = @_;; local $Test::Builder::Level = $Test::Builder::Level + 1; ok( abs($lhs - $rhs) < 1e-6, $label ); } # Int32 subtest int32 => sub { plan tests => 2; %h = ( a => 1, b => 2147483647, c => -2147483648 ); my $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 26, 0, 0, 0, 16, 97, 0, 1, 0, 0, 0, 16, 98, 0, 255, 255, 255, 127, 16, 99, 0, 0, 0, 0, 128, 0 ], 'Int32 encode' ); is_deeply( decode($bson), \%h, 'Int32 decode' ); }; # Int64 subtest int64 => sub { %h = ( a => Math::BigInt->new('2147483648'), b => Math::BigInt->new('9223372036854775807'), c => Math::BigInt->new('-9223372036854775808') ); my $bson = encode( \%h ); cmp_deeply( [ unpack "C*", $bson ], [ 38, 0, 0, 0, 18, 97, 0, 0, 0, 0, 128, 0, 0, 0, 0, 18, 98, 0, 255, 255, 255, 255, 255, 255, 255, 127, 18, 99, 0, 0, 0, 0, 0, 0, 0, 0, 128, 0 ], 'Int64 encode' ); # is_deeply fails to compare int64 properly my $decoded = decode($bson); for my $k ( qw/a b c/ ) { is( $decoded->{$k}, $h{$k}, "key $k" ); } }; # Mixed ints subtest mix_ints => sub { %h = ( a => Math::BigInt->new('2147483648'), b => 1, c => -20 ); my $bson = encode( \%h ); # is_deeply fails to compare int64 properly cmp_deeply( [ unpack "C*", $bson ], [ 30, 0, 0, 0, 18, 97, 0, 0, 0, 0, 128, 0, 0, 0, 0, 16, 98, 0, 1, 0, 0, 0, 16, 99, 0, 236, 255, 255, 255, 0 ], 'Mixints encode' ); # is_deeply fails to compare int64 properly my $decoded = decode($bson); for my $k ( qw/a b c/ ) { is( $decoded->{$k}, $h{$k}, "key $k" ); } }; subtest boolean => sub { plan tests => 6; # Boolean true %h = ( a => BSON::Bool->true ); my $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 9, 0, 0, 0, 8, 97, 0, 1, 0 ], 'True encode' ); is_deeply( decode($bson), \%h, 'True decode' ); # Boolean false %h = ( a => BSON::Bool->false ); $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 9, 0, 0, 0, 8, 97, 0, 0, 0 ], 'False encode' ); is_deeply( decode($bson), \%h, 'False decode' ); # Boolean mixed %h = ( a => BSON::Bool->true, b => BSON::Bool->false ); $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 13, 0, 0, 0, 8, 97, 0, 1, 8, 98, 0, 0, 0 ], 'mixed encode' ); is_deeply( decode($bson), \%h, 'Mixed decode' ); }; # Double subtest double => sub { plan tests => 4; %h = ( a => 0.12345, b => -0.1234, c => 123456.789 ); my $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 38, 0, 0, 0, 1, 97, 0, 124, 242, 176, 80, 107, 154, 191, 63, 1, 98, 0, 243, 142, 83, 116, 36, 151, 191, 191, 1, 99, 0, 201, 118, 190, 159, 12, 36, 254, 64, 0 ], 'Double encode' ); my $hash = decode( $bson ); for my $k ( sort keys %$hash ) { _delta_ok( $hash->{$k}, $h{$k}, "Double decode $h{$k}" ); } }; # String subtest string => sub { plan tests => 5; %h = ( a => 'bar', b => 'foo' ); my $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 27, 0, 0, 0, 2, 97, 0, 4, 0, 0, 0, 98, 97, 114, 0, 2, 98, 0, 4, 0, 0, 0, 102, 111, 111, 0, 0 ], 'String encode' ); my $hash = decode( $bson ); is_deeply( $hash, \%h, 'String decode' ); # String object %h = ( a => BSON::String->new(123456), b => BSON::String->new(-11.99) ); $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 33, 0, 0, 0, 2, 97, 0, 7, 0, 0, 0, 49, 50, 51, 52, 53, 54, 0, 2, 98, 0, 7, 0, 0, 0, 45, 49, 49, 46, 57, 57, 0, 0 ], 'String object encode' ); $hash = decode( $bson ); is( $hash->{a}, 123456, 'String object decode' ); is( $hash->{b}, -11.99, 'String object decode 2' ); }; # Array subtest array => sub { plan tests => 2; %h = ( a => [ 1, 2, 3, 'a', 'b', 'c' ] ); my $bson = encode(\%h); is_deeply( [ unpack "C*", $bson ], [ 61, 0, 0, 0, 4, 97, 0, 53, 0, 0, 0, 16, 48, 0, 1, 0, 0, 0, 16, 49, 0, 2, 0, 0, 0, 16, 50, 0, 3, 0, 0, 0, 2, 51, 0, 2, 0, 0, 0, 97, 0, 2, 52, 0, 2, 0, 0, 0, 98, 0, 2, 53, 0, 2, 0, 0, 0, 99, 0, 0, 0 ], 'Array encode' ); is_deeply( decode($bson), \%h, 'Array decode' ); }; # Null subtest null => sub { plan tests => 2; my $h = { a => undef }; my $bson = encode( $h ); is_deeply( [ unpack "C*", $bson ], [ 8, 0, 0, 0, 10, 97, 0, 0 ], 'Null encode' ); is_deeply( decode($bson), $h, 'Null decode' ); }; # Hash subtest hash => sub { plan tests => 4; tie( %h2, 'Tie::IxHash', b => 1, c => 'bar' ); %h = ( a => \%h2 ); my $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 31, 0, 0, 0, 3, 97, 0, 23, 0, 0, 0, 16, 98, 0, 1, 0, 0, 0, 2, 99, 0, 4, 0, 0, 0, 98, 97, 114, 0, 0, 0 ], 'Hash 1 encode' ); is_deeply( decode($bson), \%h, 'Hash 1 decode' ); # Hash 2 tie( %h1, 'Tie::IxHash', a => [ 1, 2, 3 ], b => 'foo' ); tie( %h2, 'Tie::IxHash', a => \%h1, b => [ 1, 2, 3 ] ); %h = ( a => \%h2, b => \%h1 ); $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], [ 138, 0, 0, 0, 3, 97, 0, 82, 0, 0, 0, 3, 97, 0, 45, 0, 0, 0, 4, 97, 0, 26, 0, 0, 0, 16, 48, 0, 1, 0, 0, 0, 16, 49, 0, 2, 0, 0, 0, 16, 50, 0, 3, 0, 0, 0, 0, 2, 98, 0, 4, 0, 0, 0, 102, 111, 111, 0, 0, 4, 98, 0, 26, 0, 0, 0, 16, 48, 0, 1, 0, 0, 0, 16, 49, 0, 2, 0, 0, 0, 16, 50, 0, 3, 0, 0, 0, 0, 0, 3, 98, 0, 45, 0, 0, 0, 4, 97, 0, 26, 0, 0, 0, 16, 48, 0, 1, 0, 0, 0, 16, 49, 0, 2, 0, 0, 0, 16, 50, 0, 3, 0, 0, 0, 0, 2, 98, 0, 4, 0, 0, 0, 102, 111, 111, 0, 0, 0 ], 'Hash 2 encode' ); is_deeply( decode($bson), \%h, 'Hash 2 decode' ); }; # Regex subtest regex => sub { plan tests => 9; my @sp = BSON::PP::_split_re(qr/\w/i); is_deeply(\@sp, ['\w', 'i']); my $re1_str = q!"(?:[^"\\\]++|\\\.)*+"!; my @re1_bytes = ( 34, 40, 63, 58, 91, 94, 34, 92, 92, 93, 43, 43, 124, 92, 92, 46, 41, 42, 43, 34, 0, 0 ); my $re2_str = q!"(?>(?:(?>[^"\\\]+)|\\\.)*)"!; my @re2_bytes = ( 34, 40, 63, 62, 40, 63, 58, 40, 63, 62, 91, 94, 34, 92, 92, 93, 43, 41, 124, 92, 92, 46, 41, 42, 41, 34, 0, 0 ); my @expected_bytes; if ($] >= 5.01) { # first regex works only on perl >= 5.10 %h = eval { ( a => qr/$re1_str/, b => qr/$re2_str/ ) }; die "Can't eval regexes: $@" if $@; @expected_bytes = ( 61, 0, 0, 0, 11, 97, 0, @re1_bytes, 11, 98, 0, @re2_bytes, 0 ); } else { %h = (a => qr/$re2_str/, b => qr/$re2_str/); @expected_bytes = ( 67, 0, 0, 0, 11, 97, 0, @re2_bytes, 11, 98, 0, @re2_bytes, 0 ); } my $bson = encode( \%h ); is_deeply( [ unpack "C*", $bson ], \@expected_bytes, 'Regex encode' ); my $hash = decode( $bson ); is(ref $hash->{a}, 'BSON::Regex'); is(ref $hash->{b}, 'BSON::Regex'); SKIP: { skip "Comparing regexes is fragile before 5.10", 1 if $] lt 5.010; $hash->{$_} = $hash->{$_}->try_compile for qw/a b/; for (qw/a b/) { is_deeply( [ re::regexp_pattern( $hash->{$_} ) ], [ re::regexp_pattern( $h{$_} ) ], "Regex decode of key $_", ); } } #<<< %h = ( a => qr/(?:(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))/i ); #>>> $bson = encode(\%h); is_deeply( [ unpack "C*", $bson ], [ 139, 0, 0, 0, 11, 97, 0, 40, 63, 58, 40, 63, 58, 91, 43, 45, 93, 63, 41, 40, 63, 58, 40, 63, 61, 91, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 93, 124, 91, 46, 93, 41, 40, 63, 58, 91, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 93, 42, 41, 40, 63, 58, 40, 63, 58, 91, 46, 93, 41, 40, 63, 58, 91, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 93, 123, 48, 44, 125, 41, 41, 63, 41, 40, 63, 58, 40, 63, 58, 91, 69, 93, 41, 40, 63, 58, 40, 63, 58, 91, 43, 45, 93, 63, 41, 40, 63, 58, 91, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 93, 43, 41, 41, 124, 41, 41, 0, 105, 0, 0 ], 'real num regex' ); $hash = decode( $bson ); is(ref $hash->{a}, 'BSON::Regex'); SKIP: { skip "Comparing regexes is fragile before 5.10", 2 if $] lt 5.010; $hash->{a} = $hash->{a}->try_compile; # after try_compile, "i" flags are put into the regex, so we must # do the same with the original my ($p,$f) = re::regexp_pattern($h{a}); $h{a} = qr{(?$f:$p)}; is_deeply( [ re::regexp_pattern( $hash->{a} ) ], [ re::regexp_pattern( $h{a} ) ], "Regex decode of key a", ); } }; # Datetime subtest datetime => sub { eval { require DateTime }; plan skip_all => "Needs DateTime" unless $INC{"DateTime.pm"}; plan tests => 6; my $dt = DateTime->new( year => 1974, month => 10, day => 15, hour => 22, minute => 50, second => 8, time_zone => 'UTC' ); my $h = { a => BSON::Time->new( $dt->epoch ) }; my $bson = encode( $h ); #<<< is_deeply( [ unpack "C*", $bson ], [ 16, 0, 0, 0, 9, 97, 0, 0, 149, 210, 46, 35, 0, 0, 0, 0 ], 'encode 1974' ); #>>> is_deeply( decode($bson), $h, 'decode 1974' ); $dt = DateTime->new( year => 1964, month => 10, day => 15, hour => 22, minute => 50, second => 8, time_zone => 'UTC' ); $h = { a => BSON::Time->new( $dt->epoch ) }; $bson = encode( $h ); #<<< is_deeply( [ unpack "C*", $bson ], [16, 0, 0, 0, 9, 97, 0, 0, 37, 154, 183, 217, 255, 255, 255, 0], 'encode 1964' ); #>>> is_deeply( decode($bson), $h, 'decode 1964' ); $dt = DateTime->new( year => 2028, month => 10, day => 15, hour => 22, minute => 50, second => 8, time_zone => 'UTC' ); $h = { a => BSON::Time->new( $dt->epoch ) }; $bson = encode( $h ); #<<< is_deeply( [ unpack "C*", $bson ], [16, 0, 0, 0, 9, 97, 0, 0, 229, 74, 246, 175, 1, 0, 0, 0], 'encode 2028' ); #>>> is_deeply( decode($bson), $h, 'decode 2028' ); }; subtest min_max_key => sub { plan tests => 4; my $bson = encode( { a => BSON::MinKey->new } ); #<<< is_deeply( [ unpack "C*", $bson ], [8, 0, 0, 0, 255, 97, 0, 0], 'MinKey encode' ); #>>> isa_ok( decode($bson)->{a}, 'BSON::MinKey', 'MinKey decode' ); $bson = encode( { a => BSON::MaxKey->new } ); #<<< is_deeply( [ unpack "C*", $bson ], [8, 0, 0, 0, 127, 97, 0, 0], 'MaxKey' ); #>>> isa_ok( decode($bson)->{a}, 'BSON::MaxKey', 'MaxKey decode' ); }; subtest binary => sub { plan tests => 8; my $bin = BSON::Binary->new( [ 1, 2, 3, 4, 5 ] ); my $bson = encode( { a => $bin } ); #<<< is_deeply( [ unpack "C*", $bson ], [18, 0, 0, 0, 5, 97, 0, 5, 0, 0, 0, 0, 1, 2, 3, 4, 5, 0], 'Binary 1 encode' ) or diag _dump_bson($bson); #>>> my $hash = decode($bson); isa_ok( $hash->{a}, 'BSON::Bytes' ); is( $hash->{a}->type, $bin->type, 'compare type' ); is_deeply( $hash->{a}->data, pack("C*",@{$bin->data}), 'compare data' ); $bin = BSON::Binary->new( "5366a937375901366effb80511b39919", 5 ); $bson = encode( { a => $bin } ); $a = [ unpack "C*", encode( { a => $bin } ) ]; is_deeply( [ unpack "C*", $bson ], [ 45, 0, 0, 0, 5, 97, 0, 32, 0, 0, 0, 5, 53, 51, 54, 54, 97, 57, 51, 55, 51, 55, 53, 57, 48, 49, 51, 54, 54, 101, 102, 102, 98, 56, 48, 53, 49, 49, 98, 51, 57, 57, 49, 57, 0 ], 'Binary 2 encode' ); $hash = decode($bson); isa_ok( $hash->{a}, 'BSON::Bytes' ); is( $hash->{a}->type, $bin->type, 'compare type' ); is_deeply( $hash->{a}->data, pack("C*",@{$bin->data}), 'compare data' ); }; # ObjectId subtest objectid => sub { plan tests => 4; my $oid = BSON::ObjectId->new('4e2766e6e1b8325d02000028'); my $h = { _id => $oid }; my $bson = encode( $h ); is_deeply( [ unpack "C*", $bson ], [ 22, 0, 0, 0, 7, 95, 105, 100, 0, 78, 39, 102, 230, 225, 184, 50, 93, 2, 0, 0, 40, 0 ], 'ObjectId encode' ); my $hash = decode($bson); isa_ok( $hash->{_id}, 'BSON::OID', 'OID created' ); is_deeply( $hash, $h, 'OID decode' ); is("$h->{_id}", "$hash->{_id}", 'Match'); }; subtest code => sub { plan tests => 8; my $code = BSON::Code->new("function a(b,c){return b>c?c:b}", {}); my $bson = encode( { a => $code } ); is_deeply( [ unpack "C*", $bson ], [ 53, 0, 0, 0, 15, 97, 0, 45, 0, 0, 0, 32, 0, 0, 0, 102, 117, 110, 99, 116, 105, 111, 110, 32, 97, 40, 98, 44, 99, 41, 123, 114, 101, 116, 117, 114, 110, 32, 98, 62, 99, 63, 99, 58, 98, 125, 0, 5, 0, 0, 0, 0, 0 ], 'Code with empty scope encode' ); my $hash = decode( $bson ); isa_ok( $hash->{a}, 'BSON::Code' ); is( $hash->{a}->code, $code->code ); is_deeply( $hash->{a}->scope, $code->scope ); %h = ( a => 'foo', b => 'bar', c => 45 ); $code = BSON::Code->new("function a(b,c){alert('OMG!')}", \%h); $bson = encode( { a => $code } ); is_deeply( [ unpack "C*", $bson ], [ 81, 0, 0, 0, 15, 97, 0, 73, 0, 0, 0, 31, 0, 0, 0, 102, 117, 110, 99, 116, 105, 111, 110, 32, 97, 40, 98, 44, 99, 41, 123, 97, 108, 101, 114, 116, 40, 39, 79, 77, 71, 33, 39, 41, 125, 0, 34, 0, 0, 0, 2, 97, 0, 4, 0, 0, 0, 102, 111, 111, 0, 2, 98, 0, 4, 0, 0, 0, 98, 97, 114, 0, 16, 99, 0, 45, 0, 0, 0, 0, 0 ], 'Code' ); $hash = decode( $bson ); isa_ok( $hash->{a}, 'BSON::Code' ); is( $hash->{a}->code, $code->code ); is_deeply( $hash->{a}->scope, $code->scope ); }; subtest timestamp => sub { plan tests => 4; my $ts = BSON::Timestamp->new( 0x1234, 0x5678 ); my $bson = encode( { a => $ts } ); is_deeply( [ unpack "C*", $bson ], [ 16, 0, 0, 0, 17, 97, 0, 120, 86, 0, 0, 52, 18, 0, 0, 0 ], 'timestamp encode' ); my $hash = decode( $bson ); isa_ok( $hash->{a}, 'BSON::Timestamp' ); is( $hash->{a}->increment, $ts->increment, 'timestamp increment' ); is( $hash->{a}->seconds, $ts->seconds, 'timestamp seconds' ); }; subtest options => sub { plan tests => 2; # ixhash my $hash = { a => 1, b => 2 }; my $bson = encode($hash); my $h1 = decode($bson); my $h2 = decode( $bson, ixhash => 1 ); is( ref tied %$h1, '', 'regular hash' ); is( ref tied %$h2, 'Tie::IxHash', 'Tie::IxHash' ); }; BSON-v1.12.1/t/corpus/dbref.t000644 000765 000024 00000000711 13524525151 016004 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/oid.t000644 000765 000024 00000000710 13524525151 015474 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-6.t000644 000765 000024 00000000710 13524525151 016715 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-2.t000644 000765 000024 00000000710 13524525151 016711 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/symbol.t000644 000765 000024 00000000710 13524525151 016226 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/int64.t000644 000765 000024 00000000710 13524525151 015665 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-5.t000644 000765 000024 00000000710 13524525151 016714 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/null.t000644 000765 000024 00000000710 13524525151 015673 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/code.t000644 000765 000024 00000000710 13524525151 015633 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-1.t000644 000765 000024 00000000710 13524525151 016710 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/datetime.t000644 000765 000024 00000000710 13524525151 016515 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/regex.t000644 000765 000024 00000000710 13524525151 016033 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/undefined.t000644 000765 000024 00000000710 13524525151 016662 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-4.t000644 000765 000024 00000000710 13524525151 016713 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/top.t000644 000765 000024 00000000710 13524525151 015523 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/int32.t000644 000765 000024 00000000710 13524525151 015660 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/boolean.t000644 000765 000024 00000000710 13524525151 016340 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/document.t000644 000765 000024 00000000710 13524525151 016537 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/array.t000644 000765 000024 00000000710 13524525151 016037 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/multi-type.t000644 000765 000024 00000000711 13524525151 017033 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/double.t000644 000765 000024 00000000710 13524525151 016173 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-7.t000644 000765 000024 00000000710 13524525151 016716 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/maxkey.t000644 000765 000024 00000000710 13524525151 016217 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/decimal128-3.t000644 000765 000024 00000000710 13524525151 016712 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/dbpointer.t000644 000765 000024 00000000710 13524525151 016707 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/timestamp.t000644 000765 000024 00000000710 13524525151 016724 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/minkey.t000644 000765 000024 00000000710 13524525151 016215 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/string.t000644 000765 000024 00000000710 13524525151 016227 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/code_w_scope.t000644 000765 000024 00000000710 13524525151 017352 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/binary.t000644 000765 000024 00000000710 13524525151 016205 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/corpus/corpus.pl000644 000765 000024 00000000664 13524525151 016414 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use Path::Tiny; use lib 't/lib'; use CleanEnv; use CorpusTest; test_corpus_file( path($0)->basename(".t") . ".json" ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/dbref.t000644 000765 000024 00000004302 13524525151 016124 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; use Tie::IxHash; my ( $bson, $expect, $hash ); # test BSON::DBRef constructor eval { bson_dbref() }; like( $@, qr/arguments to bson_dbref/i, "empty bson_dbref() throws error" ); eval { bson_dbref("12345") }; like( $@, qr/arguments to bson_dbref/i, "bson_dbref(ID) throws error" ); eval { bson_dbref( "12345", "test", more => "stuff" ) }; like( $@, qr/arguments to bson_dbref/i, "bson_dbref(ID,REF,EXTRA) throws error" ); # test mapping my $dbref = bson_dbref( "12345", "foo" ); my $input = { A => $dbref }; # BSON::DBRef-> BSON::DBRef { $expect = $bson = encode($input); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::DBRef', "BSON::DBRef->BSON::DBRef" ); is( $hash->{A}->id, $dbref->id, "DBRef id" ); is( $hash->{A}->ref, $dbref->ref, "DBRef ref" ); } # BSON::DBRef->HASH { $expect = $bson = encode($input); $hash = decode( $bson, wrap_dbrefs => 0 ); is( ref( $hash->{A} ), 'HASH', "BSON::DBRef->HASH" ); is( $hash->{A}{'$id'}, $dbref->id, "\$id" ); is( $hash->{A}{'$ref'}, $dbref->ref, "\$ref" ); } # MongoDB::DBRef -> BSON::Regex SKIP: { $ENV{PERL_MONGO_NO_DEP_WARNINGS} = 1; eval { require MongoDB::DBRef }; skip( "MongoDB::DBRef v1.0.0+ not installed", 4 ) unless $INC{'MongoDB/DBRef.pm'} && eval {MongoDB::DBRef->VERSION("v1.0.0")}; $bson = encode( { A => MongoDB::DBRef->new( id => $dbref->id, 'ref' => $dbref->ref ) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::DBRef', "MongoDB::DBRef->BSON::DBRef" ); is( $hash->{A}->id, $dbref->id, "DBRef id" ); is( $hash->{A}->ref, $dbref->ref, "DBRef ref" ); is( $bson, $expect, "BSON correct" ); } done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/time.t000644 000765 000024 00000010441 13524525151 016001 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; my ( $bson, $expect, $hash ); my $now = time; # test constructor ok( bson_time() >= $now, "empty bson_time() is current time (or so)" ); ok( BSON::Time->new >= $now, "empty BSON::Time constructor is curren time (or so)" ); # test overloading is( bson_time($now), $now, "BSON::Time string overload" ); is( 0+ bson_time($now), $now, "BSON::Time string overload" ); # BSON::Time -> BSON::Time $bson = $expect = encode( { A => bson_time($now) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::Time', "BSON::Time->BSON::Time" ); is( "$hash->{A}", $now, "value correct" ); # DateTime -> BSON::Time SKIP: { eval { require DateTime }; skip( "DateTime not installed", 1 ) unless $INC{'DateTime.pm'}; $bson = encode( { A => DateTime->from_epoch( epoch => $now ) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::Time', "DateTime->BSON::Time" ); is( "$hash->{A}", $now, "value correct" ); is( $bson, $expect, "BSON correct" ); # conversion my $obj = $hash->{A}->as_datetime; isa_ok( $obj, 'DateTime', 'as_datetime' ); is($obj->epoch, $now, "epoch"); } # DateTime::Tiny -> BSON::Time SKIP: { eval { require DateTime::Tiny }; skip( "DateTime::Tiny not installed", 1 ) unless $INC{'DateTime/Tiny.pm'}; my ($s,$m,$h,$D,$M,$Y) = gmtime($now); my $dt = DateTime::Tiny->new( year => $Y + 1900, month => $M + 1, day => $D, hour => $h, minute => $m, second => $s ); $bson = encode( { A => $dt } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::Time', "DateTime::Tiny->BSON::Time" ); is( "$hash->{A}", $now, "value correct" ); is( $bson, $expect, "BSON correct" ); # conversion my $obj = $hash->{A}->as_datetime_tiny; isa_ok( $obj, 'DateTime::Tiny', 'as_datetime_tiny' ); is($obj->as_string . "Z", $hash->{A}->as_iso8601, "iso8601"); } # Time::Moment -> BSON::Time SKIP: { eval { require Time::Moment }; skip( "Time::Moment not installed", 1 ) unless $INC{'Time/Moment.pm'}; $bson = encode( { A => Time::Moment->from_epoch( $now ) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::Time', "Time::Moment->BSON::Time" ); is( "$hash->{A}", $now, "value correct" ); is( $bson, $expect, "BSON correct" ); # conversion my $obj = $hash->{A}->as_time_moment; isa_ok( $obj, 'Time::Moment', 'as_time_moment' ); is($obj->epoch, $now, "epoch"); } # Mango::BSON::Time -> BSON::Time SKIP: { eval { require Mango::BSON::Time }; skip( "Mango::BSON::Time not installed", 1 ) unless $INC{'Mango/BSON/Time.pm'}; $bson = encode( { A => Mango::BSON::Time->new( $now * 1000 ) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::Time', "Mango::BSON::Time->BSON::Time" ); is( "$hash->{A}", $now, "value correct" ); is( $bson, $expect, "BSON correct" ); # conversion my $obj = $hash->{A}->as_mango_time; isa_ok( $obj, 'Mango::BSON::Time', 'as_mango_time' ); is( $obj->to_epoch, $now, "to_epoch" ); } # conversion to float my $small_t = BSON::Time->new( value => 2 ); my $float = $small_t->epoch; ok( $float > 0, "epoch handles small values without rounding to zero" ); # to JSON is( to_myjson({a=>bson_time(0)}), q[{"a":"1970-01-01T00:00:00Z"}], 'json: bson_time(0)' ); is( to_myjson({a=>BSON::Time->new(value => "1356351330500")}), q[{"a":"2012-12-24T12:15:30.500Z"}], 'json: bson_time(1356351330.5)' ); # to extended JSON is( to_extjson({a=>bson_time(0)}), q[{"a":{"$date":{"$numberLong":"0"}}}], 'extjson: bson_time(0)' ); is( to_extjson({a=>BSON::Time->new(value => "1356351330500")}), q[{"a":{"$date":{"$numberLong":"1356351330500"}}}], 'extjson: bson_time(1356351330.5)' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/minmaxkey.t000644 000765 000024 00000003506 13524525151 017051 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; my ( $bson, $expect, $hash ); # test constructor isa_ok( bson_maxkey(), "BSON::MaxKey", "bson_maxkey" ); isa_ok( bson_minkey(), "BSON::MinKey", "bson_minkey" ); isa_ok( BSON::MaxKey->new(), "BSON::MaxKey", "bson_maxkey" ); isa_ok( BSON::MinKey->new(), "BSON::MinKey", "bson_minkey" ); # BSON::MaxKey -> BSON::MaxKey $bson = $expect = encode( bson_doc( A => bson_maxkey(), B => bson_minkey() ) ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::MaxKey', "BSON::MaxKey->BSON::MaxKey" ); is( ref( $hash->{B} ), 'BSON::MinKey', "BSON::MinKey->BSON::MinKey" ); # MongoDB::[Min|Max]Key (deprecated) -> BSON::Regex $bson = encode( bson_doc( A => bless( {}, 'MongoDB::MaxKey' ), B => bless( {}, 'MongoDB::MinKey' ) ) ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::MaxKey', "BSON::MaxKey->BSON::MaxKey" ); is( ref( $hash->{B} ), 'BSON::MinKey', "BSON::MinKey->BSON::MinKey" ); is( $bson, $expect, "BSON correct" ); eval { to_myjson({a=>bson_maxkey()}) }; like( $@, qr/illegal in JSON/, 'json throws: bson_maxkey()' ); eval { to_myjson({a=>bson_minkey()}) }; like( $@, qr/illegal in JSON/, 'json throws: bson_minkey()' ); # to extended JSON is( to_extjson({a=>bson_minkey()}), q[{"a":{"$minKey":1}}], 'extjson: bson_minkey' ); is( to_extjson({a=>bson_maxkey()}), q[{"a":{"$maxKey":1}}], 'extjson: bson_maxkey' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/oid.t000644 000765 000024 00000007625 13524525151 015630 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; my ( $bson, $expect, $hash ); my $packed = BSON::OID::_packed_oid(); my $hexoid = unpack( "H*", $packed ); my $all_bits = "\xff" x 8; # test constructors is( length( bson_oid()->oid ), 12, "empty bson_oid() generates new OID" ); is( length( bson_oid()->from_epoch(time)->oid ), 12, "from_epoch(time) generates new OID" ); is( length( bson_oid()->from_epoch(time, 0)->oid ), 12, "from_epoch(time, 0) generates new OID" ); is( length( bson_oid()->from_epoch(time, $all_bits)->oid ), 12, 'from_epoch(time, "\xff"x8) generates new OID' ); is( bson_oid($packed)->oid, $packed, "bson_oid(\$packed) returns packed" ); is( bson_oid($hexoid)->oid, $packed, "bson_oid(\$hexoid) returns packed" ); is( length( BSON::OID->new()->oid ), 12, "empty BSON::OID->new() generates new OID" ); is( length( BSON::OID->from_epoch(time)->oid ), 12, "BSON::OID->from_epoch(time) generates new OID" ); is( BSON::OID->new(oid => $packed)->oid, $packed, "BSON::OID->new(\$packed) returns packed" ); # test overloading is( bson_oid($packed), $hexoid, "BSON::OID string overload" ); # test comparison my ($oid1, $oid2) = (bson_oid(), bson_oid()); is( $oid1 cmp $oid1, 0, "BSON::OID cmp overload (0)" ); is( $oid1 cmp $oid2, -1, "BSON::OID cmp overload (-1)" ); is( $oid2 cmp $oid1, 1, "BSON::OID cmp overload (1)" ); is( $oid1 <=> $oid1, 0, "BSON::OID <=> overload (0)" ); is( $oid1 <=> $oid2, -1, "BSON::OID <=> overload (-1)" ); is( $oid2 <=> $oid1, 1, "BSON::OID <=> overload (1)" ); # BSON::OID -> BSON::OID $bson = $expect = encode( { A => bson_oid($packed) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::OID', "BSON::OID->BSON::OID" ); is( "$hash->{A}", $hexoid, "value correct" ); # BSON::OID from_epoch my $epoch = 1467545180; my $packed_zero = pack('N3', $epoch, 0, 0); my $packed_ones = pack('Na8', $epoch, $all_bits); is( BSON::OID->from_epoch($epoch)->get_time, $epoch, "from_epoch(time) time roundtrip ok" ); is( BSON::OID->from_epoch($epoch, 0)->oid, $packed_zero, "from_epoch(time, 0) OID is correct" ); is( BSON::OID->from_epoch($epoch, "0")->oid, $packed_zero, "from_epoch(time, \"0\") OID is correct" ); is( BSON::OID->from_epoch($epoch, "000000")->oid, $packed_zero, "from_epoch(time, \"0000\") OID is correct" ); is( BSON::OID->from_epoch($epoch, $all_bits)->oid, $packed_ones, "from_epoch(time, \"\\xff\"x8) roundtrip ok" ); is( bson_oid->from_epoch($epoch, $all_bits)->oid, $packed_ones, "bson_oid->from_epoch(time, \"\\xff\"x8) roundtrip ok" ); eval { BSON::OID->from_epoch($epoch, "123") }; like( $@, qr/second argument/, "second arg must be zero or eight byts" ); # BSON::ObjectId (deprecated) -> BSON::OID $hash = encode( { A => BSON::ObjectId->new($packed) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::OID', "BSON::ObjectId->BSON::OID" ); is( "$hash->{A}", $hexoid, "value correct" ); is( $bson, $expect, "BSON correct" ); # MongoDB::OID (deprecated) -> BSON::OID SKIP: { $ENV{PERL_MONGO_NO_DEP_WARNINGS} = 1; eval { require MongoDB; require MongoDB::OID; }; skip( "MongoDB::OID not installed", 2 ) unless $INC{'MongoDB/OID.pm'}; $bson = encode( { A => MongoDB::OID->new( value => $hexoid ) } ); $hash = decode($bson); is( ref( $hash->{A} ), 'BSON::OID', "MongoDB::OID->BSON::OID" ); is( "$hash->{A}", $hexoid, "value correct" ); is( $bson, $expect, "BSON correct" ); } done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/int64.t000644 000765 000024 00000016115 13524525151 016013 0ustar00davidstaff000000 000000 use 5.0001; use strict; use warnings; use Test::More 0.96; use Math::BigInt; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use JSON::MaybeXS; use Config; use BSON qw/encode decode/; use BSON::Types ':all'; my ($hash, $bson, $expect); my $max_int64 = $Config{use64bitint} ? 9223372036854775807 : Math::BigInt->new("9223372036854775807"); my $min_int64 = $Config{use64bitint} ? -9223372036854775808 : Math::BigInt->new("-9223372036854775808"); my $max_int32_p1 = Math::BigInt->new("2147483648"); my $min_int31_m1 = Math::BigInt->new("-2147483649"); my $bigpos = Math::BigInt->new("9223372036854775808"); my $bigneg = Math::BigInt->new("-9223372036854775809"); # test constructor packed_is( INT64, bson_int64(), 0, "empty bson_int64() is 0" ); packed_is( INT64, BSON::Int64->new, 0, "empty constructor is 0" ); # test constructor errors; these will cap at min/max int64 packed_is( INT64, bson_int64(9223372036854775808), $max_int64, "bson_int64(9223372036854775808)" ); packed_is( INT64, bson_int64(9223372036854775808.01), $max_int64, "bson_int64(9223372036854775808.01)" ); packed_is( INT64, bson_int64(9223372036854775807.99), $max_int64, "bson_int64(9223372036854775807.99)" ); packed_is( INT64, bson_int64(-9223372036854775809), $min_int64, "bson_int64(-9223372036854775809)" ); packed_is( INT64, bson_int64(-9223372036854775809.01), $min_int64, "bson_int64(-9223372036854775809.01)"); packed_is( INT64, bson_int64(-9223372036854775808.99), $min_int64, "bson_int64(-9223372036854775808.99)"); packed_is( INT64, bson_int64($bigpos), $max_int64, "bson_int64(bigpos)" ); packed_is( INT64, bson_int64($bigneg), $min_int64, "bson_int64(bigpos)" ); # test overloading packed_is( INT64, bson_int64($max_int32_p1), $max_int32_p1, "overloading correct" ); subtest 'native (64-bit perls)' => sub { plan skip_all => 'not a 64-bit perl' unless $Config{use64bitint}; # int64 -> int64 $bson = $expect = encode( { A => $max_int32_p1 } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "int64->int64" ); packed_is( INT64, $hash->{A}, $max_int32_p1, "value correct" ); # BSON::Int64 -> int64 $bson = encode( { A => bson_int64($max_int32_p1) } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "BSON::Int64->int64" ); packed_is( INT64, $hash->{A}, $max_int32_p1, "value correct" ); bytes_are( $bson, $expect, "BSON correct" ); # BSON::Int64(string) -> int64 $bson = encode( { A => bson_int64("0") } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "BSON::Int64->int64" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); # Math::BigInt -> int64 $bson = encode( { A => Math::BigInt->new("0") } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "Math::BigInt->int64" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); # Math::Int64 -> int64 SKIP: { eval { require Math::Int64 }; skip( "Math::Int64 not installed", 2 ) unless $INC{'Math/Int64.pm'}; $bson = encode( { A => Math::Int64::int64("0") } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "Math::Int64->int64" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); } }; subtest 'Math::BigInt (32-bit perls)' => sub { plan skip_all => 'not a 32-bit perl' if $Config{use64bitint}; # NV -> Math::BigInt $bson = $expect = encode( { A => $max_int32_p1 } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'Math::BigInt', "int64->Math::BigInt" ); packed_is( INT64, $hash->{A}, $max_int32_p1, "value correct" ); # BSON::Int64 -> Math::BigInt $bson = encode( { A => bson_int64($max_int32_p1) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'Math::BigInt', "BSON::Int64->Math::BigInt" ); packed_is( INT64, $hash->{A}, $max_int32_p1, "value correct" ); bytes_are( $bson, $expect, "BSON correct" ); # BSON::Int64(string) -> Math::BigInt $bson = encode( { A => bson_int64("0") } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'Math::BigInt', "BSON::Int64->Math::BigInt" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); # Math::BigInt -> Math::BigInt $bson = encode( { A => Math::BigInt->new("0") } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'Math::BigInt', "Math::BigInt->Math::BigInt" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); # Math::Int64 -> Math::BigInt SKIP: { eval { require Math::Int64 }; skip( "Math::Int64 not installed", 2 ) unless $INC{'Math/Int64.pm'}; $bson = encode( { A => Math::Int64::int64("0") } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'Math::BigInt', "Math::Int64->Math::BigInt" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); } }; subtest 'wrapped' => sub { # int64 -> BSON::Int64 $bson = $expect = encode( { A => $max_int32_p1 } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int64', "int64->BSON::Int64" ); packed_is( INT64, $hash->{A}, $max_int32_p1, "value correct" ); # BSON::Int64 -> BSON::Int64 $bson = encode( { A => bson_int64($max_int32_p1) } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int64', "int64->BSON::Int64" ); packed_is( INT64, $hash->{A}, $max_int32_p1, "value correct" ); bytes_are( $bson, $expect, "BSON correct" ); # BSON::Int64(string) -> BSON::Int64 $bson = encode( { A => bson_int64("0") } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int64', "int64->BSON::Int64" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); # Math::BigInt -> BSON::Int64 $bson = encode( { A => Math::BigInt->new("0") } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int64', "Math::BigInt->BSON::Int64" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); # Math::Int64 -> BSON::Int64 SKIP: { eval { require Math::Int64 }; skip( "Math::Int64 not installed", 2 ) unless $INC{'Math/Int64.pm'}; $bson = encode( { A => Math::Int64::int64("0") } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int64', "Math::Int64->BSON::Int64" ); packed_is( INT64, $hash->{A}, 0, "value correct" ); } }; if ( $Config{use64bitint} ) { # to JSON SKIP: { skip "JSON::PP has trouble with TO_JSON being false", 1 if ref JSON::MaybeXS->new eq 'JSON::PP'; is( to_myjson({a=>bson_int64(0)}), q[{"a":0}], 'bson_int64(0)' ); } is( to_myjson({a=>bson_int64(42)}), q[{"a":42}], 'bson_int64(42)' ); # to extended JSON is( to_extjson({a=>bson_int64(0)}), q[{"a":{"$numberLong":"0"}}], 'extjson: bson_int64(0)' ); is( to_extjson({a=>bson_int64(42)}), q[{"a":{"$numberLong":"42"}}], 'extjson: bson_int64(0)' ); } done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/code.t000644 000765 000024 00000007606 13524525151 015766 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; use Test::Deep '!blessed'; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; my ($bson, $expect, $hash); my $code = 'alert("Hello World");'; my $scope = { x => 1 }; # test constructor is( bson_code()->code, '', "empty bson_code()" ); is( bson_code()->scope, undef, "empty bson_code()" ); is( bson_code($code)->code, $code, "bson_code(code)->code" ); is( bson_code($code)->scope , undef, "bson_code(code)->scope" ); is( bson_code( $code, $scope )->code, $code, "bson_code(code, scope)->code" ); is( bson_code( $code, $scope )->scope , $scope, "bson_code(code, scope)->scope" ); is( BSON::Code->new()->code, '', "empty BSON::Code->new()" ); is( BSON::Code->new()->scope, undef, "empty BSON::Code->new()" ); is( BSON::Code->new( code => $code )->code, $code, "BSON::Code->new(code)->code" ); is( BSON::Code->new( code => $code )->scope, undef, "BSON::Code->new(code)->scope" ); is( BSON::Code->new( code => $code, scope => $scope )->code, $code, "BSON::Code->new(code, scope)->code" ); is( BSON::Code->new( code => $code, scope => $scope )->scope , $scope, "BSON::Code->new(code, scope)->scope" ); subtest "BSON type CODE" => sub { $bson = $expect = encode( { A => bson_code($code) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Code', "BSON::Code->BSON::Code" ); is( $hash->{A}->code, $code, "code correct" ); cmp_deeply( $hash->{A}->scope, undef, "scope correct" ); # MongoDB::Code (deprecated) -> BSON::Code SKIP: { $ENV{PERL_MONGO_NO_DEP_WARNINGS} = 1; eval { require MongoDB::Code }; skip( "MongoDB::Code not installed", 2 ) unless $INC{'MongoDB/Code.pm'}; $bson = encode( { A => MongoDB::Code->new( code => $code ) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Code', "MongoDB::Code->BSON::Code" ); is( $hash->{A}->code, $code, "code correct" ); cmp_deeply( $hash->{A}->scope, undef, "scope correct" ); is( $bson, $expect, "BSON correct" ); } }; subtest "BSON type CODEWSCOPE" => sub { $bson = $expect = encode( { A => bson_code($code, $scope) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Code', "BSON::Code->BSON::Code" ); is( $hash->{A}->code, $code, "code correct" ); cmp_deeply( $hash->{A}->scope, $scope, "scope correct" ); # CODEWSCOPE: BSON::Code -> BSON::Code # MongoDB::Code (deprecated) -> BSON::Code SKIP: { $ENV{PERL_MONGO_NO_DEP_WARNINGS} = 1; eval { require MongoDB::Code }; skip( "MongoDB::Code not installed", 2 ) unless $INC{'MongoDB/Code.pm'}; $bson = encode( { A => MongoDB::Code->new( code => $code, scope => $scope ) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Code', "MongoDB::Code->BSON::Code" ); is( $hash->{A}->code, $code, "code correct" ); cmp_deeply( $hash->{A}->scope, $scope, "scope correct" ); is( $bson, $expect, "BSON correct" ); } }; # to JSON eval { to_myjson({a=>bson_code()}) }; like( $@, qr/illegal in JSON/, 'json throws: bson_code()' ); # to extended JSON (my $code_json = $code) =~ s{"}{\\"}g; my $scope_json = to_extjson({%$scope}); is( to_extjson({a=>bson_code($code)}), qq[{"a":{"\$code":"$code_json"}}], 'extjson: bson_code()' ); is( to_extjson( { a => bson_code( $code, $scope ) } ), qq[{"a":{"\$code":"$code_json","\$scope":$scope_json}}], 'extjson: bson_code(,)' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/regex.t000644 000765 000024 00000006434 13524525151 016164 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; my ($bson, $expect, $hash); my $pattern = '\w\d+'; my $flags = 'mix'; my $sorted_flags = 'imx'; my $qr = qr/\w\d+/xim; # test constructor is( bson_regex()->pattern, '', "empty bson_regex()" ); is( bson_regex()->flags, '', "empty bson_regex()" ); is( bson_regex($pattern)->pattern, $pattern, "bson_regex(PATTERN)->pattern" ); is( bson_regex($pattern)->flags , '', "bson_regex(PATTERN)->flags" ); is( bson_regex( $pattern, $flags )->pattern, $pattern, "bson_regex(PATTERN, FLAGS)->pattern" ); is( bson_regex( $pattern, $flags )->flags , $sorted_flags, "bson_regex(PATTERN, FLAGS)->flags" ); is( BSON::Regex->new()->pattern, '', "empty BSON::Regex->new()" ); is( BSON::Regex->new()->flags, '', "empty BSON::Regex->new()" ); is( BSON::Regex->new( pattern => $pattern )->pattern, $pattern, "BSON::Regex->new(PATTERN)->pattern" ); is( BSON::Regex->new( pattern => $pattern )->flags, '', "BSON::Regex->new(PATTERN)->flags" ); is( BSON::Regex->new( pattern => $pattern, flags => $flags )->pattern, $pattern, "BSON::Regex->new(PATTERN, FLAGS)->pattern" ); is( BSON::Regex->new( pattern => $pattern, flags => $flags )->flags , $sorted_flags, "BSON::Regex->new(PATTERN, FLAGS)->flags" ); # BSON::Regex -> BSON::Regex $bson = $expect = encode( { A => bson_regex($pattern, $flags) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Regex', "BSON::Regex->BSON::Regex" ); is( $hash->{A}->pattern, $pattern, "pattern correct" ); is( $hash->{A}->flags, $sorted_flags, "flags correct" ); # qr// -> BSON::Regex $bson = encode( { A => $qr } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Regex', "qr//->BSON::Regex" ); is( $hash->{A}->pattern, $pattern, "pattern correct" ); is( $hash->{A}->flags, $sorted_flags, "flags correct" ); is( $bson, $expect, "BSON correct" ); # MongoDB::BSON::Regexp (deprecated) -> BSON::Regex SKIP: { $ENV{PERL_MONGO_NO_DEP_WARNINGS} = 1; eval { require MongoDB::BSON::Regexp }; skip( "MongoDB::BSON::Regexp not installed", 2 ) unless $INC{'MongoDB/BSON/Regexp.pm'}; $bson = encode( { A => MongoDB::BSON::Regexp->new( pattern => $pattern, flags => $flags ) } ); $hash = decode( $bson ); is( ref( $hash->{A} ), 'BSON::Regex', "MongoDB::BSON::Regexp->BSON::Regex" ); is( $hash->{A}->pattern, $pattern, "pattern correct" ); is( $hash->{A}->flags, $sorted_flags, "flags correct" ); is( $bson, $expect, "BSON correct" ); } # to JSON eval { to_myjson({a=>bson_regex()}) }; like( $@, qr/illegal in JSON/, 'json throws: bson_regex()' ); # to extended JSON (my $pattern_json = $pattern) =~ s{\\}{\\\\}g; is( to_extjson( { a => bson_regex( $pattern, $flags ) } ), qq[{"a":{"\$regularExpression":{"pattern":"$pattern_json","options":"$sorted_flags"}}}], 'extjson: bson_regex(,)' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/hashref.t000644 000765 000024 00000014720 13524525151 016467 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; use Tie::IxHash; my ($hash); # test BSON::Doc constructor is( scalar @{ bson_doc() }, 0, "empty bson_doc() is empty doc" ); is( scalar @{ BSON::Doc->new }, 0, "empty constructor is empty doc" ); eval { bson_doc( a => 1, b => 2, a => 3, c => 4 ) }; like( $@, qr/duplicate keys not allowed/i, "duplicate keys in bson_doc() throw error" ); # test overloading # XXX TBD my @kv = qw/A B/; subtest "Top level document" => sub { # hashref -> hashref $hash = decode( encode( {@kv} ) ); is( ref($hash), 'HASH', "hashref->hashref" ); is_deeply( $hash, {@kv}, "value correct" ); # BSON::Doc -> hashref $hash = decode( encode( bson_doc(@kv) ) ); is( ref($hash), 'HASH', "BSON::Doc->hashref" ); is_deeply( $hash, {@kv}, "value correct" ); # BSON::Raw -> hashref $hash = decode( encode( bson_raw( encode { @kv } ) ) ); is( ref($hash), 'HASH', "BSON::Raw->hashref" ); is_deeply( $hash, {@kv}, "value correct" ); # MongoDB::BSON::Raw -> hashref my $raw = encode( {@kv} ); $hash = decode( encode( bless \$raw, "MongoDB::BSON::Raw" ) ); is( ref($hash), 'HASH', "MongoDB::BSON::Raw->hashref" ); is_deeply( $hash, {@kv}, "value correct" ); # Tie::IxHash tied hashref tie my %ixhash, 'Tie::IxHash', @kv; $hash = decode( encode( \%ixhash ) ); is( ref($hash), 'HASH', "Tie::IxHash(tied)->hashref" ); is_deeply( $hash, {@kv}, "value correct" ); # Tie::IxHash object my $ixdoc = Tie::IxHash->new(@kv); $hash = decode( encode($ixdoc) ); is( ref($hash), 'HASH', "Tie::IxHash(OO)->hashref" ); is_deeply( $hash, {@kv}, "value correct" ); }; subtest "Subdocument" => sub { # hashref -> hashref $hash = decode( encode( { doc => {@kv} } ) ); is( ref( $hash->{doc} ), 'HASH', "hashref->hashref" ); is_deeply( $hash, { doc => {@kv} }, "value correct" ); # BSON::Doc -> hashref $hash = decode( encode( { doc => bson_doc(@kv) } ) ); is( ref( $hash->{doc} ), 'HASH', "BSON::Doc->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # BSON::Raw -> hashref $hash = decode( encode( { doc => bson_raw( encode( {@kv} ) ) } ) ); is( ref( $hash->{doc} ), 'HASH', "BSON::Raw->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # MongoDB::BSON::Raw -> hashref my $raw = encode( {@kv} ); $hash = decode( encode( { doc => bless \$raw, "MongoDB::BSON::Raw" } ) ); is( ref( $hash->{doc} ), 'HASH', "MongoDB::BSON::Raw->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # Tie::IxHash tied hashref tie my %ixhash, 'Tie::IxHash', @kv; $hash = decode( encode( { doc => \%ixhash } ) ); is( ref( $hash->{doc} ), 'HASH', "Tie::IxHash(tied)->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # Tie::IxHash object my $ixdoc = Tie::IxHash->new(@kv); $hash = decode( encode( { doc => $ixdoc } ) ); is( ref( $hash->{doc} ), 'HASH', "Tie::IxHash(OO)->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); }; subtest "Nested" => sub { # hashref -> hashref $hash = decode( encode( bson_doc( doc => {@kv} ) ) ); is( ref( $hash->{doc} ), 'HASH', "hashref->hashref" ); is_deeply( $hash, { doc => {@kv} }, "value correct" ); # BSON::Doc -> hashref $hash = decode( encode( bson_doc( doc => bson_doc(@kv) ) ) ); is( ref( $hash->{doc} ), 'HASH', "BSON::Doc->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # BSON::Raw -> hashref $hash = decode( encode( bson_doc( doc => bson_raw( encode( {@kv} ) ) ) ) ); is( ref( $hash->{doc} ), 'HASH', "BSON::Raw->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # MongoDB::BSON::Raw -> hashref my $raw = encode( {@kv} ); $hash = decode( encode( bson_doc( doc => bless \$raw, "MongoDB::BSON::Raw" ) ) ); is( ref( $hash->{doc} ), 'HASH', "MongoDB::BSON::Raw->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # Tie::IxHash tied hashref tie my %ixhash, 'Tie::IxHash', @kv; $hash = decode( encode( bson_doc( doc => \%ixhash ) ) ); is( ref( $hash->{doc} ), 'HASH', "Tie::IxHash(tied)->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); # Tie::IxHash object my $ixdoc = Tie::IxHash->new(@kv); $hash = decode( encode( bson_doc( doc => $ixdoc ) ) ); is( ref( $hash->{doc} ), 'HASH', "Tie::IxHash(OO)->hashref" ); is_deeply( $hash->{doc}, {@kv}, "value correct" ); }; subtest "Ordered top level doc" => sub { # hashref -> hashref $hash = decode( encode( {@kv} ), ordered => 1 ); is( ref($hash), 'HASH', "hashref->hashref(ordered)" ); ok( tied(%$hash), "hashref is tied" ); is_deeply( $hash, {@kv}, "value correct" ); # BSON::Doc -> hashref $hash = decode( encode( bson_doc( @kv, C => 'D' ) ), ordered => 1 ); tie my %ixhash, 'Tie::IxHash', @kv, C => 'D'; is( ref($hash), 'HASH', "BSON::Doc->hashref" ); ok( tied(%$hash), "hashref is tied" ); is_deeply( $hash, \%ixhash, "value correct" ); # Unicode keys my $key = "\x{263a}"; $hash = decode( encode( bson_doc( @kv, $key => 'D' ) ), ordered => 1 ); tie my %ixhash2, 'Tie::IxHash', @kv, $key => 'D'; is( ref($hash), 'HASH', "BSON::Doc->hashref" ); ok( tied(%$hash), "hashref is tied" ); is_deeply( $hash, \%ixhash2, "value correct" ); }; subtest "Ordered subdoc" => sub { # hashref -> hashref $hash = decode( encode( { doc => {@kv} } ), ordered => 1 ); is( ref( $hash->{doc} ), 'HASH', "hashref->hashref" ); ok( tied( %{ $hash->{doc} } ), "hashref is tied" ); is_deeply( $hash, { doc => {@kv} }, "value correct" ); # BSON::Doc -> hashref $hash = decode( encode( { doc => bson_doc( @kv, C => 'D' ) } ), ordered => 1 ); tie my %ixhash, 'Tie::IxHash', @kv, C => 'D'; is( ref( $hash->{doc} ), 'HASH', "BSON::Doc->hashref" ); ok( tied( %{ $hash->{doc} } ), "hashref is tied" ); is_deeply( $hash->{doc}, \%ixhash, "value correct" ); }; # TODO: # Hash::Ordered to hashref done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/int32.t000644 000765 000024 00000007022 13524525151 016003 0ustar00davidstaff000000 000000 use 5.0001; use strict; use warnings; use Test::More 0.96; use Math::BigInt; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use JSON::MaybeXS; use BSON qw/encode decode/; use BSON::Types ':all'; my ($hash, $bson, $expect); my $bigpos = Math::BigInt->new("2147483648"); my $bigneg = Math::BigInt->new("-2147483649"); # test constructor packed_is( INT32, bson_int32(), 0, "empty bson_int32() is 0" ); packed_is( INT32, BSON::Int32->new, 0, "empty constructor is 0" ); # test constructor errors; these will wind up doubles on 32-bit platforms eval { bson_int32(2**31) }; like( $@, qr/can't fit/, "bson_int32(2**31) fails" ); eval { bson_int32(-2**31-1) }; like( $@, qr/can't fit/, "bson_int32(-2**31-1) fails" ); # test constructor errors with Math::BigInt eval { bson_int32($bigpos) }; like( $@, qr/can't fit/, "bson_int32(big BigInt) fails" ); eval { bson_int32($bigneg) }; like( $@, qr/can't fit/, "bson_int32(-big BigInt) fails" ); # test overloading packed_is( INT32, bson_int32(314159), 314159, "overloading correct" ); subtest 'native' => sub { # int32 -> int32 $bson = $expect = encode( { A => 314159 } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "int32->int32" ); packed_is( INT32, $hash->{A}, 314159, "value correct" ); # BSON::Int32 -> int32 $bson = encode( { A => bson_int32(314159) } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "BSON::Int32->int32" ); packed_is( INT32, $hash->{A}, 314159, "value correct" ); is( $bson, $expect, "BSON correct" ); # BSON::Int32(string) -> int32 $bson = encode( { A => bson_int32("314159") } ); $hash = decode( $bson ); is( sv_type( $hash->{A} ), 'IV', "BSON::Int32->int32" ); packed_is( INT32, $hash->{A}, 314159, "value correct" ); is( $bson, $expect, "BSON correct" ); }; subtest 'wrapped' => sub { # int32 -> BSON::Int32 $bson = $expect = encode( { A => 314159 } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int32', "int32->BSON::Int32" ); packed_is( INT32, $hash->{A}, 314159, "value correct" ); # BSON::Int32 -> BSON::Int32 $bson = encode( { A => bson_int32(314159) } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int32', "int32->BSON::Int32" ); packed_is( INT32, $hash->{A}, 314159, "value correct" ); is( $bson, $expect, "BSON correct" ); # BSON::Int32(string) -> BSON::Int32 $bson = encode( { A => bson_int32("314159") } ); $hash = decode( $bson, wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Int32', "int32->BSON::Int32" ); packed_is( INT32, $hash->{A}, 314159, "value correct" ); is( $bson, $expect, "BSON correct" ); }; # to JSON SKIP: { skip "JSON::PP has trouble with TO_JSON being false", 1 if ref JSON::MaybeXS->new eq 'JSON::PP'; is( to_myjson({a=>bson_int32(0)}), q[{"a":0}], 'bson_int32(0)' ); } is( to_myjson({a=>bson_int32(42)}), q[{"a":42}], 'bson_int32(42)' ); # to extended JSON SKIP: { skip "JSON::PP has trouble with TO_JSON being false", 1 if ref JSON::MaybeXS->new eq 'JSON::PP'; is( to_extjson({a=>bson_int32(0)}), q[{"a":{"$numberInt":"0"}}], 'extjson: bson_int32(0)' ); } is( to_extjson({a=>bson_int32(42)}), q[{"a":{"$numberInt":"42"}}], 'extjson: bson_int32(42)' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/boolean.t000644 000765 000024 00000003117 13524525151 016464 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; use boolean; my ( $bson, $expect, $hash ); # test constructor isa_ok( bson_bool(), 'boolean', "bson_bool() gives boolean.pm" ); isa_ok( bson_bool(0), 'boolean', "bson_bool(0) gives boolean.pm" ); isa_ok( bson_bool(1), 'boolean', "bson_bool(1) gives boolean.pm" ); # test overloading ok( !bson_bool(), "bson_bool() is false" ); ok( !bson_bool(0), "bson_bool(0) is false" ); ok( bson_bool(1), "bson_bool(1) is true" ); # boolean -> boolean $bson = $expect = encode( { A => true } ); $hash = decode($bson); is( ref( $hash->{A} ), 'boolean', "boolean->boolean" ); ok( $hash->{A}, "value is correct" ); # mock various classes we support my @mocks = qw( BSON::Bool JSON::XS::Boolean JSON::PP::Boolean JSON::Tiny::_Bool Mojo::JSON::_Bool Cpanel::JSON::XS::Boolean Types::Serialiser::Boolean ); for my $c ( @mocks ) { my $bool = bless \(my $b = 1), $c; $bson = encode( { A => $bool } ); $hash = decode($bson); is( ref( $hash->{A} ), 'boolean', "$c->boolean" ); ok( $hash->{A}, "value is correct" ); is($bson, $expect, "BSON is correct" ); } done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/double.t000644 000765 000024 00000007502 13524525151 016321 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types qw/bson_double/; use JSON::MaybeXS; my ($hash); # test constructor packed_is( FLOAT, bson_double(), 0.0, "empty bson_double() is 0.0" ); packed_is( FLOAT, BSON::Double->new, 0.0, "empty constructor is 0.0" ); # test overloading packed_is( FLOAT, bson_double(3.14159), 3.14159, "overloading correct" ); # double -> double $hash = decode( encode( { A => 3.14159 } ) ); is( sv_type( $hash->{A} ), 'NV', "double->double" ); packed_is( FLOAT, $hash->{A}, 3.14159, "value correct" ); # BSON::Double -> double $hash = decode( encode( { A => bson_double(3.14159) } ) ); is( sv_type( $hash->{A} ), 'NV', "BSON::Double->double" ); packed_is( FLOAT, $hash->{A}, 3.14159, "value correct" ); # double -> BSON::Double $hash = decode( encode( { A => 3.14159 } ), wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Double', "double->BSON::Double" ); packed_is( FLOAT, $hash->{A}->value, 3.14159, "value correct" ); # BSON::Double -> BSON::Double $hash = decode( encode( { A => bson_double(3.14159) } ), wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Double', "BSON::Double->BSON::Double" ); packed_is( FLOAT, $hash->{A}->value, 3.14159, "value correct" ); # test special doubles my %special = ( "Inf" => BSON::Double::pInf(), "-Inf" => BSON::Double::nInf(), "NaN" => BSON::Double::NaN(), ); for my $s ( qw/Inf -Inf NaN/ ) { $hash = decode( encode( { A => $special{$s} } ) ); is( sv_type( $hash->{A} ), 'PVNV', "$s as double->double" ); packed_is( FLOAT, $hash->{A}, $special{$s}, "value correct" ); } for my $s ( qw/Inf -Inf NaN/ ) { $hash = decode( encode( { A => $special{$s} } ), wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Double', "$s as double->BSON::Double" ) or diag explain $hash; packed_is( FLOAT, $hash->{A}, $special{$s}, "value correct" ); } # test special BSON::Double for my $s ( qw/Inf -Inf NaN/ ) { $hash = decode( encode( { A => bson_double($special{$s}) } ) ); is( sv_type( $hash->{A} ), 'PVNV', "$s as BSON::Double->BSON::Double" ); packed_is( FLOAT, $hash->{A}, $special{$s}, "value correct" ); } for my $s ( qw/Inf -Inf NaN/ ) { $hash = decode( encode( { A => bson_double($special{$s}) } ), wrap_numbers => 1 ); is( ref( $hash->{A} ), 'BSON::Double', "$s as BSON::Double->BSON::Double" ) or diag explain $hash; packed_is( FLOAT, $hash->{A}, $special{$s}, "value correct" ); } # to JSON # Depending on the JSON parser (and version), .0 might get encoded in various # lossy ways, so we check with a regex for any of the various things we might see like( to_myjson({a=>bson_double(0.0)}), qr/\{"a":(?:0\.0|"0"|0)\}/, 'bson_double(0.0) (XXX lossy!)' ); like( to_myjson({a=>bson_double(42)}), qr/\{"a":(?:42\.0|"42"|42)\}/, 'bson_double(42) (XXX lossy!)' ); is( to_myjson({a=>bson_double(0.1)}), q[{"a":0.1}], 'bson_double(0.1)' ); eval { to_myjson({a=>bson_double(BSON::Double::pInf())}) }; like( $@, qr/illegal in JSON/, 'throws: bson_double(BSON::Double:pInf())' ); # to extended JSON; XXX not implemented yet by mognod; # see https://jira.mongodb.org/browse/SERVER-23204 ##is( to_extjson({a=>bson_double(0.0)}), q[{"a":0}], 'extjson: bson_double(0.0) (XXX lossy!)' ); ##is( to_extjson({a=>bson_double(42)}), q[{"a":42}], 'extjson: bson_double(42) (XXX lossy!)' ); ##is( to_extjson({a=>bson_double(0.1)}), q[{"a":0.1}], 'extjson: bson_double(0.1)' ); ##is( to_extjson({a=>bson_double("Inf"/1.0)}), q[{"a":{"$numberDouble":"Inf"}}], 'extjson: bson_double("Inf"/1.0)' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/decimal128.t000644 000765 000024 00000003345 13524525151 016701 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; use JSON::MaybeXS; my ($hash); # test constructor is( bson_decimal128(), "0", "empty bson_decimal128() is 0" ); eval { BSON::Decimal128->new }; ok( $@, "BSON::Decimal128->new throws" ); # test overloading is( bson_decimal128("3.14159"), "3.14159", "overloading correct" ); # BSON::Decimal128 -> BSON::Decimal128 $hash = decode( encode( { A => bson_decimal128("3.14159") } ) ); is( ref( $hash->{A} ), 'BSON::Decimal128', "BSON::Decimal128->BSON::Decimal128" ); is( $hash->{A}->value, "3.14159", "value correct" ); # test special decimal128s for my $s ( qw/Infinity -Infinity NaN/ ) { $hash = decode( encode( { A => bson_decimal128($s) } ) ); is( $hash->{A}->value, $s, "$s value correct" ); } # to JSON is( to_myjson( { a => bson_decimal128("0.0") } ), q[{"a":"0.0"}], 'bson_decimal128(0.0)' ); is( to_myjson( { a => bson_decimal128("42") } ), q[{"a":"42"}], 'bson_decimal128(42)' ); is( to_myjson( { a => bson_decimal128("0.1") } ), q[{"a":"0.1"}], 'bson_decimal128(0.1)' ); # to extended JSON is( to_extjson( { a => bson_decimal128("0.0") } ), q[{"a":{"$numberDecimal":"0.0"}}], 'bson_decimal128(0.0)' ); # normalizes representation is( to_extjson( { a => bson_decimal128("12345678E678") } ), q[{"a":{"$numberDecimal":"1.2345678E+685"}}], 'bson_decimal128(12345678E+678)' ); done_testing; # # This file is part of BSON # # This software is Copyright (c) 2019 by Stefan G. and MongoDB, Inc. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # # vim: set ts=4 sts=4 sw=4 et tw=75: BSON-v1.12.1/t/mapping/timestamp.t000644 000765 000024 00000010177 13524525151 017054 0ustar00davidstaff000000 000000 use 5.008001; use strict; use warnings; use utf8; use Test::More 0.96; binmode( Test::More->builder->$_, ":utf8" ) for qw/output failure_output todo_output/; use lib 't/lib'; use lib 't/pvtlib'; use CleanEnv; use TestUtils; use BSON qw/encode decode/; use BSON::Types ':all'; my ($bson, $expect, $hash); my $seconds = time; my $increment = 42; # test constructor ok( bson_timestamp()->seconds >= $seconds, "bson_timestamp()->seconds" ); is( bson_timestamp()->increment, 0, "bson_timestamp()->increment" ); is( bson_timestamp($seconds)->seconds, $seconds, "bson_timestamp(seconds)->seconds" ); is( bson_timestamp($seconds)->increment, 0, "bson_timestamp(seconds)->increment" ); is( bson_timestamp( $seconds, $increment )->seconds, $seconds, "bson_timestamp(seconds, increment)->seconds" ); is( bson_timestamp( $seconds, $increment )->increment, $increment, "bson_timestamp(seconds, increment)->increment" ); ok( BSON::Timestamp->new()->seconds >= $seconds, "BSON::Timestamp->new()->seconds" ); is( BSON::Timestamp->new()->increment, 0, "BSON::Timestamp->new()->increment" ); is( BSON::Timestamp->new( seconds => $seconds )->seconds, $seconds, "BSON::Timestamp->new(seconds)->seconds" ); is( BSON::Timestamp->new( seconds => $seconds )->increment, 0, "BSON::Timestamp->new(seconds)->increment" ); is( BSON::Timestamp->new( seconds => $seconds, increment => $increment )->seconds, $seconds, "BSON::Timestamp->new(seconds, increment)->seconds" ); is( BSON::Timestamp->new( seconds => $seconds, increment => $increment )->increment , $increment, "BSON::Timestamp->new(seconds, increment)->increment" ); # test constructor range errors eval { bson_timestamp(2**32, $increment) }; like( $@, qr/must be uint32/, "bson_timestamp(2**32, 42) fails" ); eval { bson_timestamp(-1, $increment) }; like( $@, qr/must be uint32/, "bson_timestamp(-1, 42) fails" ); eval { bson_timestamp($seconds, 2**32) }; like( $@, qr/must be uint32/, "bson_timestamp(