--- /dev/null
+Revision history for File-KDBX.
+
+0.800 2022-04-30 21:14:30-0600
+
+ * Initial release
+
--- /dev/null
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+Terms of the Perl programming language system itself
+
+a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+b) the "Artistic License"
+
+--- The GNU General Public License, Version 1, February 1989 ---
+
+This software is Copyright (c) 2022 by Charles McGarvey.
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 1, February 1989
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
+--- The Artistic License 1.0 ---
+
+This software is Copyright (c) 2022 by Charles McGarvey.
+
+This is free software, licensed under:
+
+ The Artistic License 1.0
+
+The Artistic License
+
+Preamble
+
+The intent of this document is to state the conditions under which a Package
+may be copied, such that the Copyright Holder maintains some semblance of
+artistic control over the development of the package, while giving the users of
+the package the right to use and distribute the Package in a more-or-less
+customary fashion, plus the right to make reasonable modifications.
+
+Definitions:
+
+ - "Package" refers to the collection of files distributed by the Copyright
+ Holder, and derivatives of that collection of files created through
+ textual modification.
+ - "Standard Version" refers to such a Package if it has not been modified,
+ or has been modified in accordance with the wishes of the Copyright
+ Holder.
+ - "Copyright Holder" is whoever is named in the copyright or copyrights for
+ the package.
+ - "You" is you, if you're thinking about copying or distributing this Package.
+ - "Reasonable copying fee" is whatever you can justify on the basis of media
+ cost, duplication charges, time of people involved, and so on. (You will
+ not be required to justify it to the Copyright Holder, but only to the
+ computing community at large as a market that must bear the fee.)
+ - "Freely Available" means that no fee is charged for the item itself, though
+ there may be fees involved in handling the item. It also means that
+ recipients of the item may redistribute it under the same conditions they
+ received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications derived
+from the Public Domain or from the Copyright Holder. A Package modified in such
+a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided that
+you insert a prominent notice in each changed file stating how and when you
+changed that file, and provided that you do at least ONE of the following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or an
+ equivalent medium, or placing the modifications on a major archive site
+ such as ftp.uu.net, or by allowing the Copyright Holder to include your
+ modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict with
+ standard executables, which must also be provided, and provide a separate
+ manual page for each non-standard executable that clearly documents how it
+ differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or executable
+form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where to
+ get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of the Package
+ with your modifications.
+
+ c) accompany any non-standard executables with their corresponding Standard
+ Version executables, giving the non-standard executables non-standard
+ names, and clearly documenting the differences in manual pages (or
+ equivalent), together with instructions on where to get the Standard
+ Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this Package. You
+may not charge a fee for this Package itself. However, you may distribute this
+Package in aggregate with other (possibly commercial) programs as part of a
+larger (possibly commercial) software distribution provided that you do not
+advertise this Package as a product of your own.
+
+6. The scripts and library files supplied as input to or produced as output
+from the programs of this Package do not automatically fall under the copyright
+of this Package, but belong to whomever generated them, and may be sold
+commercially, and may be aggregated with this Package.
+
+7. C or perl subroutines supplied by you and linked into this Package shall not
+be considered part of this Package.
+
+8. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+The End
+
--- /dev/null
+# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.024.
+Changes
+LICENSE
+MANIFEST
+META.json
+META.yml
+Makefile.PL
+README
+lib/File/KDBX.pm
+lib/File/KDBX/Cipher.pm
+lib/File/KDBX/Cipher/CBC.pm
+lib/File/KDBX/Cipher/Stream.pm
+lib/File/KDBX/Constants.pm
+lib/File/KDBX/Dumper.pm
+lib/File/KDBX/Dumper/KDB.pm
+lib/File/KDBX/Dumper/Raw.pm
+lib/File/KDBX/Dumper/V3.pm
+lib/File/KDBX/Dumper/V4.pm
+lib/File/KDBX/Dumper/XML.pm
+lib/File/KDBX/Entry.pm
+lib/File/KDBX/Error.pm
+lib/File/KDBX/Group.pm
+lib/File/KDBX/IO.pm
+lib/File/KDBX/IO/Crypt.pm
+lib/File/KDBX/IO/HashBlock.pm
+lib/File/KDBX/IO/HmacBlock.pm
+lib/File/KDBX/Iterator.pm
+lib/File/KDBX/KDF.pm
+lib/File/KDBX/KDF/AES.pm
+lib/File/KDBX/KDF/Argon2.pm
+lib/File/KDBX/Key.pm
+lib/File/KDBX/Key/ChallengeResponse.pm
+lib/File/KDBX/Key/Composite.pm
+lib/File/KDBX/Key/File.pm
+lib/File/KDBX/Key/Password.pm
+lib/File/KDBX/Key/YubiKey.pm
+lib/File/KDBX/Loader.pm
+lib/File/KDBX/Loader/KDB.pm
+lib/File/KDBX/Loader/Raw.pm
+lib/File/KDBX/Loader/V3.pm
+lib/File/KDBX/Loader/V4.pm
+lib/File/KDBX/Loader/XML.pm
+lib/File/KDBX/Object.pm
+lib/File/KDBX/Safe.pm
+lib/File/KDBX/Transaction.pm
+lib/File/KDBX/Util.pm
+perlcritic.rc
+t/00-compile.t
+t/00-report-prereqs.dd
+t/00-report-prereqs.t
+t/crypt.t
+t/database.t
+t/entry.t
+t/erase.t
+t/error.t
+t/files/BrokenHeaderHash.kdbx
+t/files/CP-1252.kdb
+t/files/CompositeKey.kdb
+t/files/Compressed.kdbx
+t/files/FileKeyBinary.kdb
+t/files/FileKeyBinary.kdbx
+t/files/FileKeyBinary.key
+t/files/FileKeyHashed.kdb
+t/files/FileKeyHashed.kdbx
+t/files/FileKeyHashed.key
+t/files/FileKeyHex.kdb
+t/files/FileKeyHex.kdbx
+t/files/FileKeyHex.key
+t/files/Format200.kdbx
+t/files/Format300.kdbx
+t/files/Format400.kdbx
+t/files/MemoryProtection.kdbx
+t/files/NonAscii.kdbx
+t/files/ProtectedStrings.kdbx
+t/files/Twofish.kdb
+t/files/basic.kdb
+t/files/bin/ykchalresp
+t/files/bin/ykinfo
+t/files/keys/binary.key
+t/files/keys/hashed.key
+t/files/keys/hex.key
+t/files/keys/xmlv1.key
+t/files/keys/xmlv2.key
+t/group.t
+t/hash-block.t
+t/hmac-block.t
+t/iterator.t
+t/kdb.t
+t/kdbx2.t
+t/kdbx3.t
+t/kdbx4.t
+t/kdf-aes-pp.t
+t/kdf.t
+t/keys.t
+t/lib/TestCommon.pm
+t/memory-protection.t
+t/object.t
+t/otp.t
+t/placeholders.t
+t/query.t
+t/references.t
+t/safe.t
+t/util.t
+t/yubikey.t
+xt/author/clean-namespaces.t
+xt/author/critic.t
+xt/author/distmeta.t
+xt/author/eol.t
+xt/author/minimum-version.t
+xt/author/no-tabs.t
+xt/author/pod-coverage.t
+xt/author/pod-no404s.t
+xt/author/pod-syntax.t
+xt/author/portability.t
+xt/release/cpan-changes.t
--- /dev/null
+{
+ "abstract" : "Encrypted database to store secret text and files",
+ "author" : [
+ "Charles McGarvey <ccm@cpan.org>"
+ ],
+ "dynamic_config" : 0,
+ "generated_by" : "Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : 2
+ },
+ "name" : "File-KDBX",
+ "no_index" : {
+ "directory" : [
+ "eg",
+ "share",
+ "shares",
+ "t",
+ "xt"
+ ]
+ },
+ "optional_features" : {
+ "compression" : {
+ "description" : "ability to read and write compressed KDBX files",
+ "prereqs" : {
+ "runtime" : {
+ "requires" : {
+ "Compress::Raw::Zlib" : "0",
+ "IO::Compress::Gzip" : "0",
+ "IO::Uncompress::Gunzip" : "0"
+ }
+ }
+ }
+ },
+ "otp" : {
+ "description" : "ability to generate one-time passwords from configured database entries",
+ "prereqs" : {
+ "runtime" : {
+ "requires" : {
+ "Pass::OTP" : "0"
+ }
+ }
+ }
+ },
+ "xs" : {
+ "description" : "speed improvements (requires C compiler)",
+ "prereqs" : {
+ "runtime" : {
+ "requires" : {
+ "File::KDBX::XS" : "0"
+ }
+ }
+ }
+ }
+ },
+ "prereqs" : {
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "develop" : {
+ "requires" : {
+ "Compress::Raw::Zlib" : "0",
+ "Dist::Zilla" : "5",
+ "Dist::Zilla::Plugin::Encoding" : "0",
+ "Dist::Zilla::Plugin::OptionalFeature" : "0",
+ "Dist::Zilla::Plugin::Prereqs" : "0",
+ "Dist::Zilla::Plugin::Prereqs::Soften" : "0",
+ "Dist::Zilla::PluginBundle::Author::CCM" : "0",
+ "File::KDBX::XS" : "0",
+ "IO::Compress::Gzip" : "0",
+ "IO::Uncompress::Gunzip" : "0",
+ "Pass::OTP" : "0",
+ "Pod::Coverage::TrustPod" : "0",
+ "Software::License::Perl_5" : "0",
+ "Test::CPAN::Changes" : "0.19",
+ "Test::CPAN::Meta" : "0",
+ "Test::CleanNamespaces" : "0.15",
+ "Test::EOL" : "0",
+ "Test::MinimumVersion" : "0",
+ "Test::More" : "0.96",
+ "Test::NoTabs" : "0",
+ "Test::Perl::Critic" : "0",
+ "Test::Pod" : "1.41",
+ "Test::Pod::Coverage" : "1.08",
+ "Test::Pod::No404s" : "0",
+ "Test::Portability::Files" : "0"
+ }
+ },
+ "runtime" : {
+ "recommends" : {
+ "Compress::Raw::Zlib" : "0",
+ "File::KDBX::XS" : "0",
+ "File::Spec" : "0",
+ "IO::Compress::Gzip" : "0",
+ "IO::Uncompress::Gunzip" : "0",
+ "Pass::OTP" : "0"
+ },
+ "requires" : {
+ "Carp" : "0",
+ "Crypt::Argon2" : "0",
+ "Crypt::Cipher" : "0",
+ "Crypt::Digest" : "0",
+ "Crypt::Mac::HMAC" : "0",
+ "Crypt::Misc" : "0.029",
+ "Crypt::Mode::CBC" : "0",
+ "Crypt::PRNG" : "0",
+ "Data::Dumper" : "0",
+ "Devel::GlobalDestruction" : "0",
+ "Encode" : "0",
+ "Exporter" : "0",
+ "File::Temp" : "0",
+ "Hash::Util::FieldHash" : "0",
+ "IO::Handle" : "0",
+ "IPC::Cmd" : "0.52",
+ "Iterator::Simple" : "0",
+ "Iterator::Simple::Iterator" : "0",
+ "List::Util" : "1.33",
+ "Module::Load" : "0",
+ "Module::Loaded" : "0",
+ "POSIX" : "0",
+ "Ref::Util" : "0",
+ "Scalar::Util" : "0",
+ "Scope::Guard" : "0",
+ "Storable" : "0",
+ "Symbol" : "0",
+ "Text::ParseWords" : "0",
+ "Time::Piece" : "0",
+ "XML::LibXML" : "0",
+ "XML::LibXML::Reader" : "0",
+ "boolean" : "0",
+ "namespace::clean" : "0",
+ "overload" : "0",
+ "strict" : "0",
+ "warnings" : "0"
+ }
+ },
+ "test" : {
+ "recommends" : {
+ "CPAN::Meta" : "2.120900",
+ "Pass::OTP" : "0"
+ },
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0",
+ "File::Spec" : "0",
+ "FindBin" : "0",
+ "Getopt::Std" : "0",
+ "IO::Handle" : "0",
+ "IPC::Open3" : "0",
+ "Test::Deep" : "0",
+ "Test::Fatal" : "0",
+ "Test::More" : "0",
+ "Test::Warnings" : "0",
+ "lib" : "0",
+ "perl" : "5.006",
+ "utf8" : "0"
+ },
+ "suggests" : {
+ "POSIX::1003" : "0"
+ }
+ }
+ },
+ "provides" : {
+ "File::KDBX" : {
+ "file" : "lib/File/KDBX.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Cipher" : {
+ "file" : "lib/File/KDBX/Cipher.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Cipher::CBC" : {
+ "file" : "lib/File/KDBX/Cipher/CBC.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Cipher::Stream" : {
+ "file" : "lib/File/KDBX/Cipher/Stream.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Constants" : {
+ "file" : "lib/File/KDBX/Constants.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Dumper" : {
+ "file" : "lib/File/KDBX/Dumper.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Dumper::KDB" : {
+ "file" : "lib/File/KDBX/Dumper/KDB.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Dumper::Raw" : {
+ "file" : "lib/File/KDBX/Dumper/Raw.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Dumper::V3" : {
+ "file" : "lib/File/KDBX/Dumper/V3.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Dumper::V4" : {
+ "file" : "lib/File/KDBX/Dumper/V4.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Dumper::XML" : {
+ "file" : "lib/File/KDBX/Dumper/XML.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Entry" : {
+ "file" : "lib/File/KDBX/Entry.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Error" : {
+ "file" : "lib/File/KDBX/Error.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Group" : {
+ "file" : "lib/File/KDBX/Group.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::IO" : {
+ "file" : "lib/File/KDBX/IO.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::IO::Crypt" : {
+ "file" : "lib/File/KDBX/IO/Crypt.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::IO::HashBlock" : {
+ "file" : "lib/File/KDBX/IO/HashBlock.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::IO::HmacBlock" : {
+ "file" : "lib/File/KDBX/IO/HmacBlock.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Iterator" : {
+ "file" : "lib/File/KDBX/Iterator.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::KDF" : {
+ "file" : "lib/File/KDBX/KDF.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::KDF::AES" : {
+ "file" : "lib/File/KDBX/KDF/AES.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::KDF::Argon2" : {
+ "file" : "lib/File/KDBX/KDF/Argon2.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Key" : {
+ "file" : "lib/File/KDBX/Key.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Key::ChallengeResponse" : {
+ "file" : "lib/File/KDBX/Key/ChallengeResponse.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Key::Composite" : {
+ "file" : "lib/File/KDBX/Key/Composite.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Key::File" : {
+ "file" : "lib/File/KDBX/Key/File.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Key::Password" : {
+ "file" : "lib/File/KDBX/Key/Password.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Key::YubiKey" : {
+ "file" : "lib/File/KDBX/Key/YubiKey.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Loader" : {
+ "file" : "lib/File/KDBX/Loader.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Loader::KDB" : {
+ "file" : "lib/File/KDBX/Loader/KDB.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Loader::Raw" : {
+ "file" : "lib/File/KDBX/Loader/Raw.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Loader::V3" : {
+ "file" : "lib/File/KDBX/Loader/V3.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Loader::V4" : {
+ "file" : "lib/File/KDBX/Loader/V4.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Loader::XML" : {
+ "file" : "lib/File/KDBX/Loader/XML.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Object" : {
+ "file" : "lib/File/KDBX/Object.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Safe" : {
+ "file" : "lib/File/KDBX/Safe.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Transaction" : {
+ "file" : "lib/File/KDBX/Transaction.pm",
+ "version" : "0.800"
+ },
+ "File::KDBX::Util" : {
+ "file" : "lib/File/KDBX/Util.pm",
+ "version" : "0.800"
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/chazmcgarvey/File-KDBX/issues"
+ },
+ "homepage" : "https://github.com/chazmcgarvey/File-KDBX",
+ "repository" : {
+ "type" : "git",
+ "url" : "https://github.com/chazmcgarvey/File-KDBX.git",
+ "web" : "https://github.com/chazmcgarvey/File-KDBX"
+ }
+ },
+ "version" : "0.800",
+ "x_authority" : "cpan:CCM",
+ "x_generated_by_perl" : "v5.34.1",
+ "x_serialization_backend" : "Cpanel::JSON::XS version 4.27",
+ "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later"
+}
+
--- /dev/null
+---
+abstract: 'Encrypted database to store secret text and files'
+author:
+ - 'Charles McGarvey <ccm@cpan.org>'
+build_requires:
+ ExtUtils::MakeMaker: '0'
+ File::Spec: '0'
+ FindBin: '0'
+ Getopt::Std: '0'
+ IO::Handle: '0'
+ IPC::Open3: '0'
+ Test::Deep: '0'
+ Test::Fatal: '0'
+ Test::More: '0'
+ Test::Warnings: '0'
+ lib: '0'
+ perl: '5.006'
+ utf8: '0'
+configure_requires:
+ ExtUtils::MakeMaker: '0'
+dynamic_config: 0
+generated_by: 'Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: '1.4'
+name: File-KDBX
+no_index:
+ directory:
+ - eg
+ - share
+ - shares
+ - t
+ - xt
+optional_features:
+ compression:
+ description: 'ability to read and write compressed KDBX files'
+ requires:
+ Compress::Raw::Zlib: '0'
+ IO::Compress::Gzip: '0'
+ IO::Uncompress::Gunzip: '0'
+ otp:
+ description: 'ability to generate one-time passwords from configured database entries'
+ requires:
+ Pass::OTP: '0'
+ xs:
+ description: 'speed improvements (requires C compiler)'
+ requires:
+ File::KDBX::XS: '0'
+provides:
+ File::KDBX:
+ file: lib/File/KDBX.pm
+ version: '0.800'
+ File::KDBX::Cipher:
+ file: lib/File/KDBX/Cipher.pm
+ version: '0.800'
+ File::KDBX::Cipher::CBC:
+ file: lib/File/KDBX/Cipher/CBC.pm
+ version: '0.800'
+ File::KDBX::Cipher::Stream:
+ file: lib/File/KDBX/Cipher/Stream.pm
+ version: '0.800'
+ File::KDBX::Constants:
+ file: lib/File/KDBX/Constants.pm
+ version: '0.800'
+ File::KDBX::Dumper:
+ file: lib/File/KDBX/Dumper.pm
+ version: '0.800'
+ File::KDBX::Dumper::KDB:
+ file: lib/File/KDBX/Dumper/KDB.pm
+ version: '0.800'
+ File::KDBX::Dumper::Raw:
+ file: lib/File/KDBX/Dumper/Raw.pm
+ version: '0.800'
+ File::KDBX::Dumper::V3:
+ file: lib/File/KDBX/Dumper/V3.pm
+ version: '0.800'
+ File::KDBX::Dumper::V4:
+ file: lib/File/KDBX/Dumper/V4.pm
+ version: '0.800'
+ File::KDBX::Dumper::XML:
+ file: lib/File/KDBX/Dumper/XML.pm
+ version: '0.800'
+ File::KDBX::Entry:
+ file: lib/File/KDBX/Entry.pm
+ version: '0.800'
+ File::KDBX::Error:
+ file: lib/File/KDBX/Error.pm
+ version: '0.800'
+ File::KDBX::Group:
+ file: lib/File/KDBX/Group.pm
+ version: '0.800'
+ File::KDBX::IO:
+ file: lib/File/KDBX/IO.pm
+ version: '0.800'
+ File::KDBX::IO::Crypt:
+ file: lib/File/KDBX/IO/Crypt.pm
+ version: '0.800'
+ File::KDBX::IO::HashBlock:
+ file: lib/File/KDBX/IO/HashBlock.pm
+ version: '0.800'
+ File::KDBX::IO::HmacBlock:
+ file: lib/File/KDBX/IO/HmacBlock.pm
+ version: '0.800'
+ File::KDBX::Iterator:
+ file: lib/File/KDBX/Iterator.pm
+ version: '0.800'
+ File::KDBX::KDF:
+ file: lib/File/KDBX/KDF.pm
+ version: '0.800'
+ File::KDBX::KDF::AES:
+ file: lib/File/KDBX/KDF/AES.pm
+ version: '0.800'
+ File::KDBX::KDF::Argon2:
+ file: lib/File/KDBX/KDF/Argon2.pm
+ version: '0.800'
+ File::KDBX::Key:
+ file: lib/File/KDBX/Key.pm
+ version: '0.800'
+ File::KDBX::Key::ChallengeResponse:
+ file: lib/File/KDBX/Key/ChallengeResponse.pm
+ version: '0.800'
+ File::KDBX::Key::Composite:
+ file: lib/File/KDBX/Key/Composite.pm
+ version: '0.800'
+ File::KDBX::Key::File:
+ file: lib/File/KDBX/Key/File.pm
+ version: '0.800'
+ File::KDBX::Key::Password:
+ file: lib/File/KDBX/Key/Password.pm
+ version: '0.800'
+ File::KDBX::Key::YubiKey:
+ file: lib/File/KDBX/Key/YubiKey.pm
+ version: '0.800'
+ File::KDBX::Loader:
+ file: lib/File/KDBX/Loader.pm
+ version: '0.800'
+ File::KDBX::Loader::KDB:
+ file: lib/File/KDBX/Loader/KDB.pm
+ version: '0.800'
+ File::KDBX::Loader::Raw:
+ file: lib/File/KDBX/Loader/Raw.pm
+ version: '0.800'
+ File::KDBX::Loader::V3:
+ file: lib/File/KDBX/Loader/V3.pm
+ version: '0.800'
+ File::KDBX::Loader::V4:
+ file: lib/File/KDBX/Loader/V4.pm
+ version: '0.800'
+ File::KDBX::Loader::XML:
+ file: lib/File/KDBX/Loader/XML.pm
+ version: '0.800'
+ File::KDBX::Object:
+ file: lib/File/KDBX/Object.pm
+ version: '0.800'
+ File::KDBX::Safe:
+ file: lib/File/KDBX/Safe.pm
+ version: '0.800'
+ File::KDBX::Transaction:
+ file: lib/File/KDBX/Transaction.pm
+ version: '0.800'
+ File::KDBX::Util:
+ file: lib/File/KDBX/Util.pm
+ version: '0.800'
+recommends:
+ Compress::Raw::Zlib: '0'
+ File::KDBX::XS: '0'
+ File::Spec: '0'
+ IO::Compress::Gzip: '0'
+ IO::Uncompress::Gunzip: '0'
+ Pass::OTP: '0'
+requires:
+ Carp: '0'
+ Crypt::Argon2: '0'
+ Crypt::Cipher: '0'
+ Crypt::Digest: '0'
+ Crypt::Mac::HMAC: '0'
+ Crypt::Misc: '0.029'
+ Crypt::Mode::CBC: '0'
+ Crypt::PRNG: '0'
+ Data::Dumper: '0'
+ Devel::GlobalDestruction: '0'
+ Encode: '0'
+ Exporter: '0'
+ File::Temp: '0'
+ Hash::Util::FieldHash: '0'
+ IO::Handle: '0'
+ IPC::Cmd: '0.52'
+ Iterator::Simple: '0'
+ Iterator::Simple::Iterator: '0'
+ List::Util: '1.33'
+ Module::Load: '0'
+ Module::Loaded: '0'
+ POSIX: '0'
+ Ref::Util: '0'
+ Scalar::Util: '0'
+ Scope::Guard: '0'
+ Storable: '0'
+ Symbol: '0'
+ Text::ParseWords: '0'
+ Time::Piece: '0'
+ XML::LibXML: '0'
+ XML::LibXML::Reader: '0'
+ boolean: '0'
+ namespace::clean: '0'
+ overload: '0'
+ strict: '0'
+ warnings: '0'
+resources:
+ bugtracker: https://github.com/chazmcgarvey/File-KDBX/issues
+ homepage: https://github.com/chazmcgarvey/File-KDBX
+ repository: https://github.com/chazmcgarvey/File-KDBX.git
+version: '0.800'
+x_authority: cpan:CCM
+x_generated_by_perl: v5.34.1
+x_serialization_backend: 'YAML::Tiny version 1.73'
+x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later'
--- /dev/null
+# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.024.
+use strict;
+use warnings;
+
+use 5.006;
+
+use ExtUtils::MakeMaker;
+
+my %WriteMakefileArgs = (
+ "ABSTRACT" => "Encrypted database to store secret text and files",
+ "AUTHOR" => "Charles McGarvey <ccm\@cpan.org>",
+ "CONFIGURE_REQUIRES" => {
+ "ExtUtils::MakeMaker" => 0
+ },
+ "DISTNAME" => "File-KDBX",
+ "LICENSE" => "perl",
+ "MIN_PERL_VERSION" => "5.006",
+ "NAME" => "File::KDBX",
+ "PREREQ_PM" => {
+ "Carp" => 0,
+ "Crypt::Argon2" => 0,
+ "Crypt::Cipher" => 0,
+ "Crypt::Digest" => 0,
+ "Crypt::Mac::HMAC" => 0,
+ "Crypt::Misc" => "0.029",
+ "Crypt::Mode::CBC" => 0,
+ "Crypt::PRNG" => 0,
+ "Data::Dumper" => 0,
+ "Devel::GlobalDestruction" => 0,
+ "Encode" => 0,
+ "Exporter" => 0,
+ "File::Temp" => 0,
+ "Hash::Util::FieldHash" => 0,
+ "IO::Handle" => 0,
+ "IPC::Cmd" => "0.52",
+ "Iterator::Simple" => 0,
+ "Iterator::Simple::Iterator" => 0,
+ "List::Util" => "1.33",
+ "Module::Load" => 0,
+ "Module::Loaded" => 0,
+ "POSIX" => 0,
+ "Ref::Util" => 0,
+ "Scalar::Util" => 0,
+ "Scope::Guard" => 0,
+ "Storable" => 0,
+ "Symbol" => 0,
+ "Text::ParseWords" => 0,
+ "Time::Piece" => 0,
+ "XML::LibXML" => 0,
+ "XML::LibXML::Reader" => 0,
+ "boolean" => 0,
+ "namespace::clean" => 0,
+ "overload" => 0,
+ "strict" => 0,
+ "warnings" => 0
+ },
+ "TEST_REQUIRES" => {
+ "ExtUtils::MakeMaker" => 0,
+ "File::Spec" => 0,
+ "FindBin" => 0,
+ "Getopt::Std" => 0,
+ "IO::Handle" => 0,
+ "IPC::Open3" => 0,
+ "Test::Deep" => 0,
+ "Test::Fatal" => 0,
+ "Test::More" => 0,
+ "Test::Warnings" => 0,
+ "lib" => 0,
+ "utf8" => 0
+ },
+ "VERSION" => "0.800",
+ "test" => {
+ "TESTS" => "t/*.t"
+ }
+);
+
+
+my %FallbackPrereqs = (
+ "Carp" => 0,
+ "Crypt::Argon2" => 0,
+ "Crypt::Cipher" => 0,
+ "Crypt::Digest" => 0,
+ "Crypt::Mac::HMAC" => 0,
+ "Crypt::Misc" => "0.029",
+ "Crypt::Mode::CBC" => 0,
+ "Crypt::PRNG" => 0,
+ "Data::Dumper" => 0,
+ "Devel::GlobalDestruction" => 0,
+ "Encode" => 0,
+ "Exporter" => 0,
+ "ExtUtils::MakeMaker" => 0,
+ "File::Spec" => 0,
+ "File::Temp" => 0,
+ "FindBin" => 0,
+ "Getopt::Std" => 0,
+ "Hash::Util::FieldHash" => 0,
+ "IO::Handle" => 0,
+ "IPC::Cmd" => "0.52",
+ "IPC::Open3" => 0,
+ "Iterator::Simple" => 0,
+ "Iterator::Simple::Iterator" => 0,
+ "List::Util" => "1.33",
+ "Module::Load" => 0,
+ "Module::Loaded" => 0,
+ "POSIX" => 0,
+ "Ref::Util" => 0,
+ "Scalar::Util" => 0,
+ "Scope::Guard" => 0,
+ "Storable" => 0,
+ "Symbol" => 0,
+ "Test::Deep" => 0,
+ "Test::Fatal" => 0,
+ "Test::More" => 0,
+ "Test::Warnings" => 0,
+ "Text::ParseWords" => 0,
+ "Time::Piece" => 0,
+ "XML::LibXML" => 0,
+ "XML::LibXML::Reader" => 0,
+ "boolean" => 0,
+ "lib" => 0,
+ "namespace::clean" => 0,
+ "overload" => 0,
+ "strict" => 0,
+ "utf8" => 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);
--- /dev/null
+NAME
+
+ File::KDBX - Encrypted database to store secret text and files
+
+VERSION
+
+ version 0.800
+
+SYNOPSIS
+
+ use File::KDBX;
+
+ my $kdbx = File::KDBX->new;
+
+ my $group = $kdbx->add_group(
+ name => 'Passwords',
+ );
+
+ my $entry = $group->add_entry(
+ title => 'My Bank',
+ password => 's3cr3t',
+ );
+
+ $kdbx->dump_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
+
+ $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
+
+ $kdbx->entries->each(sub {
+ my ($entry) = @_;
+ say 'Entry: ', $entry->title;
+ });
+
+ See "RECIPES" for more examples.
+
+DESCRIPTION
+
+ File::KDBX provides everything you need to work with a KDBX database. A
+ KDBX database is a hierarchical object database which is commonly used
+ to store secret information securely. It was developed for the KeePass
+ password safe. See "Introduction to KDBX" for more information about
+ KDBX.
+
+ This module lets you query entries, create new entries, delete entries
+ and modify entries. The distribution also includes various parsers and
+ generators for serializing and persisting databases.
+
+ This design of this software was influenced by the KeePassXC
+ <https://github.com/keepassxreboot/keepassxc> implementation of KeePass
+ as well as the File::KeePass module. File::KeePass is an alternative
+ module that works well in most cases but has a small backlog of bugs
+ and security issues and also does not work with newer KDBX version 4
+ files. If you're coming here from the File::KeePass world, you might be
+ interested in File::KeePass::KDBX that is a drop-in replacement for
+ File::KeePass that uses File::KDBX for storage.
+
+ This software is a pre-1.0 release. The interface should be considered
+ pretty stable, but there might be minor changes up until a 1.0 release.
+ Breaking changes will be noted in the Changes file.
+
+ Features
+
+ This implementation of KDBX supports a lot of features:
+
+ * ☑ Read and write KDBX version 3 - version 4.1
+
+ * ☑ Read and write KDB files (requires File::KeePass)
+
+ * ☑ Unicode character strings
+
+ * ☑ "Simple Expression" Searching
+
+ * ☑ Placeholders and field references
+
+ * ☑ One-time passwords
+
+ * ☑ Very secure
+
+ * ☑ "Memory Protection"
+
+ * ☑ Challenge-response key components, like YubiKey
+
+ * ☑ Variety of key file types: binary, hexed, hashed, XML v1 and v2
+
+ * ☑ Pluggable registration of different kinds of ciphers and key
+ derivation functions
+
+ * ☑ Built-in database maintenance functions
+
+ * ☑ Pretty fast, with XS optimizations available
+
+ * ☒ Database synchronization / merging (not yet)
+
+ Introduction to KDBX
+
+ A KDBX database consists of a tree of groups and entries, with a single
+ root group. Entries can contain zero or more key-value pairs of strings
+ and zero or more binaries (i.e. octet strings). Groups, entries,
+ strings and binaries: that's the KDBX vernacular. A small amount of
+ metadata (timestamps, etc.) is associated with each entry, group and
+ the database as a whole.
+
+ You can think of a KDBX database kind of like a file system, where
+ groups are directories, entries are files, and strings and binaries
+ make up a file's contents.
+
+ Databases are typically persisted as a encrypted, compressed files.
+ They are usually accessed directly (i.e. not over a network). The
+ primary focus of this type of database is data security. It is ideal
+ for storing relatively small amounts of data (strings and binaries)
+ that must remain secret except to such individuals as have the correct
+ master key. Even if the database file were to be "leaked" to the public
+ Internet, it should be virtually impossible to crack with a strong key.
+ The KDBX format is most often used by password managers to store
+ passwords so that users can know a single strong password and not have
+ to reuse passwords across different websites. See "SECURITY" for an
+ overview of security considerations.
+
+ATTRIBUTES
+
+ sig1
+
+ sig2
+
+ version
+
+ headers
+
+ inner_headers
+
+ meta
+
+ binaries
+
+ deleted_objects
+
+ Hash of UUIDs for objects that have been deleted. This includes groups,
+ entries and even custom icons.
+
+ raw
+
+ Bytes contained within the encrypted layer of a KDBX file. This is only
+ set when using File::KDBX::Loader::Raw.
+
+ comment
+
+ A text string associated with the database. Often unset.
+
+ cipher_id
+
+ The UUID of a cipher used to encrypt the database when stored as a
+ file.
+
+ See "File::KDBX::Cipher".
+
+ compression_flags
+
+ Configuration for whether or not and how the database gets compressed.
+ See ":compression" in File::KDBX::Constants.
+
+ master_seed
+
+ The master seed is a string of 32 random bytes that is used as salt in
+ hashing the master key when loading and saving the database. If a
+ challenge-response key is used in the master key, the master seed is
+ also the challenge.
+
+ The master seed should be changed each time the database is saved to
+ file.
+
+ transform_seed
+
+ The transform seed is a string of 32 random bytes that is used in the
+ key derivation function, either as the salt or the key (depending on
+ the algorithm).
+
+ The transform seed should be changed each time the database is saved to
+ file.
+
+ transform_rounds
+
+ The number of rounds or iterations used in the key derivation function.
+ Increasing this number makes loading and saving the database slower by
+ design in order to make dictionary and brute force attacks more costly.
+
+ encryption_iv
+
+ The initialization vector used by the cipher.
+
+ The encryption IV should be changed each time the database is saved to
+ file.
+
+ inner_random_stream_key
+
+ The encryption key (possibly including the IV, depending on the cipher)
+ used to encrypt the protected strings within the database.
+
+ stream_start_bytes
+
+ A string of 32 random bytes written in the header and encrypted in the
+ body. If the bytes do not match when loading a file then the wrong
+ master key was used or the file is corrupt. Only KDBX 2 and KDBX 3
+ files use this. KDBX 4 files use an improved HMAC method to verify the
+ master key and data integrity of the header and entire file body.
+
+ inner_random_stream_id
+
+ A number indicating the cipher algorithm used to encrypt the protected
+ strings within the database, usually Salsa20 or ChaCha20. See
+ ":random_stream" in File::KDBX::Constants.
+
+ kdf_parameters
+
+ A hash/dict of key-value pairs used to configure the key derivation
+ function. This is the KDBX4+ way to configure the KDF, superceding
+ "transform_seed" and "transform_rounds".
+
+ generator
+
+ The name of the software used to generate the KDBX file.
+
+ header_hash
+
+ The header hash used to verify that the file header is not corrupt.
+ (KDBX 2 - KDBX 3.1, removed KDBX 4.0)
+
+ database_name
+
+ Name of the database.
+
+ database_name_changed
+
+ Timestamp indicating when the database name was last changed.
+
+ database_description
+
+ Description of the database
+
+ database_description_changed
+
+ Timestamp indicating when the database description was last changed.
+
+ default_username
+
+ When a new entry is created, the UserName string will be populated with
+ this value.
+
+ default_username_changed
+
+ Timestamp indicating when the default username was last changed.
+
+ maintenance_history_days
+
+ TODO... not really sure what this is. 😀
+
+ color
+
+ A color associated with the database (in the form #ffffff where "f" is
+ a hexidecimal digit). Some agents use this to help users visually
+ distinguish between different databases.
+
+ master_key_changed
+
+ Timestamp indicating when the master key was last changed.
+
+ master_key_change_rec
+
+ Number of days until the agent should prompt to recommend changing the
+ master key.
+
+ master_key_change_force
+
+ Number of days until the agent should prompt to force changing the
+ master key.
+
+ Note: This is purely advisory. It is up to the individual agent
+ software to actually enforce it. File::KDBX does NOT enforce it.
+
+ custom_icons
+
+ Array of custom icons that can be associated with groups and entries.
+
+ This list can be managed with the methods "add_custom_icon" and
+ "remove_custom_icon".
+
+ recycle_bin_enabled
+
+ Boolean indicating whether removed groups and entries should go to a
+ recycle bin or be immediately deleted.
+
+ recycle_bin_uuid
+
+ The UUID of a group used to store thrown-away groups and entries.
+
+ recycle_bin_changed
+
+ Timestamp indicating when the recycle bin was last changed.
+
+ entry_templates_group
+
+ The UUID of a group containing template entries used when creating new
+ entries.
+
+ entry_templates_group_changed
+
+ Timestamp indicating when the entry templates group was last changed.
+
+ last_selected_group
+
+ The UUID of the previously-selected group.
+
+ last_top_visible_group
+
+ The UUID of the group visible at the top of the list.
+
+ history_max_items
+
+ The maximum number of historical entries allowed to be saved for each
+ entry.
+
+ history_max_size
+
+ The maximum total size (in bytes) that each individual entry's history
+ is allowed to grow.
+
+ settings_changed
+
+ Timestamp indicating when the database settings were last updated.
+
+ protect_title
+
+ Alias of the "memory_protection" setting for the Title string.
+
+ protect_username
+
+ Alias of the "memory_protection" setting for the UserName string.
+
+ protect_password
+
+ Alias of the "memory_protection" setting for the Password string.
+
+ protect_url
+
+ Alias of the "memory_protection" setting for the URL string.
+
+ protect_notes
+
+ Alias of the "memory_protection" setting for the Notes string.
+
+METHODS
+
+ new
+
+ $kdbx = File::KDBX->new(%attributes);
+ $kdbx = File::KDBX->new($kdbx); # copy constructor
+
+ Construct a new File::KDBX.
+
+ init
+
+ $kdbx = $kdbx->init(%attributes);
+
+ Initialize a File::KDBX with a set of attributes. Returns itself to
+ allow method chaining.
+
+ This is called by "new".
+
+ reset
+
+ $kdbx = $kdbx->reset;
+
+ Set a File::KDBX to an empty state, ready to load a KDBX file or build
+ a new one. Returns itself to allow method chaining.
+
+ clone
+
+ $kdbx_copy = $kdbx->clone;
+ $kdbx_copy = File::KDBX->new($kdbx);
+
+ Clone a File::KDBX. The clone will be an exact copy and completely
+ independent of the original.
+
+ load
+
+ load_string
+
+ load_file
+
+ load_handle
+
+ $kdbx = KDBX::File->load(\$string, $key);
+ $kdbx = KDBX::File->load(*IO, $key);
+ $kdbx = KDBX::File->load($filepath, $key);
+ $kdbx->load(...); # also instance method
+
+ $kdbx = File::KDBX->load_string($string, $key);
+ $kdbx = File::KDBX->load_string(\$string, $key);
+ $kdbx->load_string(...); # also instance method
+
+ $kdbx = File::KDBX->load_file($filepath, $key);
+ $kdbx->load_file(...); # also instance method
+
+ $kdbx = File::KDBX->load_handle($fh, $key);
+ $kdbx = File::KDBX->load_handle(*IO, $key);
+ $kdbx->load_handle(...); # also instance method
+
+ Load a KDBX file from a string buffer, IO handle or file from a
+ filesystem.
+
+ File::KDBX::Loader does the heavy lifting.
+
+ dump
+
+ dump_string
+
+ dump_file
+
+ dump_handle
+
+ $kdbx->dump(\$string, $key);
+ $kdbx->dump(*IO, $key);
+ $kdbx->dump($filepath, $key);
+
+ $kdbx->dump_string(\$string, $key);
+ \$string = $kdbx->dump_string($key);
+
+ $kdbx->dump_file($filepath, $key);
+
+ $kdbx->dump_handle($fh, $key);
+ $kdbx->dump_handle(*IO, $key);
+
+ Dump a KDBX file to a string buffer, IO handle or file in a filesystem.
+
+ File::KDBX::Dumper does the heavy lifting.
+
+ user_agent_string
+
+ $string = $kdbx->user_agent_string;
+
+ Get a text string identifying the database client software.
+
+ memory_protection
+
+ \%settings = $kdbx->memory_protection
+ $kdbx->memory_protection(\%settings);
+
+ $bool = $kdbx->memory_protection($string_key);
+ $kdbx->memory_protection($string_key => $bool);
+
+ Get or set memory protection settings. This globally (for the whole
+ database) configures whether and which of the standard strings should
+ be memory-protected. The default setting is to memory-protect only
+ Password strings.
+
+ Memory protection can be toggled individually for each entry string,
+ and individual settings take precedence over these global settings.
+
+ minimum_version
+
+ $version = $kdbx->minimum_version;
+
+ Determine the minimum file version required to save a database
+ losslessly. Using certain databases features might increase this value.
+ For example, setting the KDF to Argon2 will increase the minimum
+ version to at least KDBX_VERSION_4_0 (i.e. 0x00040000) because Argon2
+ was introduced with KDBX4.
+
+ This method never returns less than KDBX_VERSION_3_1 (i.e. 0x00030001).
+ That file version is so ubiquitious and well-supported, there are
+ seldom reasons to dump in a lesser format nowadays.
+
+ WARNING: If you dump a database with a minimum version higher than the
+ current "version", the dumper will typically issue a warning and
+ automatically upgrade the database. This seems like the safest behavior
+ in order to avoid data loss, but lower versions have the benefit of
+ being compatible with more software. It is possible to prevent
+ auto-upgrades by explicitly telling the dumper which version to use,
+ but you do run the risk of data loss. A database will never be
+ automatically downgraded.
+
+ root
+
+ $group = $kdbx->root;
+ $kdbx->root($group);
+
+ Get or set a database's root group. You don't necessarily need to
+ explicitly create or set a root group because it autovivifies when
+ adding entries and groups to the database.
+
+ Every database has only a single root group at a time. Some old KDB
+ files might have multiple root groups. When reading such files, a
+ single implicit root group is created to contain the actual root
+ groups. When writing to such a format, if the root group looks like it
+ was implicitly created then it won't be written and the resulting file
+ might have multiple root groups. This allows working with older files
+ without changing their written internal structure while still adhering
+ to modern semantics while the database is opened.
+
+ The root group of a KDBX database contains all of the database's
+ entries and other groups. If you replace the root group, you are
+ essentially replacing the entire database contents with something else.
+
+ trace_lineage
+
+ \@lineage = $kdbx->trace_lineage($group);
+ \@lineage = $kdbx->trace_lineage($group, $base_group);
+ \@lineage = $kdbx->trace_lineage($entry);
+ \@lineage = $kdbx->trace_lineage($entry, $base_group);
+
+ Get the direct line of ancestors from $base_group (default: the root
+ group) to a group or entry. The lineage includes the base group but not
+ the target group or entry. Returns undef if the target is not in the
+ database structure.
+
+ recycle_bin
+
+ $group = $kdbx->recycle_bin;
+ $kdbx->recycle_bin($group);
+
+ Get or set the recycle bin group. Returns undef if there is no recycle
+ bin and "recycle_bin_enabled" is false, otherwise the current recycle
+ bin or an autovivified recycle bin group is returned.
+
+ entry_templates
+
+ $group = $kdbx->entry_templates;
+ $kdbx->entry_templates($group);
+
+ Get or set the entry templates group. May return undef if unset.
+
+ last_selected
+
+ $group = $kdbx->last_selected;
+ $kdbx->last_selected($group);
+
+ Get or set the last selected group. May return undef if unset.
+
+ last_top_visible
+
+ $group = $kdbx->last_top_visible;
+ $kdbx->last_top_visible($group);
+
+ Get or set the last top visible group. May return undef if unset.
+
+ add_group
+
+ $kdbx->add_group($group);
+ $kdbx->add_group(%group_attributes, %options);
+
+ Add a group to a database. This is equivalent to identifying a parent
+ group and calling "add_group" in File::KDBX::Group on the parent group,
+ forwarding the arguments. Available options:
+
+ * group (aka parent) - Group object or group UUID to add the group to
+ (default: root group)
+
+ groups
+
+ \&iterator = $kdbx->groups(%options);
+ \&iterator = $kdbx->groups($base_group, %options);
+
+ Get an File::KDBX::Iterator over groups within a database. Options:
+
+ * base - Only include groups within a base group (same as
+ $base_group) (default: "root")
+
+ * inclusive - Include the base group in the results (default: true)
+
+ * algorithm - Search algorithm, one of ids, bfs or dfs (default: ids)
+
+ add_entry
+
+ $kdbx->add_entry($entry, %options);
+ $kdbx->add_entry(%entry_attributes, %options);
+
+ Add a entry to a database. This is equivalent to identifying a parent
+ group and calling "add_entry" in File::KDBX::Group on the parent group,
+ forwarding the arguments. Available options:
+
+ * group (aka parent) - Group object or group UUID to add the entry to
+ (default: root group)
+
+ entries
+
+ \&iterator = $kdbx->entries(%options);
+ \&iterator = $kdbx->entries($base_group, %options);
+
+ Get an File::KDBX::Iterator over entries within a database. Supports
+ the same options as "groups", plus some new ones:
+
+ * auto_type - Only include entries with auto-type enabled (default:
+ false, include all)
+
+ * searching - Only include entries within groups with searching
+ enabled (default: false, include all)
+
+ * history - Also include historical entries (default: false, include
+ only current entries)
+
+ objects
+
+ \&iterator = $kdbx->objects(%options);
+ \&iterator = $kdbx->objects($base_group, %options);
+
+ Get an File::KDBX::Iterator over objects within a database. Groups and
+ entries are considered objects, so this is essentially a combination of
+ "groups" and "entries". This won't often be useful, but it can be
+ convenient for maintenance tasks. This method takes the same options as
+ "groups" and "entries".
+
+ custom_icon
+
+ \%icon = $kdbx->custom_icon($uuid);
+ $kdbx->custom_icon($uuid => \%icon);
+ $kdbx->custom_icon(%icon);
+ $kdbx->custom_icon(uuid => $value, %icon);
+
+ Get or set custom icons.
+
+ custom_icon_data
+
+ $image_data = $kdbx->custom_icon_data($uuid);
+
+ Get a custom icon image data.
+
+ add_custom_icon
+
+ $uuid = $kdbx->add_custom_icon($image_data, %attributes);
+ $uuid = $kdbx->add_custom_icon(%attributes);
+
+ Add a custom icon and get its UUID. If not provided, a random UUID will
+ be generated. Possible attributes:
+
+ * uuid - Icon UUID (default: autogenerated)
+
+ * data - Image data (same as $image_data)
+
+ * name - Name of the icon (text, KDBX4.1+)
+
+ * last_modification_time - Just what it says (datetime, KDBX4.1+)
+
+ remove_custom_icon
+
+ $kdbx->remove_custom_icon($uuid);
+
+ Remove a custom icon.
+
+ custom_data
+
+ \%all_data = $kdbx->custom_data;
+ $kdbx->custom_data(\%all_data);
+
+ \%data = $kdbx->custom_data($key);
+ $kdbx->custom_data($key => \%data);
+ $kdbx->custom_data(%data);
+ $kdbx->custom_data(key => $value, %data);
+
+ Get and set custom data. Custom data is metadata associated with a
+ database.
+
+ Each data item can have a few attributes associated with it.
+
+ * key - A unique text string identifier used to look up the data item
+ (required)
+
+ * value - A text string value (required)
+
+ * last_modification_time (optional, KDBX4.1+)
+
+ custom_data_value
+
+ $value = $kdbx->custom_data_value($key);
+
+ Exactly the same as "custom_data" except returns just the custom data's
+ value rather than a structure of attributes. This is a shortcut for:
+
+ my $data = $kdbx->custom_data($key);
+ my $value = defined $data ? $data->{value} : undef;
+
+ public_custom_data
+
+ \%all_data = $kdbx->public_custom_data;
+ $kdbx->public_custom_data(\%all_data);
+
+ $value = $kdbx->public_custom_data($key);
+ $kdbx->public_custom_data($key => $value);
+
+ Get and set public custom data. Public custom data is similar to custom
+ data but different in some important ways. Public custom data:
+
+ * can store strings, booleans and up to 64-bit integer values (custom
+ data can only store text values)
+
+ * is NOT encrypted within a KDBX file (hence the "public" part of the
+ name)
+
+ * is a plain hash/dict of key-value pairs with no other associated
+ fields (like modification times)
+
+ add_deleted_object
+
+ $kdbx->add_deleted_object($uuid);
+
+ Add a UUID to the deleted objects list. This list is used to support
+ automatic database merging.
+
+ You typically do not need to call this yourself because the list will
+ be populated automatically as objects are removed.
+
+ remove_deleted_object
+
+ $kdbx->remove_deleted_object($uuid);
+
+ Remove a UUID from the deleted objects list. This list is used to
+ support automatic database merging.
+
+ You typically do not need to call this yourself because the list will
+ be maintained automatically as objects are added.
+
+ clear_deleted_objects
+
+ Remove all UUIDs from the deleted objects list. This list is used to
+ support automatic database merging, but if you don't need merging then
+ you can clear deleted objects to reduce the database file size.
+
+ resolve_reference
+
+ $string = $kdbx->resolve_reference($reference);
+ $string = $kdbx->resolve_reference($wanted, $search_in, $expression);
+
+ Resolve a field reference
+ <https://keepass.info/help/base/fieldrefs.html>. A field reference is a
+ kind of string placeholder. You can use a field reference to refer
+ directly to a standard field within an entry. Field references are
+ resolved automatically while expanding entry strings (i.e. replacing
+ placeholders), but you can use this method to resolve on-the-fly
+ references that aren't part of any actual string in the database.
+
+ If the reference does not resolve to any field, undef is returned. If
+ the reference resolves to multiple fields, only the first one is
+ returned (in the same order as iterated by "entries"). To avoid
+ ambiguity, you can refer to a specific entry by its UUID.
+
+ The syntax of a reference is: {REF:<WantedField>@<SearchIn>:<Text>}.
+ Text is a "Simple Expression". WantedField and SearchIn are both single
+ character codes representing a field:
+
+ * T - Title
+
+ * U - UserName
+
+ * P - Password
+
+ * A - URL
+
+ * N - Notes
+
+ * I - UUID
+
+ * O - Other custom strings
+
+ Since O does not represent any specific field, it cannot be used as the
+ WantedField.
+
+ Examples:
+
+ To get the value of the UserName string of the first entry with "My
+ Bank" in the title:
+
+ my $username = $kdbx->resolve_reference('{REF:U@T:"My Bank"}');
+ # OR the {REF:...} wrapper is optional
+ my $username = $kdbx->resolve_reference('U@T:"My Bank"');
+ # OR separate the arguments
+ my $username = $kdbx->resolve_reference(U => T => '"My Bank"');
+
+ Note how the text is a "Simple Expression", so search terms with spaces
+ must be surrounded in double quotes.
+
+ To get the Password string of a specific entry (identified by its
+ UUID):
+
+ my $password = $kdbx->resolve_reference('{REF:P@I:46C9B1FFBD4ABC4BBB260C6190BAD20C}');
+
+ lock
+
+ $kdbx->lock;
+
+ Encrypt all protected binaries strings in a database. The encrypted
+ strings are stored in a File::KDBX::Safe associated with the database
+ and the actual strings will be replaced with undef to indicate their
+ protected state. Returns itself to allow method chaining.
+
+ You can call code on an already-locked database to memory-protect any
+ unprotected strings and binaries added after the last time the database
+ was locked.
+
+ unlock
+
+ $kdbx->unlock;
+
+ Decrypt all protected strings in a database, replacing undef
+ placeholders with unprotected values. Returns itself to allow method
+ chaining.
+
+ unlock_scoped
+
+ $guard = $kdbx->unlock_scoped;
+
+ Unlock a database temporarily, relocking when the guard is released
+ (typically at the end of a scope). Returns undef if the database is
+ already unlocked.
+
+ See "lock" and "unlock".
+
+ peek
+
+ $string = $kdbx->peek(\%string);
+ $string = $kdbx->peek(\%binary);
+
+ Peek at the value of a protected string or binary without unlocking the
+ whole database. The argument can be a string or binary hashref as
+ returned by "string" in File::KDBX::Entry or "binary" in
+ File::KDBX::Entry.
+
+ is_locked
+
+ $bool = $kdbx->is_locked;
+
+ Get whether or not a database's strings are memory-protected. If this
+ is true, then some or all of the protected strings within the database
+ will be unavailable (literally have undef values) until "unlock" is
+ called.
+
+ remove_empty_groups
+
+ $kdbx->remove_empty_groups;
+
+ Remove groups with no subgroups and no entries.
+
+ remove_unused_icons
+
+ $kdbx->remove_unused_icons;
+
+ Remove icons that are not associated with any entry or group in the
+ database.
+
+ remove_duplicate_icons
+
+ $kdbx->remove_duplicate_icons;
+
+ Remove duplicate icons as determined by hashing the icon data.
+
+ prune_history
+
+ $kdbx->prune_history(%options);
+
+ Remove just as many older historical entries as necessary to get under
+ certain limits.
+
+ * max_items - Maximum number of historical entries to keep (default:
+ value of "history_max_items", no limit: -1)
+
+ * max_size - Maximum total size (in bytes) of historical entries to
+ keep (default: value of "history_max_size", no limit: -1)
+
+ * max_age - Maximum age (in days) of historical entries to keep
+ (default: 365, no limit: -1)
+
+ randomize_seeds
+
+ $kdbx->randomize_seeds;
+
+ Set various keys, seeds and IVs to random values. These values are used
+ by the cryptographic functions that secure the database when dumped.
+ The attributes that will be randomized are:
+
+ * "encryption_iv"
+
+ * "inner_random_stream_key"
+
+ * "master_seed"
+
+ * "stream_start_bytes"
+
+ * "transform_seed"
+
+ Randomizing these values has no effect on a loaded database. These are
+ only used when a database is dumped. You normally do not need to call
+ this method explicitly because the dumper does it explicitly by
+ default.
+
+ key
+
+ $key = $kdbx->key;
+ $key = $kdbx->key($key);
+ $key = $kdbx->key($primitive);
+
+ Get or set a File::KDBX::Key. This is the master key (e.g. a password
+ or a key file that can decrypt a database). See "new" in
+ File::KDBX::Key for an explanation of what the primitive can be.
+
+ You generally don't need to call this directly because you can provide
+ the key directly to the loader or dumper when loading or dumping a KDBX
+ file.
+
+ composite_key
+
+ $key = $kdbx->composite_key($key);
+ $key = $kdbx->composite_key($primitive);
+
+ Construct a File::KDBX::Key::Composite from a primitive. See "new" in
+ File::KDBX::Key for an explanation of what the primitive can be. If the
+ primitive does not represent a composite key, it will be wrapped.
+
+ You generally don't need to call this directly. The parser and writer
+ use it to transform a master key into a raw encryption key.
+
+ kdf
+
+ $kdf = $kdbx->kdf(%options);
+ $kdf = $kdbx->kdf(\%parameters, %options);
+
+ Get a File::KDBX::KDF (key derivation function).
+
+ Options:
+
+ * params - KDF parameters, same as \%parameters (default: value of
+ "kdf_parameters")
+
+ cipher
+
+ $cipher = $kdbx->cipher(key => $key);
+ $cipher = $kdbx->cipher(key => $key, iv => $iv, uuid => $uuid);
+
+ Get a File::KDBX::Cipher capable of encrypting and decrypting the body
+ of a database file.
+
+ A key is required. This should be a raw encryption key made up of a
+ fixed number of octets (depending on the cipher), not a File::KDBX::Key
+ or primitive.
+
+ If not passed, the UUID comes from $kdbx->headers->{cipher_id} and the
+ encryption IV comes from $kdbx->headers->{encryption_iv}.
+
+ You generally don't need to call this directly. The parser and writer
+ use it to decrypt and encrypt KDBX files.
+
+ random_stream
+
+ $cipher = $kdbx->random_stream;
+ $cipher = $kdbx->random_stream(id => $stream_id, key => $key);
+
+ Get a File::KDBX::Cipher::Stream for decrypting and encrypting
+ protected values.
+
+ If not passed, the ID and encryption key comes from
+ $kdbx->headers->{inner_random_stream_id} and
+ $kdbx->headers->{inner_random_stream_key} (respectively) for KDBX3
+ files and from $kdbx->inner_headers->{inner_random_stream_key} and
+ $kdbx->inner_headers->{inner_random_stream_id} (respectively) for KDBX4
+ files.
+
+ You generally don't need to call this directly. The parser and writer
+ use it to scramble protected strings.
+
+RECIPES
+
+ Create a new database
+
+ my $kdbx = File::KDBX->new;
+
+ my $group = $kdbx->add_group(name => 'Passwords);
+ my $entry = $group->add_entry(
+ title => 'WayneCorp',
+ username => 'bwayne',
+ password => 'iambatman',
+ url => 'https://example.com/login'
+ );
+ $entry->add_auto_type_window_association('WayneCorp - Mozilla Firefox', '{PASSWORD}{ENTER}');
+
+ $kdbx->dump_file('mypasswords.kdbx', 'master password CHANGEME');
+
+ Read an existing database
+
+ my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME');
+ $kdbx->unlock; # cause $entry->password below to be defined
+
+ $kdbx->entries->each(sub {
+ my ($entry) = @_;
+ say 'Found password for: ', $entry->title;
+ say ' Username: ', $entry->username;
+ say ' Password: ', $entry->password;
+ });
+
+ Search for entries
+
+ my @entries = $kdbx->entries(searching => 1)
+ ->grep(title => 'WayneCorp')
+ ->each; # return all matches
+
+ The searching option limits results to only entries within groups with
+ searching enabled. Other options are also available. See "entries".
+
+ See "QUERY" for many more query examples.
+
+ Search for entries by auto-type window association
+
+ my $window_title = 'WayneCorp - Mozilla Firefox';
+
+ my $entries = $kdbx->entries(auto_type => 1)
+ ->filter(sub {
+ my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations};
+ return [$_, $ata->{keystroke_sequence}] if $ata;
+ })
+ ->each(sub {
+ my ($entry, $keys) = @$_;
+ say 'Entry title: ', $entry->title, ', key sequence: ', $keys;
+ });
+
+ Example output:
+
+ Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER}
+
+ Remove entries from a database
+
+ $kdbx->entries
+ ->grep(notes => {'=~' => qr/too old/i})
+ ->each(sub { $_->recycle });
+
+ Recycle all entries with the string "too old" appearing in the Notes
+ string.
+
+ Remove empty groups
+
+ $kdbx->groups(algorithm => 'dfs')
+ ->where(-true => 'is_empty')
+ ->each('remove');
+
+ With the search/iteration algorithm set to "dfs", groups will be
+ ordered deepest first and the root group will be last. This allows
+ removing groups that only contain empty groups.
+
+ This can also be done with one call to "remove_empty_groups".
+
+SECURITY
+
+ One of the biggest threats to your database security is how easily the
+ encryption key can be brute-forced. Strong brute-force protection
+ depends on:
+
+ * Using unguessable passwords, passphrases and key files.
+
+ * Using a brute-force resistent key derivation function.
+
+ The first factor is up to you. This module does not enforce strong
+ master keys. It is up to you to pick or generate strong keys.
+
+ The KDBX format allows for the key derivation function to be tuned. The
+ idea is that you want each single brute-foce attempt to be expensive
+ (in terms of time, CPU usage or memory usage), so that making a lot of
+ attempts (which would be required if you have a strong master key) gets
+ really expensive.
+
+ How expensive you want to make each attempt is up to you and can depend
+ on the application.
+
+ This and other KDBX-related security issues are covered here more in
+ depth: https://keepass.info/help/base/security.html
+
+ Here are other security risks you should be thinking about:
+
+ Cryptography
+
+ This distribution uses the excellent CryptX and Crypt::Argon2 packages
+ to handle all crypto-related functions. As such, a lot of the security
+ depends on the quality of these dependencies. Fortunately these modules
+ are maintained and appear to have good track records.
+
+ The KDBX format has evolved over time to incorporate improved security
+ practices and cryptographic functions. This package uses the following
+ functions for authentication, hashing, encryption and random number
+ generation:
+
+ * AES-128 (legacy)
+
+ * AES-256
+
+ * Argon2d & Argon2id
+
+ * CBC block mode
+
+ * HMAC-SHA256
+
+ * SHA256
+
+ * SHA512
+
+ * Salsa20 & ChaCha20
+
+ * Twofish
+
+ At the time of this writing, I am not aware of any successful attacks
+ against any of these functions. These are among the most-analyzed and
+ widely-adopted crypto functions available.
+
+ The KDBX format allows the body cipher and key derivation function to
+ be configured. If a flaw is discovered in one of these functions, you
+ can hopefully just switch to a better function without needing to
+ update this software. A later software release may phase out the use of
+ any functions which are no longer secure.
+
+ Memory Protection
+
+ It is not a good idea to keep secret information unencrypted in system
+ memory for longer than is needed. The address space of your program can
+ generally be read by a user with elevated privileges on the system. If
+ your system is memory-constrained or goes into a hibernation mode, the
+ contents of your address space could be written to a disk where it
+ might be persisted for long time.
+
+ There might be system-level things you can do to reduce your risk, like
+ using swap encryption and limiting system access to your program's
+ address space while your program is running.
+
+ File::KDBX helps minimize (but not eliminate) risk by keeping secrets
+ encrypted in memory until accessed and zeroing out memory that holds
+ secrets after they're no longer needed, but it's not a silver bullet.
+
+ For one thing, the encryption key is stored in the same address space.
+ If core is dumped, the encryption key is available to be found out. But
+ at least there is the chance that the encryption key and the encrypted
+ secrets won't both be paged out together while memory-constrained.
+
+ Another problem is that some perls (somewhat notoriously) copy around
+ memory behind the scenes willy nilly, and it's difficult know when perl
+ makes a copy of a secret in order to be able to zero it out later. It
+ might be impossible. The good news is that perls with SvPV
+ copy-on-write (enabled by default beginning with perl 5.20) are much
+ better in this regard. With COW, it's mostly possible to know what
+ operations will cause perl to copy the memory of a scalar string, and
+ the number of copies will be significantly reduced. There is a unit
+ test named t/memory-protection.t in this distribution that can be run
+ on POSIX systems to determine how well File::KDBX memory protection is
+ working.
+
+ Memory protection also depends on how your application handles secrets.
+ If your app code is handling scalar strings with secret information,
+ it's up to you to make sure its memory is zeroed out when no longer
+ needed. "erase" in File::KDBX::Util et al. provide some tools to help
+ accomplish this. Or if you're not too concerned about the risks memory
+ protection is meant to mitigate, then maybe don't worry about it. The
+ security policy of File::KDBX is to try hard to keep secrets protected
+ while in memory so that your app might claim a high level of security,
+ in case you care about that.
+
+ There are some memory protection strategies that File::KDBX does NOT
+ use today but could in the future:
+
+ Many systems allow programs to mark unswappable pages. Secret
+ information should ideally be stored in such pages. You could
+ potentially use mlockall(2) (or equivalent for your system) in your own
+ application to prevent the entire address space from being swapped.
+
+ Some systems provide special syscalls for storing secrets in memory
+ while keeping the encryption key outside of the program's address
+ space, like CryptProtectMemory for Windows. This could be a good
+ option, though unfortunately not portable.
+
+QUERY
+
+ To find things in a KDBX database, you should use a filtered iterator.
+ If you have an iterator, such as returned by "entries", "groups" or
+ even "objects" you can filter it using "where" in File::KDBX::Iterator.
+
+ my $filtered_entries = $kdbx->entries->where($query);
+
+ A $query is just a subroutine that you can either write yourself or
+ have generated for you from either a "Simple Expression" or
+ "Declarative Syntax". It's easier to have your query generated, so I'll
+ cover that first.
+
+ Simple Expression
+
+ A simple expression is mostly compatible with the KeePass 2
+ implementation described here
+ <https://keepass.info/help/base/search.html#mode_se>.
+
+ An expression is a string with one or more space-separated terms. Terms
+ with spaces can be enclosed in double quotes. Terms are negated if they
+ are prefixed with a minus sign. A record must match every term on at
+ least one of the given fields.
+
+ So a simple expression is something like what you might type into a
+ search engine. You can generate a simple expression query using
+ "simple_expression_query" in File::KDBX::Util or by passing the simple
+ expression as a scalar reference to where.
+
+ To search for all entries in a database with the word "canyon"
+ appearing anywhere in the title:
+
+ my $entries = $kdbx->entries->where(\'canyon', qw[title]);
+
+ Notice the first argument is a scalarref. This disambiguates a simple
+ expression from other types of queries covered below.
+
+ As mentioned, a simple expression can have multiple terms. This simple
+ expression query matches any entry that has the words "red" and
+ "canyon" anywhere in the title:
+
+ my $entries = $kdbx->entries->where(\'red canyon', qw[title]);
+
+ Each term in the simple expression must be found for an entry to match.
+
+ To search for entries with "red" in the title but not "canyon", just
+ prepend "canyon" with a minus sign:
+
+ my $entries = $kdbx->entries->where(\'red -canyon', qw[title]);
+
+ To search over multiple fields simultaneously, just list them all. To
+ search for entries with "grocery" (but not "Foodland") in the title or
+ notes:
+
+ my $entries = $kdbx->entries->where(\'grocery -Foodland', qw[title notes]);
+
+ The default operator is a case-insensitive regexp match, which is fine
+ for searching text loosely. You can use just about any binary
+ comparison operator that perl supports. To specify an operator, list it
+ after the simple expression. For example, to search for any entry that
+ has been used at least five times:
+
+ my $entries = $kdbx->entries->where(\5, '>=', qw[usage_count]);
+
+ It helps to read it right-to-left, like "usage_count is greater than or
+ equal to 5".
+
+ If you find the disambiguating structures to be distracting or
+ confusing, you can also the "simple_expression_query" in
+ File::KDBX::Util function as a more intuitive alternative. The
+ following example is equivalent to the previous:
+
+ my $entries = $kdbx->entries->where(simple_expression_query(5, '>=', qw[usage_count]));
+
+ Declarative Syntax
+
+ Structuring a declarative query is similar to "WHERE CLAUSES" in
+ SQL::Abstract, but you don't have to be familiar with that module. Just
+ learn by examples here.
+
+ To search for all entries in a database titled "My Bank":
+
+ my $entries = $kdbx->entries->where({ title => 'My Bank' });
+
+ The query here is { title => 'My Bank' }. A hashref can contain
+ key-value pairs where the key is an attribute of the thing being
+ searched for (in this case an entry) and the value is what you want the
+ thing's attribute to be to consider it a match. In this case, the
+ attribute we're using as our match criteria is "title" in
+ File::KDBX::Entry, a text field. If an entry has its title attribute
+ equal to "My Bank", it's a match.
+
+ A hashref can contain multiple attributes. The search candidate will be
+ a match if all of the specified attributes are equal to their
+ respective values. For example, to search for all entries with a
+ particular URL AND username:
+
+ my $entries = $kdbx->entries->where({
+ url => 'https://example.com',
+ username => 'neo',
+ });
+
+ To search for entries matching any criteria, just change the hashref to
+ an arrayref. To search for entries with a particular URL OR username:
+
+ my $entries = $kdbx->entries->where([ # <-- Notice the square bracket
+ url => 'https://example.com',
+ username => 'neo',
+ ]);
+
+ You can use different operators to test different types of attributes.
+ The "icon_id" in File::KDBX::Entry attribute is a number, so we should
+ use a number comparison operator. To find entries using the smartphone
+ icon:
+
+ my $entries = $kdbx->entries->where({
+ icon_id => { '==', ICON_SMARTPHONE },
+ });
+
+ Note: "ICON_SMARTPHONE" in File::KDBX::Constants is just a constant
+ from File::KDBX::Constants. It isn't special to this example or to
+ queries generally. We could have just used a literal number.
+
+ The important thing to notice here is how we wrapped the condition in
+ another arrayref with a single key-value pair where the key is the name
+ of an operator and the value is the thing to match against. The
+ supported operators are:
+
+ * eq - String equal
+
+ * ne - String not equal
+
+ * lt - String less than
+
+ * gt - String greater than
+
+ * le - String less than or equal
+
+ * ge - String greater than or equal
+
+ * == - Number equal
+
+ * != - Number not equal
+
+ * < - Number less than
+
+ * >> - Number greater than
+
+ * <= - Number less than or equal
+
+ * >= - Number less than or equal
+
+ * =~ - String match regular expression
+
+ * !~ - String does not match regular expression
+
+ * ! - Boolean false
+
+ * !! - Boolean true
+
+ Other special operators:
+
+ * -true - Boolean true
+
+ * -false - Boolean false
+
+ * -not - Boolean false (alias for -false)
+
+ * -defined - Is defined
+
+ * -undef - Is not defined
+
+ * -empty - Is empty
+
+ * -nonempty - Is not empty
+
+ * -or - Logical or
+
+ * -and - Logical and
+
+ Let's see another example using an explicit operator. To find all
+ groups except one in particular (identified by its "uuid" in
+ File::KDBX::Group), we can use the ne (string not equal) operator:
+
+ my $groups = $kdbx->groups->where(
+ uuid => {
+ 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'),
+ },
+ );
+
+ Note: "uuid" in File::KDBX::Util is a little utility function to
+ convert a UUID in its pretty form into bytes. This utility function
+ isn't special to this example or to queries generally. It could have
+ been written with a literal such as "\x59\x6f\x75\x20\x61...", but
+ that's harder to read.
+
+ Notice we searched for groups this time. Finding groups works exactly
+ the same as it does for entries.
+
+ Notice also that we didn't wrap the query in hashref curly-braces or
+ arrayref square-braces. Those are optional. By default it will only
+ match ALL attributes (as if there were curly-braces).
+
+ Testing the truthiness of an attribute is a little bit different
+ because it isn't a binary operation. To find all entries with the
+ password quality check disabled:
+
+ my $entries = $kdbx->entries->where('!' => 'quality_check');
+
+ This time the string after the operator is the attribute name rather
+ than a value to compare the attribute against. To test that a boolean
+ value is true, use the !! operator (or -true if !! seems a little too
+ weird for your taste):
+
+ my $entries = $kdbx->entries->where('!!' => 'quality_check');
+ my $entries = $kdbx->entries->where(-true => 'quality_check'); # same thing
+
+ Yes, there is also a -false and a -not if you prefer one of those over
+ !. -false and -not (along with -true) are also special in that you can
+ use them to invert the logic of a subquery. These are logically
+ equivalent:
+
+ my $entries = $kdbx->entries->where(-not => { title => 'My Bank' });
+ my $entries = $kdbx->entries->where(title => { 'ne' => 'My Bank' });
+
+ These special operators become more useful when combined with two more
+ special operators: -and and -or. With these, it is possible to
+ construct more interesting queries with groups of logic. For example:
+
+ my $entries = $kdbx->entries->where({
+ title => { '=~', qr/bank/ },
+ -not => {
+ -or => {
+ notes => { '=~', qr/business/ },
+ icon_id => { '==', ICON_TRASHCAN_FULL },
+ },
+ },
+ });
+
+ In English, find entries where the word "bank" appears anywhere in the
+ title but also do not have either the word "business" in the notes or
+ are using the full trashcan icon.
+
+ Subroutine Query
+
+ Lastly, as mentioned at the top, you can ignore all this and write your
+ own subroutine. Your subroutine will be called once for each object
+ being searched over. The subroutine should match the candidate against
+ whatever criteria you want and return true if it matches or false to
+ skip. To do this, just pass your subroutine coderef to where.
+
+ To review the different types of queries, these are all equivalent to
+ find all entries in the database titled "My Bank":
+
+ my $entries = $kdbx->entries->where(\'"My Bank"', 'eq', qw[title]); # simple expression
+ my $entries = $kdbx->entries->where(title => 'My Bank'); # declarative syntax
+ my $entries = $kdbx->entries->where(sub { $_->title eq 'My Bank' }); # subroutine query
+
+ This is a trivial example, but of course your subroutine can be
+ arbitrarily complex.
+
+ All of these query mechanisms described in this section are just tools,
+ each with its own set of limitations. If the tools are getting in your
+ way, you can of course iterate over the contents of a database and
+ implement your own query logic, like this:
+
+ my $entries = $kdbx->entries;
+ while (my $entry = $entries->next) {
+ if (wanted($entry)) {
+ do_something($entry);
+ }
+ else {
+ ...
+ }
+ }
+
+ Iteration
+
+ Iterators are the built-in way to navigate or walk the database tree.
+ You get an iterator from "entries", "groups" and "objects". You can
+ specify the search algorithm to iterate over objects in different
+ orders using the algorith option, which can be one of these constants:
+
+ * ITERATION_IDS - Iterative deepening search (default)
+
+ * ITERATION_DFS - Depth-first search
+
+ * ITERATION_BFS - Breadth-first search
+
+ When iterating over objects generically, groups always precede their
+ direct entries (if any). When the history option is used, current
+ entries always precede historical entries.
+
+ If you have a database tree like this:
+
+ Database
+ - Root
+ - Group1
+ - EntryA
+ - Group2
+ - EntryB
+ - Group3
+ - EntryC
+
+ IDS order of groups is: Root, Group1, Group2, Group3 IDS order of
+ entries is: EntryA, EntryB, EntryC IDS order of objects is: Root,
+ Group1, EntryA, Group2, EntryB, Group3, EntryC
+
+ DFS order of groups is: Group2, Group1, Group3, Root DFS order of
+ entries is: EntryB, EntryA, EntryC DFS order of objects is: Group2,
+ EntryB, Group1, EntryA, Group3, EntryC, Root
+
+ BFS order of groups is: Root, Group1, Group3, Group2 BFS order of
+ entries is: EntryA, EntryC, EntryB BFS order of objects is: Root,
+ Group1, EntryA, Group3, EntryC, Group2, EntryB
+
+SYNCHRONIZING
+
+ TODO - This is a planned feature, not yet implemented.
+
+ERRORS
+
+ Errors in this package are constructed as File::KDBX::Error objects and
+ propagated using perl's built-in mechanisms. Fatal errors are
+ propagated using "die" in functions and non-fatal errors (a.k.a.
+ warnings) are propagated using "warn" in functions while adhering to
+ perl's warnings system. If you're already familiar with these
+ mechanisms, you can skip this section.
+
+ You can catch fatal errors using "eval" in functions (or something like
+ Try::Tiny) and non-fatal errors using $SIG{__WARN__} (see "%SIG" in
+ variables). Examples:
+
+ use File::KDBX::Error qw(error);
+
+ my $key = ''; # uh oh
+ eval {
+ $kdbx->load_file('whatever.kdbx', $key);
+ };
+ if (my $error = error($@)) {
+ handle_missing_key($error) if $error->type eq 'key.missing';
+ $error->throw;
+ }
+
+ or using Try::Tiny:
+
+ try {
+ $kdbx->load_file('whatever.kdbx', $key);
+ }
+ catch {
+ handle_error($_);
+ };
+
+ Catching non-fatal errors:
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, $_[0] };
+
+ $kdbx->load_file('whatever.kdbx', $key);
+
+ handle_warnings(@warnings) if @warnings;
+
+ By default perl prints warnings to STDERR if you don't catch them. If
+ you don't want to catch them and also don't want them printed to
+ STDERR, you can suppress them lexically (perl v5.28 or higher
+ required):
+
+ {
+ no warnings 'File::KDBX';
+ ...
+ }
+
+ or locally:
+
+ {
+ local $File::KDBX::WARNINGS = 0;
+ ...
+ }
+
+ or globally in your program:
+
+ $File::KDBX::WARNINGS = 0;
+
+ You cannot suppress fatal errors, and if you don't catch them your
+ program will exit.
+
+ENVIRONMENT
+
+ This software will alter its behavior depending on the value of certain
+ environment variables:
+
+ * PERL_FILE_KDBX_XS - Do not use File::KDBX::XS if false (default:
+ true)
+
+ * PERL_ONLY - Do not use File::KDBX::XS if true (default: false)
+
+ * NO_FORK - Do not fork if true (default: false)
+
+CAVEATS
+
+ Some features (e.g. parsing) require 64-bit perl. It should be possible
+ and actually pretty easy to make it work using Math::BigInt, but I need
+ to build a 32-bit perl in order to test it and frankly I'm still
+ figuring out how. I'm sure it's simple so I'll mark this one "TODO",
+ but for now an exception will be thrown when trying to use such
+ features with undersized IVs.
+
+SEE ALSO
+
+ * KeePass Password Safe <https://keepass.info/> - The original
+ KeePass
+
+ * KeePassXC <https://keepassxc.org/> - Cross-Platform Password
+ Manager written in C++
+
+ * File::KeePass has overlapping functionality. It's good but has a
+ backlog of some pretty critical bugs and lacks support for newer KDBX
+ features.
+
+BUGS
+
+ Please report any bugs or feature requests on the bugtracker website
+ https://github.com/chazmcgarvey/File-KDBX/issues
+
+ When submitting a bug or request, please include a test-file or a patch
+ to an existing test-file that illustrates the bug or desired feature.
+
+AUTHOR
+
+ Charles McGarvey <ccm@cpan.org>
+
+COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2022 by Charles McGarvey.
+
+ This is free software; you can redistribute it and/or modify it under
+ the same terms as the Perl 5 programming language system itself.
+
--- /dev/null
+package File::KDBX;
+# ABSTRACT: Encrypted database to store secret text and files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::PRNG qw(random_bytes);
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:all :icon);
+use File::KDBX::Error;
+use File::KDBX::Safe;
+use File::KDBX::Util qw(:class :coercion :empty :search :uuid erase simple_expression_query snakify);
+use Hash::Util::FieldHash qw(fieldhashes);
+use List::Util qw(any first);
+use Ref::Util qw(is_ref is_arrayref is_plain_hashref);
+use Scalar::Util qw(blessed);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+our $WARNINGS = 1;
+
+fieldhashes \my (%SAFE, %KEYS);
+
+
+sub new {
+ my $class = shift;
+
+ # copy constructor
+ return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
+
+ my $self = bless {}, $class;
+ $self->init(@_);
+ $self->_set_nonlazy_attributes if empty $self;
+ return $self;
+}
+
+sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->reset }
+
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+
+sub reset {
+ my $self = shift;
+ erase $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY};
+ erase $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
+ erase $self->{raw};
+ %$self = ();
+ $self->_remove_safe;
+ return $self;
+}
+
+
+sub clone {
+ my $self = shift;
+ require Storable;
+ return Storable::dclone($self);
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my $cloning = shift;
+
+ my $copy = {%$self};
+
+ return '', $copy, $KEYS{$self} // (), $SAFE{$self} // ();
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ shift;
+ my $clone = shift;
+ my $key = shift;
+ my $safe = shift;
+
+ @$self{keys %$clone} = values %$clone;
+ $KEYS{$self} = $key;
+ $SAFE{$self} = $safe;
+
+ # Dualvars aren't cloned as dualvars, so coerce the compression flags.
+ $self->compression_flags($self->compression_flags);
+
+ $self->objects(history => 1)->each(sub { $_->kdbx($self) });
+}
+
+##############################################################################
+
+
+sub load { shift->_loader->load(@_) }
+sub load_string { shift->_loader->load_string(@_) }
+sub load_file { shift->_loader->load_file(@_) }
+sub load_handle { shift->_loader->load_handle(@_) }
+
+sub _loader {
+ my $self = shift;
+ $self = $self->new if !ref $self;
+ require File::KDBX::Loader;
+ File::KDBX::Loader->new(kdbx => $self);
+}
+
+
+sub dump { shift->_dumper->dump(@_) }
+sub dump_string { shift->_dumper->dump_string(@_) }
+sub dump_file { shift->_dumper->dump_file(@_) }
+sub dump_handle { shift->_dumper->dump_handle(@_) }
+
+sub _dumper {
+ my $self = shift;
+ $self = $self->new if !ref $self;
+ require File::KDBX::Dumper;
+ File::KDBX::Dumper->new(kdbx => $self);
+}
+
+##############################################################################
+
+
+sub user_agent_string {
+ require Config;
+ sprintf('%s/%s (%s/%s; %s/%s; %s)',
+ __PACKAGE__, $VERSION, @Config::Config{qw(package version osname osvers archname)});
+}
+
+has sig1 => KDBX_SIG1, coerce => \&to_number;
+has sig2 => KDBX_SIG2_2, coerce => \&to_number;
+has version => KDBX_VERSION_3_1, coerce => \&to_number;
+has headers => {};
+has inner_headers => {};
+has meta => {};
+has binaries => {};
+has deleted_objects => {};
+has raw => coerce => \&to_string;
+
+# HEADERS
+has 'headers.comment' => '', coerce => \&to_string;
+has 'headers.cipher_id' => CIPHER_UUID_CHACHA20, coerce => \&to_uuid;
+has 'headers.compression_flags' => COMPRESSION_GZIP, coerce => \&to_compression_constant;
+has 'headers.master_seed' => sub { random_bytes(32) }, coerce => \&to_string;
+has 'headers.encryption_iv' => sub { random_bytes(16) }, coerce => \&to_string;
+has 'headers.stream_start_bytes' => sub { random_bytes(32) }, coerce => \&to_string;
+has 'headers.kdf_parameters' => sub {
+ +{
+ KDF_PARAM_UUID() => KDF_UUID_AES,
+ KDF_PARAM_AES_ROUNDS() => $_[0]->headers->{+HEADER_TRANSFORM_ROUNDS} // KDF_DEFAULT_AES_ROUNDS,
+ KDF_PARAM_AES_SEED() => $_[0]->headers->{+HEADER_TRANSFORM_SEED} // random_bytes(32),
+ };
+};
+# has 'headers.transform_seed' => sub { random_bytes(32) };
+# has 'headers.transform_rounds' => 100_000;
+# has 'headers.inner_random_stream_key' => sub { random_bytes(32) }; # 64 ?
+# has 'headers.inner_random_stream_id' => STREAM_ID_CHACHA20;
+# has 'headers.public_custom_data' => {};
+
+# META
+has 'meta.generator' => '', coerce => \&to_string;
+has 'meta.header_hash' => '', coerce => \&to_string;
+has 'meta.database_name' => '', coerce => \&to_string;
+has 'meta.database_name_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.database_description' => '', coerce => \&to_string;
+has 'meta.database_description_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.default_username' => '', coerce => \&to_string;
+has 'meta.default_username_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.maintenance_history_days' => 0, coerce => \&to_number;
+has 'meta.color' => '', coerce => \&to_string;
+has 'meta.master_key_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.master_key_change_rec' => -1, coerce => \&to_number;
+has 'meta.master_key_change_force' => -1, coerce => \&to_number;
+# has 'meta.memory_protection' => {};
+has 'meta.custom_icons' => [];
+has 'meta.recycle_bin_enabled' => true, coerce => \&to_bool;
+has 'meta.recycle_bin_uuid' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.recycle_bin_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.entry_templates_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.entry_templates_group_changed' => sub { gmtime }, coerce => \&to_time;
+has 'meta.last_selected_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.last_top_visible_group' => UUID_NULL, coerce => \&to_uuid;
+has 'meta.history_max_items' => HISTORY_DEFAULT_MAX_ITEMS, coerce => \&to_number;
+has 'meta.history_max_size' => HISTORY_DEFAULT_MAX_SIZE, coerce => \&to_number;
+has 'meta.settings_changed' => sub { gmtime }, coerce => \&to_time;
+# has 'meta.binaries' => {};
+# has 'meta.custom_data' => {};
+
+has 'memory_protection.protect_title' => false, coerce => \&to_bool;
+has 'memory_protection.protect_username' => false, coerce => \&to_bool;
+has 'memory_protection.protect_password' => true, coerce => \&to_bool;
+has 'memory_protection.protect_url' => false, coerce => \&to_bool;
+has 'memory_protection.protect_notes' => false, coerce => \&to_bool;
+# has 'memory_protection.auto_enable_visual_hiding' => false;
+
+my @ATTRS = (
+ HEADER_TRANSFORM_SEED,
+ HEADER_TRANSFORM_ROUNDS,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_INNER_RANDOM_STREAM_ID,
+ HEADER_PUBLIC_CUSTOM_DATA,
+);
+sub _set_nonlazy_attributes {
+ my $self = shift;
+ $self->$_ for list_attributes(ref $self), @ATTRS;
+}
+
+
+sub memory_protection {
+ my $self = shift;
+ $self->{meta}{memory_protection} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{meta}{memory_protection} //= {} if !@_;
+
+ my $string_key = shift;
+ my $key = 'protect_' . lc($string_key);
+
+ $self->meta->{memory_protection}{$key} = shift if @_;
+ $self->meta->{memory_protection}{$key};
+}
+
+
+sub minimum_version {
+ my $self = shift;
+
+ return KDBX_VERSION_4_1 if any {
+ nonempty $_->{last_modification_time}
+ } values %{$self->custom_data};
+
+ return KDBX_VERSION_4_1 if any {
+ nonempty $_->{name} || nonempty $_->{last_modification_time}
+ } @{$self->custom_icons};
+
+ return KDBX_VERSION_4_1 if $self->groups->next(sub {
+ nonempty $_->previous_parent_group ||
+ nonempty $_->tags ||
+ (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
+ });
+
+ return KDBX_VERSION_4_1 if $self->entries(history => 1)->next(sub {
+ nonempty $_->previous_parent_group ||
+ (defined $_->quality_check && !$_->quality_check) ||
+ (any { nonempty $_->{last_modification_time} } values %{$_->custom_data})
+ });
+
+ return KDBX_VERSION_4_0 if $self->kdf->uuid ne KDF_UUID_AES;
+
+ return KDBX_VERSION_4_0 if nonempty $self->public_custom_data;
+
+ return KDBX_VERSION_4_0 if $self->objects->next(sub {
+ nonempty $_->custom_data
+ });
+
+ return KDBX_VERSION_3_1;
+}
+
+##############################################################################
+
+
+sub root {
+ my $self = shift;
+ if (@_) {
+ $self->{root} = $self->_wrap_group(@_);
+ $self->{root}->kdbx($self);
+ }
+ $self->{root} //= $self->_implicit_root;
+ return $self->_wrap_group($self->{root});
+}
+
+# Called by File::KeePass::KDBX so that a File::KDBX an be treated as a File::KDBX::Group in that both types
+# can have subgroups. File::KDBX already has a `groups' method that does something different from the
+# File::KDBX::Groups `groups' method.
+sub _kpx_groups {
+ my $self = shift;
+ return [] if !$self->{root};
+ return $self->_has_implicit_root ? $self->root->groups : [$self->root];
+}
+
+sub _has_implicit_root {
+ my $self = shift;
+ my $root = $self->root;
+ my $temp = __PACKAGE__->_implicit_root;
+ # If an implicit root group has been changed in any significant way, it is no longer implicit.
+ return $root->name eq $temp->name &&
+ $root->is_expanded ^ $temp->is_expanded &&
+ $root->notes eq $temp->notes &&
+ !@{$root->entries} &&
+ !defined $root->custom_icon_uuid &&
+ !keys %{$root->custom_data} &&
+ $root->icon_id == $temp->icon_id &&
+ $root->expires ^ $temp->expires &&
+ $root->default_auto_type_sequence eq $temp->default_auto_type_sequence &&
+ !defined $root->enable_auto_type &&
+ !defined $root->enable_searching;
+}
+
+sub _implicit_root {
+ my $self = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->new(
+ name => 'Root',
+ is_expanded => true,
+ notes => 'Added as an implicit root group by '.__PACKAGE__.'.',
+ ref $self ? (kdbx => $self) : (),
+ );
+}
+
+
+sub trace_lineage {
+ my $self = shift;
+ my $object = shift;
+ return $object->lineage(@_);
+}
+
+sub _trace_lineage {
+ my $self = shift;
+ my $object = shift;
+ my @lineage = @_;
+
+ push @lineage, $self->root if !@lineage;
+ my $base = $lineage[-1] or return [];
+
+ my $uuid = $object->uuid;
+ return \@lineage if any { $_->uuid eq $uuid } @{$base->groups}, @{$base->entries};
+
+ for my $subgroup (@{$base->groups}) {
+ my $result = $self->_trace_lineage($object, @lineage, $subgroup);
+ return $result if $result;
+ }
+}
+
+
+sub recycle_bin {
+ my $self = shift;
+ if (my $group = shift) {
+ $self->recycle_bin_uuid($group->uuid);
+ return $group;
+ }
+ my $group;
+ my $uuid = $self->recycle_bin_uuid;
+ $group = $self->groups->grep(uuid => $uuid)->next if $uuid ne UUID_NULL;
+ if (!$group && $self->recycle_bin_enabled) {
+ $group = $self->add_group(
+ name => 'Recycle Bin',
+ icon_id => ICON_TRASHCAN_FULL,
+ enable_auto_type => false,
+ enable_searching => false,
+ );
+ $self->recycle_bin_uuid($group->uuid);
+ }
+ return $group;
+}
+
+
+sub entry_templates {
+ my $self = shift;
+ if (my $group = shift) {
+ $self->entry_templates_group($group->uuid);
+ return $group;
+ }
+ my $uuid = $self->entry_templates_group;
+ return if $uuid eq UUID_NULL;
+ return $self->groups->grep(uuid => $uuid)->next;
+}
+
+
+sub last_selected {
+ my $self = shift;
+ if (my $group = shift) {
+ $self->last_selected_group($group->uuid);
+ return $group;
+ }
+ my $uuid = $self->last_selected_group;
+ return if $uuid eq UUID_NULL;
+ return $self->groups->grep(uuid => $uuid)->next;
+}
+
+
+sub last_top_visible {
+ my $self = shift;
+ if (my $group = shift) {
+ $self->last_top_visible_group($group->uuid);
+ return $group;
+ }
+ my $uuid = $self->last_top_visible_group;
+ return if $uuid eq UUID_NULL;
+ return $self->groups->grep(uuid => $uuid)->next;
+}
+
+##############################################################################
+
+
+sub add_group {
+ my $self = shift;
+ my $group = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ # find the right group to add the group to
+ my $parent = delete $args{group} // delete $args{parent} // $self->root;
+ $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent;
+ $parent or throw 'Invalid group';
+
+ return $parent->add_group(defined $group ? $group : (), %args, kdbx => $self);
+}
+
+sub _wrap_group {
+ my $self = shift;
+ my $group = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->wrap($group, $self);
+}
+
+
+sub groups {
+ my $self = shift;
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
+ my $base = delete $args{base} // $self->root;
+
+ return $base->groups_deeply(%args);
+}
+
+##############################################################################
+
+
+sub add_entry {
+ my $self = shift;
+ my $entry = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ # find the right group to add the entry to
+ my $parent = delete $args{group} // delete $args{parent} // $self->root;
+ $parent = $self->groups->grep({uuid => $parent})->next if !ref $parent;
+ $parent or throw 'Invalid group';
+
+ return $parent->add_entry(defined $entry ? $entry : (), %args, kdbx => $self);
+}
+
+sub _wrap_entry {
+ my $self = shift;
+ my $entry = shift;
+ require File::KDBX::Entry;
+ return File::KDBX::Entry->wrap($entry, $self);
+}
+
+
+sub entries {
+ my $self = shift;
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
+ my $base = delete $args{base} // $self->root;
+
+ return $base->entries_deeply(%args);
+}
+
+##############################################################################
+
+
+sub objects {
+ my $self = shift;
+ my %args = @_ % 2 == 0 ? @_ : (base => shift, @_);
+ my $base = delete $args{base} // $self->root;
+
+ return $base->objects_deeply(%args);
+}
+
+sub __iter__ { $_[0]->objects }
+
+##############################################################################
+
+
+sub custom_icon {
+ my $self = shift;
+ my %args = @_ == 2 ? (uuid => shift, data => shift)
+ : @_ % 2 == 1 ? (uuid => shift, @_) : @_;
+
+ if (!$args{uuid} && !$args{data}) {
+ my %standard = (uuid => 1, data => 1, name => 1, last_modification_time => 1);
+ my @other_keys = grep { !$standard{$_} } keys %args;
+ if (@other_keys == 1) {
+ my $key = $args{key} = $other_keys[0];
+ $args{data} = delete $args{$key};
+ }
+ }
+
+ my $uuid = $args{uuid} or throw 'Must provide a custom icon UUID to access';
+ my $icon = (first { $_->{uuid} eq $uuid } @{$self->custom_icons}) // do {
+ push @{$self->custom_icons}, my $i = { uuid => $uuid };
+ $i;
+ };
+
+ my $fields = \%args;
+ $fields = $args{data} if is_plain_hashref($args{data});
+
+ while (my ($field, $value) = each %$fields) {
+ $icon->{$field} = $value;
+ }
+ return $icon;
+}
+
+
+sub custom_icon_data {
+ my $self = shift;
+ my $uuid = shift // return;
+ my $icon = first { $_->{uuid} eq $uuid } @{$self->custom_icons} or return;
+ return $icon->{data};
+}
+
+
+sub add_custom_icon {
+ my $self = shift;
+ my %args = @_ % 2 == 1 ? (data => shift, @_) : @_;
+
+ defined $args{data} or throw 'Must provide image data';
+
+ my $uuid = $args{uuid} // generate_uuid;
+ push @{$self->custom_icons}, {
+ @_,
+ uuid => $uuid,
+ data => $args{data},
+ };
+ return $uuid;
+}
+
+
+sub remove_custom_icon {
+ my $self = shift;
+ my $uuid = shift;
+ my @deleted;
+ @{$self->custom_icons} = grep { $_->{uuid} eq $uuid ? do { push @deleted, $_; 0 } : 1 }
+ @{$self->custom_icons};
+ $self->add_deleted_object($uuid) if @deleted;
+ return @deleted;
+}
+
+##############################################################################
+
+
+sub custom_data {
+ my $self = shift;
+ $self->{meta}{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{meta}{custom_data} //= {} if !@_;
+
+ my %args = @_ == 2 ? (key => shift, value => shift)
+ : @_ % 2 == 1 ? (key => shift, @_) : @_;
+
+ if (!$args{key} && !$args{value}) {
+ my %standard = (key => 1, value => 1, last_modification_time => 1);
+ my @other_keys = grep { !$standard{$_} } keys %args;
+ if (@other_keys == 1) {
+ my $key = $args{key} = $other_keys[0];
+ $args{value} = delete $args{$key};
+ }
+ }
+
+ my $key = $args{key} or throw 'Must provide a custom_data key to access';
+
+ return $self->{meta}{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{meta}{custom_data}{$key}{$field} = $value;
+ }
+ return $self->{meta}{custom_data}{$key};
+}
+
+
+sub custom_data_value {
+ my $self = shift;
+ my $data = $self->custom_data(@_) // return;
+ return $data->{value};
+}
+
+
+sub public_custom_data {
+ my $self = shift;
+ $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA} //= {} if !@_;
+
+ my $key = shift or throw 'Must provide a public_custom_data key to access';
+ $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key} = shift if @_;
+ return $self->{headers}{+HEADER_PUBLIC_CUSTOM_DATA}{$key};
+}
+
+##############################################################################
+
+# TODO
+
+# sub merge_to {
+# my $self = shift;
+# my $other = shift;
+# my %options = @_; # prefer_old / prefer_new
+# $other->merge_from($self);
+# }
+
+# sub merge_from {
+# my $self = shift;
+# my $other = shift;
+
+# die 'Not implemented';
+# }
+
+
+sub add_deleted_object {
+ my $self = shift;
+ my $uuid = shift;
+
+ # ignore null and meta stream UUIDs
+ return if $uuid eq UUID_NULL || $uuid eq '0' x 16;
+
+ $self->deleted_objects->{$uuid} = {
+ uuid => $uuid,
+ deletion_time => scalar gmtime,
+ };
+}
+
+
+sub remove_deleted_object {
+ my $self = shift;
+ my $uuid = shift;
+ delete $self->deleted_objects->{$uuid};
+}
+
+
+sub clear_deleted_objects {
+ my $self = shift;
+ %{$self->deleted_objects} = ();
+}
+
+##############################################################################
+
+
+sub resolve_reference {
+ my $self = shift;
+ my $wanted = shift // return;
+ my $search_in = shift;
+ my $text = shift;
+
+ if (!defined $text) {
+ $wanted =~ s/^\{REF:([^\}]+)\}$/$1/i;
+ ($wanted, $search_in, $text) = $wanted =~ /^([TUPANI])\@([TUPANIO]):(.*)$/i;
+ }
+ $wanted && $search_in && nonempty($text) or return;
+
+ my %fields = (
+ T => 'expand_title',
+ U => 'expand_username',
+ P => 'expand_password',
+ A => 'expand_url',
+ N => 'expand_notes',
+ I => 'uuid',
+ O => 'other_strings',
+ );
+ $wanted = $fields{$wanted} or return;
+ $search_in = $fields{$search_in} or return;
+
+ my $query = $search_in eq 'uuid' ? query($search_in => uuid($text))
+ : simple_expression_query($text, '=~', $search_in);
+
+ my $entry = $self->entries->grep($query)->next;
+ $entry or return;
+
+ return $entry->$wanted;
+}
+
+our %PLACEHOLDERS = (
+ # 'PLACEHOLDER' => sub { my ($entry, $arg) = @_; ... };
+ 'TITLE' => sub { $_[0]->expand_title },
+ 'USERNAME' => sub { $_[0]->expand_username },
+ 'PASSWORD' => sub { $_[0]->expand_password },
+ 'NOTES' => sub { $_[0]->expand_notes },
+ 'S:' => sub { $_[0]->string_value($_[1]) },
+ 'URL' => sub { $_[0]->expand_url },
+ 'URL:RMVSCM' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ },
+ 'URL:WITHOUTSCHEME' => sub { local $_ = $_[0]->url; s!^[^:/\?\#]+://!!; $_ },
+ 'URL:SCM' => sub { (split_url($_[0]->url))[0] },
+ 'URL:SCHEME' => sub { (split_url($_[0]->url))[0] }, # non-standard
+ 'URL:HOST' => sub { (split_url($_[0]->url))[2] },
+ 'URL:PORT' => sub { (split_url($_[0]->url))[3] },
+ 'URL:PATH' => sub { (split_url($_[0]->url))[4] },
+ 'URL:QUERY' => sub { (split_url($_[0]->url))[5] },
+ 'URL:HASH' => sub { (split_url($_[0]->url))[6] }, # non-standard
+ 'URL:FRAGMENT' => sub { (split_url($_[0]->url))[6] }, # non-standard
+ 'URL:USERINFO' => sub { (split_url($_[0]->url))[1] },
+ 'URL:USERNAME' => sub { (split_url($_[0]->url))[7] },
+ 'URL:PASSWORD' => sub { (split_url($_[0]->url))[8] },
+ 'UUID' => sub { local $_ = format_uuid($_[0]->uuid); s/-//g; $_ },
+ 'REF:' => sub { $_[0]->kdbx->resolve_reference($_[1]) },
+ 'INTERNETEXPLORER' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('iexplore') },
+ 'FIREFOX' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('firefox') },
+ 'GOOGLECHROME' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('google-chrome') },
+ 'OPERA' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('opera') },
+ 'SAFARI' => sub { load_optional('IPC::Cmd'); IPC::Cmd::can_run('safari') },
+ 'APPDIR' => sub { load_optional('FindBin'); $FindBin::Bin },
+ 'GROUP' => sub { my $p = $_[0]->group; $p ? $p->name : undef },
+ 'GROUP_PATH' => sub { $_[0]->path },
+ 'GROUP_NOTES' => sub { my $p = $_[0]->group; $p ? $p->notes : undef },
+ # 'GROUP_SEL'
+ # 'GROUP_SEL_PATH'
+ # 'GROUP_SEL_NOTES'
+ # 'DB_PATH'
+ # 'DB_DIR'
+ # 'DB_NAME'
+ # 'DB_BASENAME'
+ # 'DB_EXT'
+ 'ENV:' => sub { $ENV{$_[1]} },
+ 'ENV_DIRSEP' => sub { load_optional('File::Spec')->catfile('', '') },
+ 'ENV_PROGRAMFILES_X86' => sub { $ENV{'ProgramFiles(x86)'} || $ENV{'ProgramFiles'} },
+ # 'T-REPLACE-RX:'
+ # 'T-CONV:'
+ 'DT_SIMPLE' => sub { localtime->strftime('%Y%m%d%H%M%S') },
+ 'DT_YEAR' => sub { localtime->strftime('%Y') },
+ 'DT_MONTH' => sub { localtime->strftime('%m') },
+ 'DT_DAY' => sub { localtime->strftime('%d') },
+ 'DT_HOUR' => sub { localtime->strftime('%H') },
+ 'DT_MINUTE' => sub { localtime->strftime('%M') },
+ 'DT_SECOND' => sub { localtime->strftime('%S') },
+ 'DT_UTC_SIMPLE' => sub { gmtime->strftime('%Y%m%d%H%M%S') },
+ 'DT_UTC_YEAR' => sub { gmtime->strftime('%Y') },
+ 'DT_UTC_MONTH' => sub { gmtime->strftime('%m') },
+ 'DT_UTC_DAY' => sub { gmtime->strftime('%d') },
+ 'DT_UTC_HOUR' => sub { gmtime->strftime('%H') },
+ 'DT_UTC_MINUTE' => sub { gmtime->strftime('%M') },
+ 'DT_UTC_SECOND' => sub { gmtime->strftime('%S') },
+ # 'PICKCHARS'
+ # 'PICKCHARS:'
+ # 'PICKFIELD'
+ # 'NEWPASSWORD'
+ # 'NEWPASSWORD:'
+ # 'PASSWORD_ENC'
+ 'HMACOTP' => sub { $_[0]->hmac_otp },
+ 'TIMEOTP' => sub { $_[0]->time_otp },
+ 'C:' => sub { '' }, # comment
+ # 'BASE'
+ # 'BASE:'
+ # 'CLIPBOARD'
+ # 'CLIPBOARD-SET:'
+ # 'CMD:'
+);
+
+##############################################################################
+
+
+sub _safe {
+ my $self = shift;
+ $SAFE{$self} = shift if @_;
+ $SAFE{$self};
+}
+
+sub _remove_safe { delete $SAFE{$_[0]} }
+
+sub lock {
+ my $self = shift;
+
+ $self->_safe and return $self;
+
+ my @strings;
+
+ $self->entries(history => 1)->each(sub {
+ push @strings, grep { $_->{protect} } values %{$_->strings}, values %{$_->binaries};
+ });
+
+ $self->_safe(File::KDBX::Safe->new(\@strings));
+
+ return $self;
+}
+
+
+sub unlock {
+ my $self = shift;
+ my $safe = $self->_safe or return $self;
+
+ $safe->unlock;
+ $self->_remove_safe;
+
+ return $self;
+}
+
+
+sub unlock_scoped {
+ throw 'Programmer error: Cannot call unlock_scoped in void context' if !defined wantarray;
+ my $self = shift;
+ return if !$self->is_locked;
+ require Scope::Guard;
+ my $guard = Scope::Guard->new(sub { $self->lock });
+ $self->unlock;
+ return $guard;
+}
+
+
+sub peek {
+ my $self = shift;
+ my $string = shift;
+ my $safe = $self->_safe or return;
+ return $safe->peek($string);
+}
+
+
+sub is_locked { $_[0]->_safe ? 1 : 0 }
+
+##############################################################################
+
+# sub check {
+# - Fixer tool. Can repair inconsistencies, including:
+# - Orphaned binaries... not really a thing anymore since we now distribute binaries amongst entries
+# - Unused custom icons (OFF, data loss)
+# - Duplicate icons
+# - All data types are valid
+# - date times are correct
+# - boolean fields
+# - All UUIDs refer to things that exist
+# - previous parent group
+# - recycle bin
+# - last selected group
+# - last visible group
+# - Enforce history size limits (ON)
+# - Check headers/meta (ON)
+# - Duplicate deleted objects (ON)
+# - Duplicate window associations (OFF)
+# - Header UUIDs match known ciphers/KDFs?
+# }
+
+
+sub remove_empty_groups {
+ my $self = shift;
+ my @removed;
+ $self->groups(algorithm => 'dfs')
+ ->where(-true => 'is_empty')
+ ->each(sub { push @removed, $_->remove });
+ return @removed;
+}
+
+
+sub remove_unused_icons {
+ my $self = shift;
+ my %icons = map { $_->{uuid} => 0 } @{$self->custom_icons};
+
+ $self->objects->each(sub { ++$icons{$_->custom_icon_uuid // ''} });
+
+ my @removed;
+ push @removed, $self->remove_custom_icon($_) for grep { $icons{$_} == 0 } keys %icons;
+ return @removed;
+}
+
+
+sub remove_duplicate_icons {
+ my $self = shift;
+
+ my %seen;
+ my %dup;
+ for my $icon (@{$self->custom_icons}) {
+ my $digest = digest_data('SHA256', $icon->{data});
+ if (my $other = $seen{$digest}) {
+ $dup{$icon->{uuid}} = $other->{uuid};
+ }
+ else {
+ $seen{$digest} = $icon;
+ }
+ }
+
+ my @removed;
+ while (my ($old_uuid, $new_uuid) = each %dup) {
+ $self->objects
+ ->where(custom_icon_uuid => $old_uuid)
+ ->each(sub { $_->custom_icon_uuid($new_uuid) });
+ push @removed, $self->remove_custom_icon($old_uuid);
+ }
+ return @removed;
+}
+
+
+sub prune_history {
+ my $self = shift;
+ my %args = @_;
+
+ my $max_items = $args{max_items} // $self->history_max_items // HISTORY_DEFAULT_MAX_ITEMS;
+ my $max_size = $args{max_size} // $self->history_max_size // HISTORY_DEFAULT_MAX_SIZE;
+ my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE;
+
+ my @removed;
+ $self->entries->each(sub {
+ push @removed, $_->prune_history(
+ max_items => $max_items,
+ max_size => $max_size,
+ max_age => $max_age,
+ );
+ });
+ return @removed;
+}
+
+
+sub randomize_seeds {
+ my $self = shift;
+ $self->encryption_iv(random_bytes(16));
+ $self->inner_random_stream_key(random_bytes(64));
+ $self->master_seed(random_bytes(32));
+ $self->stream_start_bytes(random_bytes(32));
+ $self->transform_seed(random_bytes(32));
+}
+
+##############################################################################
+
+
+sub key {
+ my $self = shift;
+ $KEYS{$self} = File::KDBX::Key->new(@_) if @_;
+ $KEYS{$self};
+}
+
+
+sub composite_key {
+ my $self = shift;
+ require File::KDBX::Key::Composite;
+ return File::KDBX::Key::Composite->new(@_);
+}
+
+
+sub kdf {
+ my $self = shift;
+ my %args = @_ % 2 == 1 ? (params => shift, @_) : @_;
+
+ my $params = $args{params};
+ my $compat = $args{compatible} // 1;
+
+ $params //= $self->kdf_parameters;
+ $params = {%{$params || {}}};
+
+ if (empty $params || !defined $params->{+KDF_PARAM_UUID}) {
+ $params->{+KDF_PARAM_UUID} = KDF_UUID_AES;
+ }
+ if ($params->{+KDF_PARAM_UUID} eq KDF_UUID_AES) {
+ # AES_CHALLENGE_RESPONSE is equivalent to AES if there are no challenge-response keys, and since
+ # non-KeePassXC implementations don't support challenge-response keys anyway, there's no problem with
+ # always using AES_CHALLENGE_RESPONSE for all KDBX4+ databases.
+ # For compatibility, we should not *write* AES_CHALLENGE_RESPONSE, but the dumper handles that.
+ if ($self->version >= KDBX_VERSION_4_0) {
+ $params->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE;
+ }
+ $params->{+KDF_PARAM_AES_SEED} //= $self->transform_seed;
+ $params->{+KDF_PARAM_AES_ROUNDS} //= $self->transform_rounds;
+ }
+
+ require File::KDBX::KDF;
+ return File::KDBX::KDF->new(%$params);
+}
+
+sub transform_seed {
+ my $self = shift;
+ $self->headers->{+HEADER_TRANSFORM_SEED} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} = shift if @_;
+ $self->headers->{+HEADER_TRANSFORM_SEED} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_SEED} //= random_bytes(32);
+}
+
+sub transform_rounds {
+ my $self = shift;
+ $self->headers->{+HEADER_TRANSFORM_ROUNDS} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} = shift if @_;
+ $self->headers->{+HEADER_TRANSFORM_ROUNDS} =
+ $self->headers->{+HEADER_KDF_PARAMETERS}{+KDF_PARAM_AES_ROUNDS} //= 100_000;
+}
+
+
+sub cipher {
+ my $self = shift;
+ my %args = @_;
+
+ $args{uuid} //= $self->headers->{+HEADER_CIPHER_ID};
+ $args{iv} //= $self->headers->{+HEADER_ENCRYPTION_IV};
+
+ require File::KDBX::Cipher;
+ return File::KDBX::Cipher->new(%args);
+}
+
+
+sub random_stream {
+ my $self = shift;
+ my %args = @_;
+
+ $args{stream_id} //= delete $args{id} // $self->inner_random_stream_id;
+ $args{key} //= $self->inner_random_stream_key;
+
+ require File::KDBX::Cipher;
+ File::KDBX::Cipher->new(%args);
+}
+
+sub inner_random_stream_id {
+ my $self = shift;
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID}
+ = $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} = shift if @_;
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_ID}
+ //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_ID} //= do {
+ my $version = $self->minimum_version;
+ $version < KDBX_VERSION_4_0 ? STREAM_ID_SALSA20 : STREAM_ID_CHACHA20;
+ };
+}
+
+sub inner_random_stream_key {
+ my $self = shift;
+ if (@_) {
+ # These are probably the same SvPV so erasing one will CoW, but erasing the second should do the
+ # trick anyway.
+ erase \$self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY};
+ erase \$self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY};
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}
+ = $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = shift;
+ }
+ $self->inner_headers->{+INNER_HEADER_INNER_RANDOM_STREAM_KEY}
+ //= $self->headers->{+HEADER_INNER_RANDOM_STREAM_KEY} //= random_bytes(64); # 32
+}
+
+#########################################################################################
+
+sub _handle_signal {
+ my $self = shift;
+ my $object = shift;
+ my $type = shift;
+
+ my %handlers = (
+ 'entry.added' => \&_handle_object_added,
+ 'group.added' => \&_handle_object_added,
+ 'entry.removed' => \&_handle_object_removed,
+ 'group.removed' => \&_handle_object_removed,
+ 'entry.uuid.changed' => \&_handle_entry_uuid_changed,
+ 'group.uuid.changed' => \&_handle_group_uuid_changed,
+ );
+ my $handler = $handlers{$type} or return;
+ $self->$handler($object, @_);
+}
+
+sub _handle_object_added {
+ my $self = shift;
+ my $object = shift;
+ $self->remove_deleted_object($object->uuid);
+}
+
+sub _handle_object_removed {
+ my $self = shift;
+ my $object = shift;
+ my $old_uuid = $object->{uuid} // return;
+
+ my $meta = $self->meta;
+ $self->recycle_bin_uuid(UUID_NULL) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+ $self->entry_templates_group(UUID_NULL) if $old_uuid eq ($meta->{entry_templates_group} // '');
+ $self->last_selected_group(UUID_NULL) if $old_uuid eq ($meta->{last_selected_group} // '');
+ $self->last_top_visible_group(UUID_NULL) if $old_uuid eq ($meta->{last_top_visible_group} // '');
+
+ $self->add_deleted_object($old_uuid);
+}
+
+sub _handle_entry_uuid_changed {
+ my $self = shift;
+ my $object = shift;
+ my $new_uuid = shift;
+ my $old_uuid = shift // return;
+
+ my $old_pretty = format_uuid($old_uuid);
+ my $new_pretty = format_uuid($new_uuid);
+ my $fieldref_match = qr/\{REF:([TUPANI])\@I:\Q$old_pretty\E\}/is;
+
+ $self->entries->each(sub {
+ $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');
+
+ for my $string (values %{$_->strings}) {
+ next if !defined $string->{value} || $string->{value} !~ $fieldref_match;
+ my $txn = $_->begin_work;
+ $string->{value} =~ s/$fieldref_match/{REF:$1\@I:$new_pretty}/g;
+ $txn->commit;
+ }
+ });
+}
+
+sub _handle_group_uuid_changed {
+ my $self = shift;
+ my $object = shift;
+ my $new_uuid = shift;
+ my $old_uuid = shift // return;
+
+ my $meta = $self->meta;
+ $self->recycle_bin_uuid($new_uuid) if $old_uuid eq ($meta->{recycle_bin_uuid} // '');
+ $self->entry_templates_group($new_uuid) if $old_uuid eq ($meta->{entry_templates_group} // '');
+ $self->last_selected_group($new_uuid) if $old_uuid eq ($meta->{last_selected_group} // '');
+ $self->last_top_visible_group($new_uuid) if $old_uuid eq ($meta->{last_top_visible_group} // '');
+
+ $self->groups->each(sub {
+ $_->last_top_visible_entry($new_uuid) if $old_uuid eq ($_->{last_top_visible_entry} // '');
+ $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');
+ });
+ $self->entries->each(sub {
+ $_->previous_parent_group($new_uuid) if $old_uuid eq ($_->{previous_parent_group} // '');
+ });
+}
+
+#########################################################################################
+
+
+#########################################################################################
+
+sub TO_JSON { +{%{$_[0]}} }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=for markdown [](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/linux.yml)
+[](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/macos.yml)
+[](https://github.com/chazmcgarvey/File-KDBX/actions/workflows/windows.yml)
+
+=for HTML <a title="Linux" href="https://github.com/chazmcgarvey/File-KDBX/actions/workflows/linux.yml"><img src="https://github.com/chazmcgarvey/File-KDBX/actions/workflows/linux.yml/badge.svg"></a>
+<a title="macOS" href="https://github.com/chazmcgarvey/File-KDBX/actions/workflows/macos.yml"><img src="https://github.com/chazmcgarvey/File-KDBX/actions/workflows/macos.yml/badge.svg"></a>
+<a title="Windows" href="https://github.com/chazmcgarvey/File-KDBX/actions/workflows/windows.yml"><img src="https://github.com/chazmcgarvey/File-KDBX/actions/workflows/windows.yml/badge.svg"></a>
+
+=head1 NAME
+
+File::KDBX - Encrypted database to store secret text and files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX;
+
+ my $kdbx = File::KDBX->new;
+
+ my $group = $kdbx->add_group(
+ name => 'Passwords',
+ );
+
+ my $entry = $group->add_entry(
+ title => 'My Bank',
+ password => 's3cr3t',
+ );
+
+ $kdbx->dump_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
+
+ $kdbx = File::KDBX->load_file('passwords.kdbx', 'M@st3rP@ssw0rd!');
+
+ $kdbx->entries->each(sub {
+ my ($entry) = @_;
+ say 'Entry: ', $entry->title;
+ });
+
+See L</RECIPES> for more examples.
+
+=head1 DESCRIPTION
+
+B<File::KDBX> provides everything you need to work with a KDBX database. A KDBX database is a hierarchical
+object database which is commonly used to store secret information securely. It was developed for the KeePass
+password safe. See L</"Introduction to KDBX"> for more information about KDBX.
+
+This module lets you query entries, create new entries, delete entries and modify entries. The distribution
+also includes various parsers and generators for serializing and persisting databases.
+
+This design of this software was influenced by the L<KeePassXC|https://github.com/keepassxreboot/keepassxc>
+implementation of KeePass as well as the L<File::KeePass> module. B<File::KeePass> is an alternative module
+that works well in most cases but has a small backlog of bugs and security issues and also does not work with
+newer KDBX version 4 files. If you're coming here from the B<File::KeePass> world, you might be interested in
+L<File::KeePass::KDBX> that is a drop-in replacement for B<File::KeePass> that uses B<File::KDBX> for storage.
+
+This software is a B<pre-1.0 release>. The interface should be considered pretty stable, but there might be
+minor changes up until a 1.0 release. Breaking changes will be noted in the F<Changes> file.
+
+=head2 Features
+
+This implementation of KDBX supports a lot of features:
+
+=over 4
+
+=item *
+
+☑ Read and write KDBX version 3 - version 4.1
+
+=item *
+
+☑ Read and write KDB files (requires L<File::KeePass>)
+
+=item *
+
+☑ Unicode character strings
+
+=item *
+
+☑ L</"Simple Expression"> Searching
+
+=item *
+
+☑ L<Placeholders|File::KDBX::Entry/Placeholders> and L<field references|/resolve_reference>
+
+=item *
+
+☑ L<One-time passwords|File::KDBX::Entry/"One-time passwords">
+
+=item *
+
+☑ L<Very secure|/SECURITY>
+
+=item *
+
+☑ L</"Memory Protection">
+
+=item *
+
+☑ Challenge-response key components, like L<YubiKey|File::KDBX::Key::YubiKey>
+
+=item *
+
+☑ Variety of L<key file|File::KDBX::Key::File> types: binary, hexed, hashed, XML v1 and v2
+
+=item *
+
+☑ Pluggable registration of different kinds of ciphers and key derivation functions
+
+=item *
+
+☑ Built-in database maintenance functions
+
+=item *
+
+☑ Pretty fast, with L<XS optimizations|File::KDBX::XS> available
+
+=item *
+
+☒ Database synchronization / merging (not yet)
+
+=back
+
+=head2 Introduction to KDBX
+
+A KDBX database consists of a tree of I<groups> and I<entries>, with a single I<root> group. Entries can
+contain zero or more key-value pairs of I<strings> and zero or more I<binaries> (i.e. octet strings). Groups,
+entries, strings and binaries: that's the KDBX vernacular. A small amount of metadata (timestamps, etc.) is
+associated with each entry, group and the database as a whole.
+
+You can think of a KDBX database kind of like a file system, where groups are directories, entries are files,
+and strings and binaries make up a file's contents.
+
+Databases are typically persisted as a encrypted, compressed files. They are usually accessed directly (i.e.
+not over a network). The primary focus of this type of database is data security. It is ideal for storing
+relatively small amounts of data (strings and binaries) that must remain secret except to such individuals as
+have the correct I<master key>. Even if the database file were to be "leaked" to the public Internet, it
+should be virtually impossible to crack with a strong key. The KDBX format is most often used by password
+managers to store passwords so that users can know a single strong password and not have to reuse passwords
+across different websites. See L</SECURITY> for an overview of security considerations.
+
+=head1 ATTRIBUTES
+
+=head2 sig1
+
+=head2 sig2
+
+=head2 version
+
+=head2 headers
+
+=head2 inner_headers
+
+=head2 meta
+
+=head2 binaries
+
+=head2 deleted_objects
+
+Hash of UUIDs for objects that have been deleted. This includes groups, entries and even custom icons.
+
+=head2 raw
+
+Bytes contained within the encrypted layer of a KDBX file. This is only set when using
+L<File::KDBX::Loader::Raw>.
+
+=head2 comment
+
+A text string associated with the database. Often unset.
+
+=head2 cipher_id
+
+The UUID of a cipher used to encrypt the database when stored as a file.
+
+See L</File::KDBX::Cipher>.
+
+=head2 compression_flags
+
+Configuration for whether or not and how the database gets compressed. See
+L<File::KDBX::Constants/":compression">.
+
+=head2 master_seed
+
+The master seed is a string of 32 random bytes that is used as salt in hashing the master key when loading
+and saving the database. If a challenge-response key is used in the master key, the master seed is also the
+challenge.
+
+The master seed I<should> be changed each time the database is saved to file.
+
+=head2 transform_seed
+
+The transform seed is a string of 32 random bytes that is used in the key derivation function, either as the
+salt or the key (depending on the algorithm).
+
+The transform seed I<should> be changed each time the database is saved to file.
+
+=head2 transform_rounds
+
+The number of rounds or iterations used in the key derivation function. Increasing this number makes loading
+and saving the database slower by design in order to make dictionary and brute force attacks more costly.
+
+=head2 encryption_iv
+
+The initialization vector used by the cipher.
+
+The encryption IV I<should> be changed each time the database is saved to file.
+
+=head2 inner_random_stream_key
+
+The encryption key (possibly including the IV, depending on the cipher) used to encrypt the protected strings
+within the database.
+
+=head2 stream_start_bytes
+
+A string of 32 random bytes written in the header and encrypted in the body. If the bytes do not match when
+loading a file then the wrong master key was used or the file is corrupt. Only KDBX 2 and KDBX 3 files use
+this. KDBX 4 files use an improved HMAC method to verify the master key and data integrity of the header and
+entire file body.
+
+=head2 inner_random_stream_id
+
+A number indicating the cipher algorithm used to encrypt the protected strings within the database, usually
+Salsa20 or ChaCha20. See L<File::KDBX::Constants/":random_stream">.
+
+=head2 kdf_parameters
+
+A hash/dict of key-value pairs used to configure the key derivation function. This is the KDBX4+ way to
+configure the KDF, superceding L</transform_seed> and L</transform_rounds>.
+
+=head2 generator
+
+The name of the software used to generate the KDBX file.
+
+=head2 header_hash
+
+The header hash used to verify that the file header is not corrupt. (KDBX 2 - KDBX 3.1, removed KDBX 4.0)
+
+=head2 database_name
+
+Name of the database.
+
+=head2 database_name_changed
+
+Timestamp indicating when the database name was last changed.
+
+=head2 database_description
+
+Description of the database
+
+=head2 database_description_changed
+
+Timestamp indicating when the database description was last changed.
+
+=head2 default_username
+
+When a new entry is created, the I<UserName> string will be populated with this value.
+
+=head2 default_username_changed
+
+Timestamp indicating when the default username was last changed.
+
+=head2 maintenance_history_days
+
+TODO... not really sure what this is. 😀
+
+=head2 color
+
+A color associated with the database (in the form C<#ffffff> where "f" is a hexidecimal digit). Some agents
+use this to help users visually distinguish between different databases.
+
+=head2 master_key_changed
+
+Timestamp indicating when the master key was last changed.
+
+=head2 master_key_change_rec
+
+Number of days until the agent should prompt to recommend changing the master key.
+
+=head2 master_key_change_force
+
+Number of days until the agent should prompt to force changing the master key.
+
+Note: This is purely advisory. It is up to the individual agent software to actually enforce it.
+C<File::KDBX> does NOT enforce it.
+
+=head2 custom_icons
+
+Array of custom icons that can be associated with groups and entries.
+
+This list can be managed with the methods L</add_custom_icon> and L</remove_custom_icon>.
+
+=head2 recycle_bin_enabled
+
+Boolean indicating whether removed groups and entries should go to a recycle bin or be immediately deleted.
+
+=head2 recycle_bin_uuid
+
+The UUID of a group used to store thrown-away groups and entries.
+
+=head2 recycle_bin_changed
+
+Timestamp indicating when the recycle bin was last changed.
+
+=head2 entry_templates_group
+
+The UUID of a group containing template entries used when creating new entries.
+
+=head2 entry_templates_group_changed
+
+Timestamp indicating when the entry templates group was last changed.
+
+=head2 last_selected_group
+
+The UUID of the previously-selected group.
+
+=head2 last_top_visible_group
+
+The UUID of the group visible at the top of the list.
+
+=head2 history_max_items
+
+The maximum number of historical entries allowed to be saved for each entry.
+
+=head2 history_max_size
+
+The maximum total size (in bytes) that each individual entry's history is allowed to grow.
+
+=head2 settings_changed
+
+Timestamp indicating when the database settings were last updated.
+
+=head2 protect_title
+
+Alias of the L</memory_protection> setting for the I<Title> string.
+
+=head2 protect_username
+
+Alias of the L</memory_protection> setting for the I<UserName> string.
+
+=head2 protect_password
+
+Alias of the L</memory_protection> setting for the I<Password> string.
+
+=head2 protect_url
+
+Alias of the L</memory_protection> setting for the I<URL> string.
+
+=head2 protect_notes
+
+Alias of the L</memory_protection> setting for the I<Notes> string.
+
+=head1 METHODS
+
+=head2 new
+
+ $kdbx = File::KDBX->new(%attributes);
+ $kdbx = File::KDBX->new($kdbx); # copy constructor
+
+Construct a new L<File::KDBX>.
+
+=head2 init
+
+ $kdbx = $kdbx->init(%attributes);
+
+Initialize a L<File::KDBX> with a set of attributes. Returns itself to allow method chaining.
+
+This is called by L</new>.
+
+=head2 reset
+
+ $kdbx = $kdbx->reset;
+
+Set a L<File::KDBX> to an empty state, ready to load a KDBX file or build a new one. Returns itself to allow
+method chaining.
+
+=head2 clone
+
+ $kdbx_copy = $kdbx->clone;
+ $kdbx_copy = File::KDBX->new($kdbx);
+
+Clone a L<File::KDBX>. The clone will be an exact copy and completely independent of the original.
+
+=head2 load
+
+=head2 load_string
+
+=head2 load_file
+
+=head2 load_handle
+
+ $kdbx = KDBX::File->load(\$string, $key);
+ $kdbx = KDBX::File->load(*IO, $key);
+ $kdbx = KDBX::File->load($filepath, $key);
+ $kdbx->load(...); # also instance method
+
+ $kdbx = File::KDBX->load_string($string, $key);
+ $kdbx = File::KDBX->load_string(\$string, $key);
+ $kdbx->load_string(...); # also instance method
+
+ $kdbx = File::KDBX->load_file($filepath, $key);
+ $kdbx->load_file(...); # also instance method
+
+ $kdbx = File::KDBX->load_handle($fh, $key);
+ $kdbx = File::KDBX->load_handle(*IO, $key);
+ $kdbx->load_handle(...); # also instance method
+
+Load a KDBX file from a string buffer, IO handle or file from a filesystem.
+
+L<File::KDBX::Loader> does the heavy lifting.
+
+=head2 dump
+
+=head2 dump_string
+
+=head2 dump_file
+
+=head2 dump_handle
+
+ $kdbx->dump(\$string, $key);
+ $kdbx->dump(*IO, $key);
+ $kdbx->dump($filepath, $key);
+
+ $kdbx->dump_string(\$string, $key);
+ \$string = $kdbx->dump_string($key);
+
+ $kdbx->dump_file($filepath, $key);
+
+ $kdbx->dump_handle($fh, $key);
+ $kdbx->dump_handle(*IO, $key);
+
+Dump a KDBX file to a string buffer, IO handle or file in a filesystem.
+
+L<File::KDBX::Dumper> does the heavy lifting.
+
+=head2 user_agent_string
+
+ $string = $kdbx->user_agent_string;
+
+Get a text string identifying the database client software.
+
+=head2 memory_protection
+
+ \%settings = $kdbx->memory_protection
+ $kdbx->memory_protection(\%settings);
+
+ $bool = $kdbx->memory_protection($string_key);
+ $kdbx->memory_protection($string_key => $bool);
+
+Get or set memory protection settings. This globally (for the whole database) configures whether and which of
+the standard strings should be memory-protected. The default setting is to memory-protect only I<Password>
+strings.
+
+Memory protection can be toggled individually for each entry string, and individual settings take precedence
+over these global settings.
+
+=head2 minimum_version
+
+ $version = $kdbx->minimum_version;
+
+Determine the minimum file version required to save a database losslessly. Using certain databases features
+might increase this value. For example, setting the KDF to Argon2 will increase the minimum version to at
+least C<KDBX_VERSION_4_0> (i.e. C<0x00040000>) because Argon2 was introduced with KDBX4.
+
+This method never returns less than C<KDBX_VERSION_3_1> (i.e. C<0x00030001>). That file version is so
+ubiquitious and well-supported, there are seldom reasons to dump in a lesser format nowadays.
+
+B<WARNING:> If you dump a database with a minimum version higher than the current L</version>, the dumper will
+typically issue a warning and automatically upgrade the database. This seems like the safest behavior in order
+to avoid data loss, but lower versions have the benefit of being compatible with more software. It is possible
+to prevent auto-upgrades by explicitly telling the dumper which version to use, but you do run the risk of
+data loss. A database will never be automatically downgraded.
+
+=head2 root
+
+ $group = $kdbx->root;
+ $kdbx->root($group);
+
+Get or set a database's root group. You don't necessarily need to explicitly create or set a root group
+because it autovivifies when adding entries and groups to the database.
+
+Every database has only a single root group at a time. Some old KDB files might have multiple root groups.
+When reading such files, a single implicit root group is created to contain the actual root groups. When
+writing to such a format, if the root group looks like it was implicitly created then it won't be written and
+the resulting file might have multiple root groups. This allows working with older files without changing
+their written internal structure while still adhering to modern semantics while the database is opened.
+
+The root group of a KDBX database contains all of the database's entries and other groups. If you replace the
+root group, you are essentially replacing the entire database contents with something else.
+
+=head2 trace_lineage
+
+ \@lineage = $kdbx->trace_lineage($group);
+ \@lineage = $kdbx->trace_lineage($group, $base_group);
+ \@lineage = $kdbx->trace_lineage($entry);
+ \@lineage = $kdbx->trace_lineage($entry, $base_group);
+
+Get the direct line of ancestors from C<$base_group> (default: the root group) to a group or entry. The
+lineage includes the base group but I<not> the target group or entry. Returns C<undef> if the target is not in
+the database structure.
+
+=head2 recycle_bin
+
+ $group = $kdbx->recycle_bin;
+ $kdbx->recycle_bin($group);
+
+Get or set the recycle bin group. Returns C<undef> if there is no recycle bin and L</recycle_bin_enabled> is
+false, otherwise the current recycle bin or an autovivified recycle bin group is returned.
+
+=head2 entry_templates
+
+ $group = $kdbx->entry_templates;
+ $kdbx->entry_templates($group);
+
+Get or set the entry templates group. May return C<undef> if unset.
+
+=head2 last_selected
+
+ $group = $kdbx->last_selected;
+ $kdbx->last_selected($group);
+
+Get or set the last selected group. May return C<undef> if unset.
+
+=head2 last_top_visible
+
+ $group = $kdbx->last_top_visible;
+ $kdbx->last_top_visible($group);
+
+Get or set the last top visible group. May return C<undef> if unset.
+
+=head2 add_group
+
+ $kdbx->add_group($group);
+ $kdbx->add_group(%group_attributes, %options);
+
+Add a group to a database. This is equivalent to identifying a parent group and calling
+L<File::KDBX::Group/add_group> on the parent group, forwarding the arguments. Available options:
+
+=over 4
+
+=item *
+
+C<group> (aka C<parent>) - Group object or group UUID to add the group to (default: root group)
+
+=back
+
+=head2 groups
+
+ \&iterator = $kdbx->groups(%options);
+ \&iterator = $kdbx->groups($base_group, %options);
+
+Get an L<File::KDBX::Iterator> over I<groups> within a database. Options:
+
+=over 4
+
+=item *
+
+C<base> - Only include groups within a base group (same as C<$base_group>) (default: L</root>)
+
+=item *
+
+C<inclusive> - Include the base group in the results (default: true)
+
+=item *
+
+C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>)
+
+=back
+
+=head2 add_entry
+
+ $kdbx->add_entry($entry, %options);
+ $kdbx->add_entry(%entry_attributes, %options);
+
+Add a entry to a database. This is equivalent to identifying a parent group and calling
+L<File::KDBX::Group/add_entry> on the parent group, forwarding the arguments. Available options:
+
+=over 4
+
+=item *
+
+C<group> (aka C<parent>) - Group object or group UUID to add the entry to (default: root group)
+
+=back
+
+=head2 entries
+
+ \&iterator = $kdbx->entries(%options);
+ \&iterator = $kdbx->entries($base_group, %options);
+
+Get an L<File::KDBX::Iterator> over I<entries> within a database. Supports the same options as L</groups>,
+plus some new ones:
+
+=over 4
+
+=item *
+
+C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
+
+=item *
+
+C<searching> - Only include entries within groups with searching enabled (default: false, include all)
+
+=item *
+
+C<history> - Also include historical entries (default: false, include only current entries)
+
+=back
+
+=head2 objects
+
+ \&iterator = $kdbx->objects(%options);
+ \&iterator = $kdbx->objects($base_group, %options);
+
+Get an L<File::KDBX::Iterator> over I<objects> within a database. Groups and entries are considered objects,
+so this is essentially a combination of L</groups> and L</entries>. This won't often be useful, but it can be
+convenient for maintenance tasks. This method takes the same options as L</groups> and L</entries>.
+
+=head2 custom_icon
+
+ \%icon = $kdbx->custom_icon($uuid);
+ $kdbx->custom_icon($uuid => \%icon);
+ $kdbx->custom_icon(%icon);
+ $kdbx->custom_icon(uuid => $value, %icon);
+
+Get or set custom icons.
+
+=head2 custom_icon_data
+
+ $image_data = $kdbx->custom_icon_data($uuid);
+
+Get a custom icon image data.
+
+=head2 add_custom_icon
+
+ $uuid = $kdbx->add_custom_icon($image_data, %attributes);
+ $uuid = $kdbx->add_custom_icon(%attributes);
+
+Add a custom icon and get its UUID. If not provided, a random UUID will be generated. Possible attributes:
+
+=over 4
+
+=item *
+
+C<uuid> - Icon UUID (default: autogenerated)
+
+=item *
+
+C<data> - Image data (same as C<$image_data>)
+
+=item *
+
+C<name> - Name of the icon (text, KDBX4.1+)
+
+=item *
+
+C<last_modification_time> - Just what it says (datetime, KDBX4.1+)
+
+=back
+
+=head2 remove_custom_icon
+
+ $kdbx->remove_custom_icon($uuid);
+
+Remove a custom icon.
+
+=head2 custom_data
+
+ \%all_data = $kdbx->custom_data;
+ $kdbx->custom_data(\%all_data);
+
+ \%data = $kdbx->custom_data($key);
+ $kdbx->custom_data($key => \%data);
+ $kdbx->custom_data(%data);
+ $kdbx->custom_data(key => $value, %data);
+
+Get and set custom data. Custom data is metadata associated with a database.
+
+Each data item can have a few attributes associated with it.
+
+=over 4
+
+=item *
+
+C<key> - A unique text string identifier used to look up the data item (required)
+
+=item *
+
+C<value> - A text string value (required)
+
+=item *
+
+C<last_modification_time> (optional, KDBX4.1+)
+
+=back
+
+=head2 custom_data_value
+
+ $value = $kdbx->custom_data_value($key);
+
+Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of
+attributes. This is a shortcut for:
+
+ my $data = $kdbx->custom_data($key);
+ my $value = defined $data ? $data->{value} : undef;
+
+=head2 public_custom_data
+
+ \%all_data = $kdbx->public_custom_data;
+ $kdbx->public_custom_data(\%all_data);
+
+ $value = $kdbx->public_custom_data($key);
+ $kdbx->public_custom_data($key => $value);
+
+Get and set public custom data. Public custom data is similar to custom data but different in some important
+ways. Public custom data:
+
+=over 4
+
+=item *
+
+can store strings, booleans and up to 64-bit integer values (custom data can only store text values)
+
+=item *
+
+is NOT encrypted within a KDBX file (hence the "public" part of the name)
+
+=item *
+
+is a plain hash/dict of key-value pairs with no other associated fields (like modification times)
+
+=back
+
+=head2 add_deleted_object
+
+ $kdbx->add_deleted_object($uuid);
+
+Add a UUID to the deleted objects list. This list is used to support automatic database merging.
+
+You typically do not need to call this yourself because the list will be populated automatically as objects
+are removed.
+
+=head2 remove_deleted_object
+
+ $kdbx->remove_deleted_object($uuid);
+
+Remove a UUID from the deleted objects list. This list is used to support automatic database merging.
+
+You typically do not need to call this yourself because the list will be maintained automatically as objects
+are added.
+
+=head2 clear_deleted_objects
+
+Remove all UUIDs from the deleted objects list. This list is used to support automatic database merging, but
+if you don't need merging then you can clear deleted objects to reduce the database file size.
+
+=head2 resolve_reference
+
+ $string = $kdbx->resolve_reference($reference);
+ $string = $kdbx->resolve_reference($wanted, $search_in, $expression);
+
+Resolve a L<field reference|https://keepass.info/help/base/fieldrefs.html>. A field reference is a kind of
+string placeholder. You can use a field reference to refer directly to a standard field within an entry. Field
+references are resolved automatically while expanding entry strings (i.e. replacing placeholders), but you can
+use this method to resolve on-the-fly references that aren't part of any actual string in the database.
+
+If the reference does not resolve to any field, C<undef> is returned. If the reference resolves to multiple
+fields, only the first one is returned (in the same order as iterated by L</entries>). To avoid ambiguity, you
+can refer to a specific entry by its UUID.
+
+The syntax of a reference is: C<< {REF:<WantedField>@<SearchIn>:<Text>} >>. C<Text> is a
+L</"Simple Expression">. C<WantedField> and C<SearchIn> are both single character codes representing a field:
+
+=over 4
+
+=item *
+
+C<T> - Title
+
+=item *
+
+C<U> - UserName
+
+=item *
+
+C<P> - Password
+
+=item *
+
+C<A> - URL
+
+=item *
+
+C<N> - Notes
+
+=item *
+
+C<I> - UUID
+
+=item *
+
+C<O> - Other custom strings
+
+=back
+
+Since C<O> does not represent any specific field, it cannot be used as the C<WantedField>.
+
+Examples:
+
+To get the value of the I<UserName> string of the first entry with "My Bank" in the title:
+
+ my $username = $kdbx->resolve_reference('{REF:U@T:"My Bank"}');
+ # OR the {REF:...} wrapper is optional
+ my $username = $kdbx->resolve_reference('U@T:"My Bank"');
+ # OR separate the arguments
+ my $username = $kdbx->resolve_reference(U => T => '"My Bank"');
+
+Note how the text is a L</"Simple Expression">, so search terms with spaces must be surrounded in double
+quotes.
+
+To get the I<Password> string of a specific entry (identified by its UUID):
+
+ my $password = $kdbx->resolve_reference('{REF:P@I:46C9B1FFBD4ABC4BBB260C6190BAD20C}');
+
+=head2 lock
+
+ $kdbx->lock;
+
+Encrypt all protected binaries strings in a database. The encrypted strings are stored in
+a L<File::KDBX::Safe> associated with the database and the actual strings will be replaced with C<undef> to
+indicate their protected state. Returns itself to allow method chaining.
+
+You can call C<code> on an already-locked database to memory-protect any unprotected strings and binaries
+added after the last time the database was locked.
+
+=head2 unlock
+
+ $kdbx->unlock;
+
+Decrypt all protected strings in a database, replacing C<undef> placeholders with unprotected values. Returns
+itself to allow method chaining.
+
+=head2 unlock_scoped
+
+ $guard = $kdbx->unlock_scoped;
+
+Unlock a database temporarily, relocking when the guard is released (typically at the end of a scope). Returns
+C<undef> if the database is already unlocked.
+
+See L</lock> and L</unlock>.
+
+=head2 peek
+
+ $string = $kdbx->peek(\%string);
+ $string = $kdbx->peek(\%binary);
+
+Peek at the value of a protected string or binary without unlocking the whole database. The argument can be
+a string or binary hashref as returned by L<File::KDBX::Entry/string> or L<File::KDBX::Entry/binary>.
+
+=head2 is_locked
+
+ $bool = $kdbx->is_locked;
+
+Get whether or not a database's strings are memory-protected. If this is true, then some or all of the
+protected strings within the database will be unavailable (literally have C<undef> values) until L</unlock> is
+called.
+
+=head2 remove_empty_groups
+
+ $kdbx->remove_empty_groups;
+
+Remove groups with no subgroups and no entries.
+
+=head2 remove_unused_icons
+
+ $kdbx->remove_unused_icons;
+
+Remove icons that are not associated with any entry or group in the database.
+
+=head2 remove_duplicate_icons
+
+ $kdbx->remove_duplicate_icons;
+
+Remove duplicate icons as determined by hashing the icon data.
+
+=head2 prune_history
+
+ $kdbx->prune_history(%options);
+
+Remove just as many older historical entries as necessary to get under certain limits.
+
+=over 4
+
+=item *
+
+C<max_items> - Maximum number of historical entries to keep (default: value of L</history_max_items>, no limit: -1)
+
+=item *
+
+C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: value of L</history_max_size>, no limit: -1)
+
+=item *
+
+C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1)
+
+=back
+
+=head2 randomize_seeds
+
+ $kdbx->randomize_seeds;
+
+Set various keys, seeds and IVs to random values. These values are used by the cryptographic functions that
+secure the database when dumped. The attributes that will be randomized are:
+
+=over 4
+
+=item *
+
+L</encryption_iv>
+
+=item *
+
+L</inner_random_stream_key>
+
+=item *
+
+L</master_seed>
+
+=item *
+
+L</stream_start_bytes>
+
+=item *
+
+L</transform_seed>
+
+=back
+
+Randomizing these values has no effect on a loaded database. These are only used when a database is dumped.
+You normally do not need to call this method explicitly because the dumper does it explicitly by default.
+
+=head2 key
+
+ $key = $kdbx->key;
+ $key = $kdbx->key($key);
+ $key = $kdbx->key($primitive);
+
+Get or set a L<File::KDBX::Key>. This is the master key (e.g. a password or a key file that can decrypt
+a database). See L<File::KDBX::Key/new> for an explanation of what the primitive can be.
+
+You generally don't need to call this directly because you can provide the key directly to the loader or
+dumper when loading or dumping a KDBX file.
+
+=head2 composite_key
+
+ $key = $kdbx->composite_key($key);
+ $key = $kdbx->composite_key($primitive);
+
+Construct a L<File::KDBX::Key::Composite> from a primitive. See L<File::KDBX::Key/new> for an explanation of
+what the primitive can be. If the primitive does not represent a composite key, it will be wrapped.
+
+You generally don't need to call this directly. The parser and writer use it to transform a master key into
+a raw encryption key.
+
+=head2 kdf
+
+ $kdf = $kdbx->kdf(%options);
+ $kdf = $kdbx->kdf(\%parameters, %options);
+
+Get a L<File::KDBX::KDF> (key derivation function).
+
+Options:
+
+=over 4
+
+=item *
+
+C<params> - KDF parameters, same as C<\%parameters> (default: value of L</kdf_parameters>)
+
+=back
+
+=head2 cipher
+
+ $cipher = $kdbx->cipher(key => $key);
+ $cipher = $kdbx->cipher(key => $key, iv => $iv, uuid => $uuid);
+
+Get a L<File::KDBX::Cipher> capable of encrypting and decrypting the body of a database file.
+
+A key is required. This should be a raw encryption key made up of a fixed number of octets (depending on the
+cipher), not a L<File::KDBX::Key> or primitive.
+
+If not passed, the UUID comes from C<< $kdbx->headers->{cipher_id} >> and the encryption IV comes from
+C<< $kdbx->headers->{encryption_iv} >>.
+
+You generally don't need to call this directly. The parser and writer use it to decrypt and encrypt KDBX
+files.
+
+=head2 random_stream
+
+ $cipher = $kdbx->random_stream;
+ $cipher = $kdbx->random_stream(id => $stream_id, key => $key);
+
+Get a L<File::KDBX::Cipher::Stream> for decrypting and encrypting protected values.
+
+If not passed, the ID and encryption key comes from C<< $kdbx->headers->{inner_random_stream_id} >> and
+C<< $kdbx->headers->{inner_random_stream_key} >> (respectively) for KDBX3 files and from
+C<< $kdbx->inner_headers->{inner_random_stream_key} >> and
+C<< $kdbx->inner_headers->{inner_random_stream_id} >> (respectively) for KDBX4 files.
+
+You generally don't need to call this directly. The parser and writer use it to scramble protected strings.
+
+=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
+
+=head1 RECIPES
+
+=head2 Create a new database
+
+ my $kdbx = File::KDBX->new;
+
+ my $group = $kdbx->add_group(name => 'Passwords);
+ my $entry = $group->add_entry(
+ title => 'WayneCorp',
+ username => 'bwayne',
+ password => 'iambatman',
+ url => 'https://example.com/login'
+ );
+ $entry->add_auto_type_window_association('WayneCorp - Mozilla Firefox', '{PASSWORD}{ENTER}');
+
+ $kdbx->dump_file('mypasswords.kdbx', 'master password CHANGEME');
+
+=head2 Read an existing database
+
+ my $kdbx = File::KDBX->load_file('mypasswords.kdbx', 'master password CHANGEME');
+ $kdbx->unlock; # cause $entry->password below to be defined
+
+ $kdbx->entries->each(sub {
+ my ($entry) = @_;
+ say 'Found password for: ', $entry->title;
+ say ' Username: ', $entry->username;
+ say ' Password: ', $entry->password;
+ });
+
+=head2 Search for entries
+
+ my @entries = $kdbx->entries(searching => 1)
+ ->grep(title => 'WayneCorp')
+ ->each; # return all matches
+
+The C<searching> option limits results to only entries within groups with searching enabled. Other options are
+also available. See L</entries>.
+
+See L</QUERY> for many more query examples.
+
+=head2 Search for entries by auto-type window association
+
+ my $window_title = 'WayneCorp - Mozilla Firefox';
+
+ my $entries = $kdbx->entries(auto_type => 1)
+ ->filter(sub {
+ my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations};
+ return [$_, $ata->{keystroke_sequence}] if $ata;
+ })
+ ->each(sub {
+ my ($entry, $keys) = @$_;
+ say 'Entry title: ', $entry->title, ', key sequence: ', $keys;
+ });
+
+Example output:
+
+ Entry title: WayneCorp, key sequence: {PASSWORD}{ENTER}
+
+=head2 Remove entries from a database
+
+ $kdbx->entries
+ ->grep(notes => {'=~' => qr/too old/i})
+ ->each(sub { $_->recycle });
+
+Recycle all entries with the string "too old" appearing in the B<Notes> string.
+
+=head2 Remove empty groups
+
+ $kdbx->groups(algorithm => 'dfs')
+ ->where(-true => 'is_empty')
+ ->each('remove');
+
+With the search/iteration C<algorithm> set to "dfs", groups will be ordered deepest first and the root group
+will be last. This allows removing groups that only contain empty groups.
+
+This can also be done with one call to L</remove_empty_groups>.
+
+=head1 SECURITY
+
+One of the biggest threats to your database security is how easily the encryption key can be brute-forced.
+Strong brute-force protection depends on:
+
+=over 4
+
+=item *
+
+Using unguessable passwords, passphrases and key files.
+
+=item *
+
+Using a brute-force resistent key derivation function.
+
+=back
+
+The first factor is up to you. This module does not enforce strong master keys. It is up to you to pick or
+generate strong keys.
+
+The KDBX format allows for the key derivation function to be tuned. The idea is that you want each single
+brute-foce attempt to be expensive (in terms of time, CPU usage or memory usage), so that making a lot of
+attempts (which would be required if you have a strong master key) gets I<really> expensive.
+
+How expensive you want to make each attempt is up to you and can depend on the application.
+
+This and other KDBX-related security issues are covered here more in depth:
+L<https://keepass.info/help/base/security.html>
+
+Here are other security risks you should be thinking about:
+
+=head2 Cryptography
+
+This distribution uses the excellent L<CryptX> and L<Crypt::Argon2> packages to handle all crypto-related
+functions. As such, a lot of the security depends on the quality of these dependencies. Fortunately these
+modules are maintained and appear to have good track records.
+
+The KDBX format has evolved over time to incorporate improved security practices and cryptographic functions.
+This package uses the following functions for authentication, hashing, encryption and random number
+generation:
+
+=over 4
+
+=item *
+
+AES-128 (legacy)
+
+=item *
+
+AES-256
+
+=item *
+
+Argon2d & Argon2id
+
+=item *
+
+CBC block mode
+
+=item *
+
+HMAC-SHA256
+
+=item *
+
+SHA256
+
+=item *
+
+SHA512
+
+=item *
+
+Salsa20 & ChaCha20
+
+=item *
+
+Twofish
+
+=back
+
+At the time of this writing, I am not aware of any successful attacks against any of these functions. These
+are among the most-analyzed and widely-adopted crypto functions available.
+
+The KDBX format allows the body cipher and key derivation function to be configured. If a flaw is discovered
+in one of these functions, you can hopefully just switch to a better function without needing to update this
+software. A later software release may phase out the use of any functions which are no longer secure.
+
+=head2 Memory Protection
+
+It is not a good idea to keep secret information unencrypted in system memory for longer than is needed. The
+address space of your program can generally be read by a user with elevated privileges on the system. If your
+system is memory-constrained or goes into a hibernation mode, the contents of your address space could be
+written to a disk where it might be persisted for long time.
+
+There might be system-level things you can do to reduce your risk, like using swap encryption and limiting
+system access to your program's address space while your program is running.
+
+B<File::KDBX> helps minimize (but not eliminate) risk by keeping secrets encrypted in memory until accessed
+and zeroing out memory that holds secrets after they're no longer needed, but it's not a silver bullet.
+
+For one thing, the encryption key is stored in the same address space. If core is dumped, the encryption key
+is available to be found out. But at least there is the chance that the encryption key and the encrypted
+secrets won't both be paged out together while memory-constrained.
+
+Another problem is that some perls (somewhat notoriously) copy around memory behind the scenes willy nilly,
+and it's difficult know when perl makes a copy of a secret in order to be able to zero it out later. It might
+be impossible. The good news is that perls with SvPV copy-on-write (enabled by default beginning with perl
+5.20) are much better in this regard. With COW, it's mostly possible to know what operations will cause perl
+to copy the memory of a scalar string, and the number of copies will be significantly reduced. There is a unit
+test named F<t/memory-protection.t> in this distribution that can be run on POSIX systems to determine how
+well B<File::KDBX> memory protection is working.
+
+Memory protection also depends on how your application handles secrets. If your app code is handling scalar
+strings with secret information, it's up to you to make sure its memory is zeroed out when no longer needed.
+L<File::KDBX::Util/erase> et al. provide some tools to help accomplish this. Or if you're not too concerned
+about the risks memory protection is meant to mitigate, then maybe don't worry about it. The security policy
+of B<File::KDBX> is to try hard to keep secrets protected while in memory so that your app might claim a high
+level of security, in case you care about that.
+
+There are some memory protection strategies that B<File::KDBX> does NOT use today but could in the future:
+
+Many systems allow programs to mark unswappable pages. Secret information should ideally be stored in such
+pages. You could potentially use L<mlockall(2)> (or equivalent for your system) in your own application to
+prevent the entire address space from being swapped.
+
+Some systems provide special syscalls for storing secrets in memory while keeping the encryption key outside
+of the program's address space, like C<CryptProtectMemory> for Windows. This could be a good option, though
+unfortunately not portable.
+
+=head1 QUERY
+
+To find things in a KDBX database, you should use a filtered iterator. If you have an iterator, such as
+returned by L</entries>, L</groups> or even L</objects> you can filter it using L<File::KDBX::Iterator/where>.
+
+ my $filtered_entries = $kdbx->entries->where($query);
+
+A C<$query> is just a subroutine that you can either write yourself or have generated for you from either
+a L</"Simple Expression"> or L</"Declarative Syntax">. It's easier to have your query generated, so I'll cover
+that first.
+
+=head2 Simple Expression
+
+A simple expression is mostly compatible with the KeePass 2 implementation
+L<described here|https://keepass.info/help/base/search.html#mode_se>.
+
+An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
+quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
+one of the given fields.
+
+So a simple expression is something like what you might type into a search engine. You can generate a simple
+expression query using L<File::KDBX::Util/simple_expression_query> or by passing the simple expression as
+a B<scalar reference> to C<where>.
+
+To search for all entries in a database with the word "canyon" appearing anywhere in the title:
+
+ my $entries = $kdbx->entries->where(\'canyon', qw[title]);
+
+Notice the first argument is a B<scalarref>. This disambiguates a simple expression from other types of
+queries covered below.
+
+As mentioned, a simple expression can have multiple terms. This simple expression query matches any entry that
+has the words "red" B<and> "canyon" anywhere in the title:
+
+ my $entries = $kdbx->entries->where(\'red canyon', qw[title]);
+
+Each term in the simple expression must be found for an entry to match.
+
+To search for entries with "red" in the title but B<not> "canyon", just prepend "canyon" with a minus sign:
+
+ my $entries = $kdbx->entries->where(\'red -canyon', qw[title]);
+
+To search over multiple fields simultaneously, just list them all. To search for entries with "grocery" (but
+not "Foodland") in the title or notes:
+
+ my $entries = $kdbx->entries->where(\'grocery -Foodland', qw[title notes]);
+
+The default operator is a case-insensitive regexp match, which is fine for searching text loosely. You can use
+just about any binary comparison operator that perl supports. To specify an operator, list it after the simple
+expression. For example, to search for any entry that has been used at least five times:
+
+ my $entries = $kdbx->entries->where(\5, '>=', qw[usage_count]);
+
+It helps to read it right-to-left, like "usage_count is greater than or equal to 5".
+
+If you find the disambiguating structures to be distracting or confusing, you can also the
+L<File::KDBX::Util/simple_expression_query> function as a more intuitive alternative. The following example is
+equivalent to the previous:
+
+ my $entries = $kdbx->entries->where(simple_expression_query(5, '>=', qw[usage_count]));
+
+=head2 Declarative Syntax
+
+Structuring a declarative query is similar to L<SQL::Abstract/"WHERE CLAUSES">, but you don't have to be
+familiar with that module. Just learn by examples here.
+
+To search for all entries in a database titled "My Bank":
+
+ my $entries = $kdbx->entries->where({ title => 'My Bank' });
+
+The query here is C<< { title => 'My Bank' } >>. A hashref can contain key-value pairs where the key is an
+attribute of the thing being searched for (in this case an entry) and the value is what you want the thing's
+attribute to be to consider it a match. In this case, the attribute we're using as our match criteria is
+L<File::KDBX::Entry/title>, a text field. If an entry has its title attribute equal to "My Bank", it's
+a match.
+
+A hashref can contain multiple attributes. The search candidate will be a match if I<all> of the specified
+attributes are equal to their respective values. For example, to search for all entries with a particular URL
+B<AND> username:
+
+ my $entries = $kdbx->entries->where({
+ url => 'https://example.com',
+ username => 'neo',
+ });
+
+To search for entries matching I<any> criteria, just change the hashref to an arrayref. To search for entries
+with a particular URL B<OR> username:
+
+ my $entries = $kdbx->entries->where([ # <-- Notice the square bracket
+ url => 'https://example.com',
+ username => 'neo',
+ ]);
+
+You can use different operators to test different types of attributes. The L<File::KDBX::Entry/icon_id>
+attribute is a number, so we should use a number comparison operator. To find entries using the smartphone
+icon:
+
+ my $entries = $kdbx->entries->where({
+ icon_id => { '==', ICON_SMARTPHONE },
+ });
+
+Note: L<File::KDBX::Constants/ICON_SMARTPHONE> is just a constant from L<File::KDBX::Constants>. It isn't
+special to this example or to queries generally. We could have just used a literal number.
+
+The important thing to notice here is how we wrapped the condition in another arrayref with a single key-value
+pair where the key is the name of an operator and the value is the thing to match against. The supported
+operators are:
+
+=over 4
+
+=item *
+
+C<eq> - String equal
+
+=item *
+
+C<ne> - String not equal
+
+=item *
+
+C<lt> - String less than
+
+=item *
+
+C<gt> - String greater than
+
+=item *
+
+C<le> - String less than or equal
+
+=item *
+
+C<ge> - String greater than or equal
+
+=item *
+
+C<==> - Number equal
+
+=item *
+
+C<!=> - Number not equal
+
+=item *
+
+C<< < >> - Number less than
+
+=item *
+
+C<< > >>> - Number greater than
+
+=item *
+
+C<< <= >> - Number less than or equal
+
+=item *
+
+C<< >= >> - Number less than or equal
+
+=item *
+
+C<=~> - String match regular expression
+
+=item *
+
+C<!~> - String does not match regular expression
+
+=item *
+
+C<!> - Boolean false
+
+=item *
+
+C<!!> - Boolean true
+
+=back
+
+Other special operators:
+
+=over 4
+
+=item *
+
+C<-true> - Boolean true
+
+=item *
+
+C<-false> - Boolean false
+
+=item *
+
+C<-not> - Boolean false (alias for C<-false>)
+
+=item *
+
+C<-defined> - Is defined
+
+=item *
+
+C<-undef> - Is not defined
+
+=item *
+
+C<-empty> - Is empty
+
+=item *
+
+C<-nonempty> - Is not empty
+
+=item *
+
+C<-or> - Logical or
+
+=item *
+
+C<-and> - Logical and
+
+=back
+
+Let's see another example using an explicit operator. To find all groups except one in particular (identified
+by its L<File::KDBX::Group/uuid>), we can use the C<ne> (string not equal) operator:
+
+ my $groups = $kdbx->groups->where(
+ uuid => {
+ 'ne' => uuid('596f7520-6172-6520-7370-656369616c2e'),
+ },
+ );
+
+Note: L<File::KDBX::Util/uuid> is a little utility function to convert a UUID in its pretty form into bytes.
+This utility function isn't special to this example or to queries generally. It could have been written with
+a literal such as C<"\x59\x6f\x75\x20\x61...">, but that's harder to read.
+
+Notice we searched for groups this time. Finding groups works exactly the same as it does for entries.
+
+Notice also that we didn't wrap the query in hashref curly-braces or arrayref square-braces. Those are
+optional. By default it will only match ALL attributes (as if there were curly-braces).
+
+Testing the truthiness of an attribute is a little bit different because it isn't a binary operation. To find
+all entries with the password quality check disabled:
+
+ my $entries = $kdbx->entries->where('!' => 'quality_check');
+
+This time the string after the operator is the attribute name rather than a value to compare the attribute
+against. To test that a boolean value is true, use the C<!!> operator (or C<-true> if C<!!> seems a little too
+weird for your taste):
+
+ my $entries = $kdbx->entries->where('!!' => 'quality_check');
+ my $entries = $kdbx->entries->where(-true => 'quality_check'); # same thing
+
+Yes, there is also a C<-false> and a C<-not> if you prefer one of those over C<!>. C<-false> and C<-not>
+(along with C<-true>) are also special in that you can use them to invert the logic of a subquery. These are
+logically equivalent:
+
+ my $entries = $kdbx->entries->where(-not => { title => 'My Bank' });
+ my $entries = $kdbx->entries->where(title => { 'ne' => 'My Bank' });
+
+These special operators become more useful when combined with two more special operators: C<-and> and C<-or>.
+With these, it is possible to construct more interesting queries with groups of logic. For example:
+
+ my $entries = $kdbx->entries->where({
+ title => { '=~', qr/bank/ },
+ -not => {
+ -or => {
+ notes => { '=~', qr/business/ },
+ icon_id => { '==', ICON_TRASHCAN_FULL },
+ },
+ },
+ });
+
+In English, find entries where the word "bank" appears anywhere in the title but also do not have either the
+word "business" in the notes or are using the full trashcan icon.
+
+=head2 Subroutine Query
+
+Lastly, as mentioned at the top, you can ignore all this and write your own subroutine. Your subroutine will
+be called once for each object being searched over. The subroutine should match the candidate against whatever
+criteria you want and return true if it matches or false to skip. To do this, just pass your subroutine
+coderef to C<where>.
+
+To review the different types of queries, these are all equivalent to find all entries in the database titled
+"My Bank":
+
+ my $entries = $kdbx->entries->where(\'"My Bank"', 'eq', qw[title]); # simple expression
+ my $entries = $kdbx->entries->where(title => 'My Bank'); # declarative syntax
+ my $entries = $kdbx->entries->where(sub { $_->title eq 'My Bank' }); # subroutine query
+
+This is a trivial example, but of course your subroutine can be arbitrarily complex.
+
+All of these query mechanisms described in this section are just tools, each with its own set of limitations.
+If the tools are getting in your way, you can of course iterate over the contents of a database and implement
+your own query logic, like this:
+
+ my $entries = $kdbx->entries;
+ while (my $entry = $entries->next) {
+ if (wanted($entry)) {
+ do_something($entry);
+ }
+ else {
+ ...
+ }
+ }
+
+=head2 Iteration
+
+Iterators are the built-in way to navigate or walk the database tree. You get an iterator from L</entries>,
+L</groups> and L</objects>. You can specify the search algorithm to iterate over objects in different orders
+using the C<algorith> option, which can be one of these L<constants|File::KDBX::Constants/":iteration">:
+
+=over 4
+
+=item *
+
+C<ITERATION_IDS> - Iterative deepening search (default)
+
+=item *
+
+C<ITERATION_DFS> - Depth-first search
+
+=item *
+
+C<ITERATION_BFS> - Breadth-first search
+
+=back
+
+When iterating over objects generically, groups always precede their direct entries (if any). When the
+C<history> option is used, current entries always precede historical entries.
+
+If you have a database tree like this:
+
+ Database
+ - Root
+ - Group1
+ - EntryA
+ - Group2
+ - EntryB
+ - Group3
+ - EntryC
+
+IDS order of groups is: Root, Group1, Group2, Group3
+IDS order of entries is: EntryA, EntryB, EntryC
+IDS order of objects is: Root, Group1, EntryA, Group2, EntryB, Group3, EntryC
+
+DFS order of groups is: Group2, Group1, Group3, Root
+DFS order of entries is: EntryB, EntryA, EntryC
+DFS order of objects is: Group2, EntryB, Group1, EntryA, Group3, EntryC, Root
+
+BFS order of groups is: Root, Group1, Group3, Group2
+BFS order of entries is: EntryA, EntryC, EntryB
+BFS order of objects is: Root, Group1, EntryA, Group3, EntryC, Group2, EntryB
+
+=head1 SYNCHRONIZING
+
+B<TODO> - This is a planned feature, not yet implemented.
+
+=head1 ERRORS
+
+Errors in this package are constructed as L<File::KDBX::Error> objects and propagated using perl's built-in
+mechanisms. Fatal errors are propagated using L<functions/die> and non-fatal errors (a.k.a. warnings) are
+propagated using L<functions/warn> while adhering to perl's L<warnings> system. If you're already familiar
+with these mechanisms, you can skip this section.
+
+You can catch fatal errors using L<functions/eval> (or something like L<Try::Tiny>) and non-fatal errors using
+C<$SIG{__WARN__}> (see L<variables/%SIG>). Examples:
+
+ use File::KDBX::Error qw(error);
+
+ my $key = ''; # uh oh
+ eval {
+ $kdbx->load_file('whatever.kdbx', $key);
+ };
+ if (my $error = error($@)) {
+ handle_missing_key($error) if $error->type eq 'key.missing';
+ $error->throw;
+ }
+
+or using C<Try::Tiny>:
+
+ try {
+ $kdbx->load_file('whatever.kdbx', $key);
+ }
+ catch {
+ handle_error($_);
+ };
+
+Catching non-fatal errors:
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, $_[0] };
+
+ $kdbx->load_file('whatever.kdbx', $key);
+
+ handle_warnings(@warnings) if @warnings;
+
+By default perl prints warnings to C<STDERR> if you don't catch them. If you don't want to catch them and also
+don't want them printed to C<STDERR>, you can suppress them lexically (perl v5.28 or higher required):
+
+ {
+ no warnings 'File::KDBX';
+ ...
+ }
+
+or locally:
+
+ {
+ local $File::KDBX::WARNINGS = 0;
+ ...
+ }
+
+or globally in your program:
+
+ $File::KDBX::WARNINGS = 0;
+
+You cannot suppress fatal errors, and if you don't catch them your program will exit.
+
+=head1 ENVIRONMENT
+
+This software will alter its behavior depending on the value of certain environment variables:
+
+=over 4
+
+=item *
+
+C<PERL_FILE_KDBX_XS> - Do not use L<File::KDBX::XS> if false (default: true)
+
+=item *
+
+C<PERL_ONLY> - Do not use L<File::KDBX::XS> if true (default: false)
+
+=item *
+
+C<NO_FORK> - Do not fork if true (default: false)
+
+=back
+
+=head1 CAVEATS
+
+Some features (e.g. parsing) require 64-bit perl. It should be possible and actually pretty easy to make it
+work using L<Math::BigInt>, but I need to build a 32-bit perl in order to test it and frankly I'm still
+figuring out how. I'm sure it's simple so I'll mark this one "TODO", but for now an exception will be thrown
+when trying to use such features with undersized IVs.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<KeePass Password Safe|https://keepass.info/> - The original KeePass
+
+=item *
+
+L<KeePassXC|https://keepassxc.org/> - Cross-Platform Password Manager written in C++
+
+=item *
+
+L<File::KeePass> has overlapping functionality. It's good but has a backlog of some pretty critical bugs and lacks support for newer KDBX features.
+
+=back
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Cipher;
+# ABSTRACT: A block cipher mode or cipher stream
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:cipher :random_stream);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class erase format_uuid);
+use Module::Load;
+use Scalar::Util qw(looks_like_number);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+my %CIPHERS;
+
+
+has 'uuid', is => 'ro';
+has 'stream_id', is => 'ro';
+has 'key', is => 'ro';
+has 'iv', is => 'ro';
+sub iv_size { 0 }
+sub key_size { -1 }
+sub block_size { 0 }
+sub algorithm { $_[0]->{algorithm} or throw 'Block cipher algorithm is not set' }
+
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ return $class->new_from_uuid(delete $args{uuid}, %args) if defined $args{uuid};
+ return $class->new_from_stream_id(delete $args{stream_id}, %args) if defined $args{stream_id};
+
+ throw 'Must pass uuid or stream_id';
+}
+
+sub new_from_uuid {
+ my $class = shift;
+ my $uuid = shift;
+ my %args = @_;
+
+ $args{key} or throw 'Missing encryption key';
+ $args{iv} or throw 'Missing encryption IV';
+
+ my $formatted_uuid = format_uuid($uuid);
+
+ my $cipher = $CIPHERS{$uuid} or throw "Unsupported cipher ($formatted_uuid)", uuid => $uuid;
+ ($class, my %registration_args) = @$cipher;
+
+ my @args = (%args, %registration_args, uuid => $uuid);
+ load $class;
+ my $self = bless {@args}, $class;
+ return $self->init(@args);
+}
+
+sub new_from_stream_id {
+ my $class = shift;
+ my $id = shift;
+ my %args = @_;
+
+ $args{key} or throw 'Missing encryption key';
+
+ my $cipher = $CIPHERS{$id} or throw "Unsupported stream cipher ($id)", id => $id;
+ ($class, my %registration_args) = @$cipher;
+
+ my @args = (%args, %registration_args, stream_id => $id);
+ load $class;
+ my $self = bless {@args}, $class;
+ return $self->init(@args);
+}
+
+
+sub init { $_[0] }
+
+sub DESTROY { !in_global_destruction and erase \$_[0]->{key} }
+
+
+sub encrypt { die 'Not implemented' }
+
+
+sub decrypt { die 'Not implemented' }
+
+
+sub finish { '' }
+
+
+sub encrypt_finish {
+ my $self = shift;
+ my $out = $self->encrypt(@_);
+ $out .= $self->finish;
+ return $out;
+}
+
+
+sub decrypt_finish {
+ my $self = shift;
+ my $out = $self->decrypt(@_);
+ $out .= $self->finish;
+ return $out;
+}
+
+
+sub register {
+ my $class = shift;
+ my $id = shift;
+ my $package = shift;
+ my @args = @_;
+
+ my $formatted_id = looks_like_number($id) ? $id : format_uuid($id);
+ $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/;
+
+ my %blacklist = map { (looks_like_number($_) ? $_ : File::KDBX::Util::uuid($_)) => 1 }
+ split(/,/, $ENV{FILE_KDBX_CIPHER_BLACKLIST} // '');
+ if ($blacklist{$id} || $blacklist{$package}) {
+ alert "Ignoring blacklisted cipher ($formatted_id)", id => $id, package => $package;
+ return;
+ }
+
+ if (defined $CIPHERS{$id}) {
+ alert "Overriding already-registered cipher ($formatted_id) with package $package",
+ id => $id,
+ package => $package;
+ }
+
+ $CIPHERS{$id} = [$package, @args];
+}
+
+
+sub unregister {
+ delete $CIPHERS{$_} for @_;
+}
+
+BEGIN {
+ __PACKAGE__->register(CIPHER_UUID_AES128, 'CBC', algorithm => 'AES', key_size => 16);
+ __PACKAGE__->register(CIPHER_UUID_AES256, 'CBC', algorithm => 'AES', key_size => 32);
+ __PACKAGE__->register(CIPHER_UUID_SERPENT, 'CBC', algorithm => 'Serpent', key_size => 32);
+ __PACKAGE__->register(CIPHER_UUID_TWOFISH, 'CBC', algorithm => 'Twofish', key_size => 32);
+ __PACKAGE__->register(CIPHER_UUID_CHACHA20, 'Stream', algorithm => 'ChaCha');
+ __PACKAGE__->register(CIPHER_UUID_SALSA20, 'Stream', algorithm => 'Salsa20');
+ __PACKAGE__->register(STREAM_ID_CHACHA20, 'Stream', algorithm => 'ChaCha');
+ __PACKAGE__->register(STREAM_ID_SALSA20, 'Stream', algorithm => 'Salsa20');
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Cipher - A block cipher mode or cipher stream
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Cipher;
+
+ my $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv);
+
+ my $ciphertext = $cipher->encrypt('plaintext');
+ $ciphertext .= $cipher->encrypt('more plaintext');
+ $ciphertext .= $cipher->finish;
+
+ my $plaintext = $cipher->decrypt('ciphertext');
+ $plaintext .= $cipher->decrypt('more ciphertext');
+ $plaintext .= $cipher->finish;
+
+=head1 DESCRIPTION
+
+A cipher is used to encrypt and decrypt KDBX files. The L<File::KDBX> distribution comes with several
+pre-registered ciphers ready to go:
+
+=over 4
+
+=item *
+
+C<61AB05A1-9464-41C3-8D74-3A563DF8DD35> - AES128 (legacy)
+
+=item *
+
+C<31C1F2E6-BF71-4350-BE58-05216AFC5AFF> - AES256
+
+=item *
+
+C<D6038A2B-8B6F-4CB5-A524-339A31DBB59A> - ChaCha20
+
+=item *
+
+C<716E1C8A-EE17-4BDC-93AE-A977B882833A> - Salsa20
+
+=item *
+
+C<098563FF-DDF7-4F98-8619-8079F6DB897A> - Serpent
+
+=item *
+
+C<AD68F29F-576F-4BB9-A36A-D47AF965346C> - Twofish
+
+=back
+
+B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and
+algorithm that they support. From the list above, AES256 and ChaCha20 are well-supported. You should avoid
+AES128 for new databases.
+
+You can also L</register> your own cipher. Here is a skeleton:
+
+ package File::KDBX::Cipher::MyCipher;
+
+ use parent 'File::KDBX::Cipher';
+
+ File::KDBX::Cipher->register(
+ # $uuid, $package, %args
+ "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__,
+ );
+
+ sub init { ... } # optional
+
+ sub encrypt { ... }
+ sub decrypt { ... }
+ sub finish { ... }
+
+ sub key_size { ... }
+ sub iv_size { ... }
+ sub block_size { ... }
+
+=head1 ATTRIBUTES
+
+=head2 uuid
+
+ $uuid = $cipher->uuid;
+
+Get the UUID if the cipher was constructed with one.
+
+=head2 stream_id
+
+ $stream_id = $cipher->stream_id;
+
+Get the stream ID if the cipher was constructed with one.
+
+=head2 key
+
+ $key = $cipher->key;
+
+Get the raw encryption key.
+
+=head2 iv
+
+ $iv = $cipher->iv;
+
+Get the initialization vector.
+
+=head2 iv_size
+
+ $size = $cipher->iv_size;
+
+Get the expected size of the initialization vector, in bytes.
+
+=head2 key_size
+
+ $size = $cipher->key_size;
+
+Get the size the mode or stream expects the key to be, in bytes.
+
+=head2 block_size
+
+ $size = $cipher->block_size;
+
+Get the block size, in bytes.
+
+=head2 algorithm
+
+Get the symmetric cipher algorithm.
+
+=head1 METHODS
+
+=head2 new
+
+=head2 new_from_uuid
+
+=head2 new_from_stream_id
+
+ $cipher = File::KDBX::Cipher->new(uuid => $uuid, key => $key, iv => $iv);
+ # OR
+ $cipher = File::KDBX::Cipher->new_from_uuid($uuid, key => $key, iv => $iv);
+
+ $cipher = File::KDBX::Cipher->new(stream_id => $id, key => $key);
+ # OR
+ $cipher = File::KDBX::Cipher->new_from_stream_id($id, key => $key);
+
+Construct a new L<File::KDBX::Cipher>.
+
+This is a factory method which returns a subclass.
+
+=head2 init
+
+ $self->init;
+
+Initialize the cipher. Called by </new>.
+
+=head2 encrypt
+
+ $ciphertext = $cipher->encrypt($plaintext, ...);
+
+Encrypt some data.
+
+=head2 decrypt
+
+ $plaintext = $cipher->decrypt($ciphertext, ...);
+
+Decrypt some data.
+
+=head2 finish
+
+ $ciphertext .= $cipher->finish; # if encrypting
+ $plaintext .= $cipher->finish; # if decrypting
+
+Finish the stream.
+
+=head2 encrypt_finish
+
+ $ciphertext = $cipher->encrypt_finish($plaintext, ...);
+
+Encrypt and finish a stream in one call.
+
+=head2 decrypt_finish
+
+ $plaintext = $cipher->decrypt_finish($ciphertext, ...);
+
+Decrypt and finish a stream in one call.
+
+=head2 register
+
+ File::KDBX::Cipher->register($uuid => $package, %args);
+
+Register a cipher. Registered ciphers can be used to encrypt and decrypt KDBX databases. A cipher's UUID
+B<must> be unique and B<musn't change>. A cipher UUID is written into each KDBX file and the associated cipher
+must be registered with the same UUID in order to decrypt the KDBX file.
+
+C<$package> should be a Perl package relative to C<File::KDBX::Cipher::> or prefixed with a C<+> if it is
+a fully-qualified package. C<%args> are passed as-is to the cipher's L</init> method.
+
+=head2 unregister
+
+ File::KDBX::Cipher->unregister($uuid);
+
+Unregister a cipher. Unregistered ciphers can no longer be used to encrypt and decrypt KDBX databases, until
+reregistered (see L</register>).
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Cipher::CBC;
+# ABSTRACT: A CBC block cipher mode encrypter/decrypter
+
+use warnings;
+use strict;
+
+use Crypt::Mode::CBC;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class);
+use namespace::clean;
+
+extends 'File::KDBX::Cipher';
+
+our $VERSION = '0.800'; # VERSION
+
+has key_size => 32;
+sub iv_size { 16 }
+sub block_size { 16 }
+
+sub encrypt {
+ my $self = shift;
+
+ my $mode = $self->{mode} ||= do {
+ my $m = Crypt::Mode::CBC->new($self->algorithm);
+ $m->start_encrypt($self->key, $self->iv);
+ $m;
+ };
+
+ return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_);
+}
+
+sub decrypt {
+ my $self = shift;
+
+ my $mode = $self->{mode} ||= do {
+ my $m = Crypt::Mode::CBC->new($self->algorithm);
+ $m->start_decrypt($self->key, $self->iv);
+ $m;
+ };
+
+ return join('', map { $mode->add(ref $_ ? $$_ : $_) } grep { defined } @_);
+}
+
+sub finish {
+ my $self = shift;
+ return '' if !$self->{mode};
+ my $out = $self->{mode}->finish;
+ delete $self->{mode};
+ return $out;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Cipher::CBC - A CBC block cipher mode encrypter/decrypter
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Cipher::CBC;
+
+ my $cipher = File::KDBX::Cipher::CBC->new(algorithm => $algo, key => $key, iv => $iv);
+
+=head1 DESCRIPTION
+
+A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using the CBC block cipher mode.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Cipher::Stream;
+# ABSTRACT: A cipher stream encrypter/decrypter
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Constants qw(:cipher :random_stream);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class);
+use Scalar::Util qw(blessed);
+use Module::Load;
+use namespace::clean;
+
+extends 'File::KDBX::Cipher';
+
+our $VERSION = '0.800'; # VERSION
+
+
+has 'counter', is => 'ro', default => 0;
+has 'offset', is => 'ro';
+sub key_size { { Salsa20 => 32, ChaCha => 32 }->{$_[0]->{algorithm} || ''} // 0 }
+sub iv_size { { Salsa20 => 8, ChaCha => 12 }->{$_[0]->{algorithm} || ''} // -1 }
+sub block_size { 1 }
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ if (my $uuid = $args{uuid}) {
+ if ($uuid eq CIPHER_UUID_CHACHA20 && length($args{iv}) == 16) {
+ # extract the counter
+ my $buf = substr($self->{iv}, 0, 4, '');
+ $self->{counter} = unpack('L<', $buf);
+ }
+ elsif ($uuid eq CIPHER_UUID_SALSA20) {
+ # only need eight bytes...
+ $self->{iv} = substr($args{iv}, 8);
+ }
+ }
+ elsif (my $id = $args{stream_id}) {
+ my $key_ref = ref $args{key} ? $args{key} : \$args{key};
+ if ($id == STREAM_ID_CHACHA20) {
+ ($self->{key}, $self->{iv}) = unpack('a32 a12', digest_data('SHA512', $$key_ref));
+ }
+ elsif ($id == STREAM_ID_SALSA20) {
+ ($self->{key}, $self->{iv}) = (digest_data('SHA256', $$key_ref), STREAM_SALSA20_IV);
+ }
+ }
+
+ return $self;
+}
+
+
+sub crypt {
+ my $self = shift;
+ my $stream = $self->_stream;
+ return join('', map { $stream->crypt(ref $_ ? $$_ : $_) } grep { defined } @_);
+}
+
+
+sub keystream {
+ my $self = shift;
+ return $self->_stream->keystream(@_);
+}
+
+
+sub dup {
+ my $self = shift;
+ my $class = blessed($self);
+
+ my $dup = bless {%$self, @_}, $class;
+ delete $dup->{stream};
+ return $dup;
+}
+
+sub _stream {
+ my $self = shift;
+
+ $self->{stream} //= do {
+ my $s = eval {
+ my $pkg = 'Crypt::Stream::'.$self->algorithm;
+ my $counter = $self->counter;
+ my $pos = 0;
+ if (defined (my $offset = $self->offset)) {
+ $counter = int($offset / 64);
+ $pos = $offset % 64;
+ }
+ my $s = $pkg->new($self->key, $self->iv, $counter);
+ # seek to correct position within block
+ $s->keystream($pos) if $pos;
+ $s;
+ };
+ if (my $err = $@) {
+ throw 'Failed to initialize stream cipher library',
+ error => $err,
+ algorithm => $self->{algorithm},
+ key_length => length($self->key),
+ iv_length => length($self->iv),
+ iv => unpack('H*', $self->iv),
+ key => unpack('H*', $self->key);
+ }
+ $s;
+ };
+}
+
+sub encrypt { goto &crypt }
+sub decrypt { goto &crypt }
+
+sub finish { delete $_[0]->{stream}; '' }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Cipher::Stream - A cipher stream encrypter/decrypter
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Cipher::Stream;
+
+ my $cipher = File::KDBX::Cipher::Stream->new(algorithm => $algorithm, key => $key, iv => $iv);
+
+=head1 DESCRIPTION
+
+A subclass of L<File::KDBX::Cipher> for encrypting and decrypting data using a stream cipher.
+
+=head1 ATTRIBUTES
+
+=head2 counter
+
+ $counter = $cipher->counter;
+
+Get the initial counter / block count into the keystream.
+
+=head2 offset
+
+ $offset = $cipher->offset;
+
+Get the initial byte offset into the keystream. This has precedence over L</counter> if both are set.
+
+=head1 METHODS
+
+=head2 crypt
+
+ $ciphertext = $cipher->crypt($plaintext);
+ $plaintext = $cipher->crypt($ciphertext);
+
+Encrypt or decrypt some data. These ciphers are symmetric, so encryption and decryption are the same
+operation. This method is an alias for both L<File::KDBX::Cipher/encrypt> and L<File::KDBX::Cipher/decrypt>.
+
+=head2 keystream
+
+ $stream = $cipher->keystream;
+
+Access the keystream.
+
+=head2 dup
+
+ $cipher_copy = $cipher->dup(%attributes);
+
+Get a copy of an existing cipher with the counter reset, optionally applying new attributes.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Constants;
+# ABSTRACT: All the KDBX-related constants you could ever want
+
+# HOW TO add new constants:
+# 1. Add it to the %CONSTANTS structure below.
+# 2. List it in the pod at the bottom of this file in the section corresponding to its tag.
+# 3. There is no step three.
+
+use warnings;
+use strict;
+
+use Exporter qw(import);
+use Scalar::Util qw(dualvar);
+use namespace::clean -except => 'import';
+
+our $VERSION = '0.800'; # VERSION
+
+BEGIN {
+ my %CONSTANTS = (
+ magic => {
+ __prefix => 'KDBX',
+ SIG1 => 0x9aa2d903,
+ SIG1_FIRST_BYTE => 0x03,
+ SIG2_1 => 0xb54bfb65,
+ SIG2_2 => 0xb54bfb67,
+ },
+ version => {
+ __prefix => 'KDBX_VERSION',
+ _2_0 => 0x00020000,
+ _3_0 => 0x00030000,
+ _3_1 => 0x00030001,
+ _4_0 => 0x00040000,
+ _4_1 => 0x00040001,
+ OLDEST => 0x00020000,
+ LATEST => 0x00040001,
+ MAJOR_MASK => 0xffff0000,
+ MINOR_MASK => 0x0000ffff,
+ },
+ header => {
+ __prefix => 'HEADER',
+ END => dualvar( 0, 'end'),
+ COMMENT => dualvar( 1, 'comment'),
+ CIPHER_ID => dualvar( 2, 'cipher_id'),
+ COMPRESSION_FLAGS => dualvar( 3, 'compression_flags'),
+ MASTER_SEED => dualvar( 4, 'master_seed'),
+ TRANSFORM_SEED => dualvar( 5, 'transform_seed'),
+ TRANSFORM_ROUNDS => dualvar( 6, 'transform_rounds'),
+ ENCRYPTION_IV => dualvar( 7, 'encryption_iv'),
+ INNER_RANDOM_STREAM_KEY => dualvar( 8, 'inner_random_stream_key'),
+ STREAM_START_BYTES => dualvar( 9, 'stream_start_bytes'),
+ INNER_RANDOM_STREAM_ID => dualvar( 10, 'inner_random_stream_id'),
+ KDF_PARAMETERS => dualvar( 11, 'kdf_parameters'),
+ PUBLIC_CUSTOM_DATA => dualvar( 12, 'public_custom_data'),
+ },
+ compression => {
+ __prefix => 'COMPRESSION',
+ NONE => dualvar( 0, 'none'),
+ GZIP => dualvar( 1, 'gzip'),
+ },
+ cipher => {
+ __prefix => 'CIPHER',
+ UUID_AES128 => "\x61\xab\x05\xa1\x94\x64\x41\xc3\x8d\x74\x3a\x56\x3d\xf8\xdd\x35",
+ UUID_AES256 => "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff",
+ UUID_CHACHA20 => "\xd6\x03\x8a\x2b\x8b\x6f\x4c\xb5\xa5\x24\x33\x9a\x31\xdb\xb5\x9a",
+ UUID_SALSA20 => "\x71\x6e\x1c\x8a\xee\x17\x4b\xdc\x93\xae\xa9\x77\xb8\x82\x83\x3a",
+ UUID_SERPENT => "\x09\x85\x63\xff\xdd\xf7\x4f\x98\x86\x19\x80\x79\xf6\xdb\x89\x7a",
+ UUID_TWOFISH => "\xad\x68\xf2\x9f\x57\x6f\x4b\xb9\xa3\x6a\xd4\x7a\xf9\x65\x34\x6c",
+ },
+ kdf => {
+ __prefix => 'KDF',
+ UUID_AES => "\xc9\xd9\xf3\x9a\x62\x8a\x44\x60\xbf\x74\x0d\x08\xc1\x8a\x4f\xea",
+ UUID_AES_CHALLENGE_RESPONSE => "\x7c\x02\xbb\x82\x79\xa7\x4a\xc0\x92\x7d\x11\x4a\x00\x64\x82\x38",
+ UUID_ARGON2D => "\xef\x63\x6d\xdf\x8c\x29\x44\x4b\x91\xf7\xa9\xa4\x03\xe3\x0a\x0c",
+ UUID_ARGON2ID => "\x9e\x29\x8b\x19\x56\xdb\x47\x73\xb2\x3d\xfc\x3e\xc6\xf0\xa1\xe6",
+ PARAM_UUID => '$UUID',
+ PARAM_AES_ROUNDS => 'R',
+ PARAM_AES_SEED => 'S',
+ PARAM_ARGON2_SALT => 'S',
+ PARAM_ARGON2_PARALLELISM => 'P',
+ PARAM_ARGON2_MEMORY => 'M',
+ PARAM_ARGON2_ITERATIONS => 'I',
+ PARAM_ARGON2_VERSION => 'V',
+ PARAM_ARGON2_SECRET => 'K',
+ PARAM_ARGON2_ASSOCDATA => 'A',
+ DEFAULT_AES_ROUNDS => 100_000,
+ DEFAULT_ARGON2_ITERATIONS => 10,
+ DEFAULT_ARGON2_MEMORY => 1 << 16,
+ DEFAULT_ARGON2_PARALLELISM => 2,
+ DEFAULT_ARGON2_VERSION => 0x13,
+ },
+ random_stream => {
+ __prefix => 'STREAM',
+ ID_RC4_VARIANT => 1,
+ ID_SALSA20 => 2,
+ ID_CHACHA20 => 3,
+ SALSA20_IV => "\xe8\x30\x09\x4b\x97\x20\x5d\x2a",
+
+ },
+ variant_map => {
+ __prefix => 'VMAP',
+ VERSION => 0x0100,
+ VERSION_MAJOR_MASK => 0xff00,
+ TYPE_END => 0x00,
+ TYPE_UINT32 => 0x04,
+ TYPE_UINT64 => 0x05,
+ TYPE_BOOL => 0x08,
+ TYPE_INT32 => 0x0C,
+ TYPE_INT64 => 0x0D,
+ TYPE_STRING => 0x18,
+ TYPE_BYTEARRAY => 0x42,
+ },
+ inner_header => {
+ __prefix => 'INNER_HEADER',
+ END => dualvar( 0, 'end'),
+ INNER_RANDOM_STREAM_ID => dualvar( 1, 'inner_random_stream_id'),
+ INNER_RANDOM_STREAM_KEY => dualvar( 2, 'inner_random_stream_key'),
+ BINARY => dualvar( 3, 'binary'),
+ BINARY_FLAG_PROTECT => 1,
+ },
+ key_file => {
+ __prefix => 'KEY_FILE',
+ TYPE_BINARY => dualvar( 1, 'binary'),
+ TYPE_HASHED => dualvar( 3, 'hashed'),
+ TYPE_HEX => dualvar( 2, 'hex'),
+ TYPE_XML => dualvar( 4, 'xml'),
+ },
+ history => {
+ __prefix => 'HISTORY',
+ DEFAULT_MAX_AGE => 365,
+ DEFAULT_MAX_ITEMS => 10,
+ DEFAULT_MAX_SIZE => 6_291_456, # 6 MiB
+ },
+ iteration => {
+ ITERATION_BFS => dualvar(1, 'bfs'),
+ ITERATION_DFS => dualvar(2, 'dfs'),
+ ITERATION_IDS => dualvar(3, 'ids'),
+ },
+ icon => {
+ __prefix => 'ICON',
+ PASSWORD => dualvar( 0, 'Password'),
+ PACKAGE_NETWORK => dualvar( 1, 'Package_Network'),
+ MESSAGEBOX_WARNING => dualvar( 2, 'MessageBox_Warning'),
+ SERVER => dualvar( 3, 'Server'),
+ KLIPPER => dualvar( 4, 'Klipper'),
+ EDU_LANGUAGES => dualvar( 5, 'Edu_Languages'),
+ KCMDF => dualvar( 6, 'KCMDF'),
+ KATE => dualvar( 7, 'Kate'),
+ SOCKET => dualvar( 8, 'Socket'),
+ IDENTITY => dualvar( 9, 'Identity'),
+ KONTACT => dualvar( 10, 'Kontact'),
+ CAMERA => dualvar( 11, 'Camera'),
+ IRKICKFLASH => dualvar( 12, 'IRKickFlash'),
+ KGPG_KEY3 => dualvar( 13, 'KGPG_Key3'),
+ LAPTOP_POWER => dualvar( 14, 'Laptop_Power'),
+ SCANNER => dualvar( 15, 'Scanner'),
+ MOZILLA_FIREBIRD => dualvar( 16, 'Mozilla_Firebird'),
+ CDROM_UNMOUNT => dualvar( 17, 'CDROM_Unmount'),
+ DISPLAY => dualvar( 18, 'Display'),
+ MAIL_GENERIC => dualvar( 19, 'Mail_Generic'),
+ MISC => dualvar( 20, 'Misc'),
+ KORGANIZER => dualvar( 21, 'KOrganizer'),
+ ASCII => dualvar( 22, 'ASCII'),
+ ICONS => dualvar( 23, 'Icons'),
+ CONNECT_ESTABLISHED => dualvar( 24, 'Connect_Established'),
+ FOLDER_MAIL => dualvar( 25, 'Folder_Mail'),
+ FILESAVE => dualvar( 26, 'FileSave'),
+ NFS_UNMOUNT => dualvar( 27, 'NFS_Unmount'),
+ MESSAGE => dualvar( 28, 'Message'),
+ KGPG_TERM => dualvar( 29, 'KGPG_Term'),
+ KONSOLE => dualvar( 30, 'Konsole'),
+ FILEPRINT => dualvar( 31, 'FilePrint'),
+ FSVIEW => dualvar( 32, 'FSView'),
+ RUN => dualvar( 33, 'Run'),
+ CONFIGURE => dualvar( 34, 'Configure'),
+ KRFB => dualvar( 35, 'KRFB'),
+ ARK => dualvar( 36, 'Ark'),
+ KPERCENTAGE => dualvar( 37, 'KPercentage'),
+ SAMBA_UNMOUNT => dualvar( 38, 'Samba_Unmount'),
+ HISTORY => dualvar( 39, 'History'),
+ MAIL_FIND => dualvar( 40, 'Mail_Find'),
+ VECTORGFX => dualvar( 41, 'VectorGfx'),
+ KCMMEMORY => dualvar( 42, 'KCMMemory'),
+ TRASHCAN_FULL => dualvar( 43, 'Trashcan_Full'),
+ KNOTES => dualvar( 44, 'KNotes'),
+ CANCEL => dualvar( 45, 'Cancel'),
+ HELP => dualvar( 46, 'Help'),
+ KPACKAGE => dualvar( 47, 'KPackage'),
+ FOLDER => dualvar( 48, 'Folder'),
+ FOLDER_BLUE_OPEN => dualvar( 49, 'Folder_Blue_Open'),
+ FOLDER_TAR => dualvar( 50, 'Folder_Tar'),
+ DECRYPTED => dualvar( 51, 'Decrypted'),
+ ENCRYPTED => dualvar( 52, 'Encrypted'),
+ APPLY => dualvar( 53, 'Apply'),
+ SIGNATURE => dualvar( 54, 'Signature'),
+ THUMBNAIL => dualvar( 55, 'Thumbnail'),
+ KADDRESSBOOK => dualvar( 56, 'KAddressBook'),
+ VIEW_TEXT => dualvar( 57, 'View_Text'),
+ KGPG => dualvar( 58, 'KGPG'),
+ PACKAGE_DEVELOPMENT => dualvar( 59, 'Package_Development'),
+ KFM_HOME => dualvar( 60, 'KFM_Home'),
+ SERVICES => dualvar( 61, 'Services'),
+ TUX => dualvar( 62, 'Tux'),
+ FEATHER => dualvar( 63, 'Feather'),
+ APPLE => dualvar( 64, 'Apple'),
+ W => dualvar( 65, 'W'),
+ MONEY => dualvar( 66, 'Money'),
+ CERTIFICATE => dualvar( 67, 'Certificate'),
+ SMARTPHONE => dualvar( 68, 'Smartphone'),
+ },
+ bool => {
+ FALSE => !1,
+ TRUE => 1,
+ },
+ time => {
+ __prefix => 'TIME',
+ SECONDS_AD1_TO_UNIX_EPOCH => 62_135_596_800,
+ },
+ yubikey => {
+ YUBICO_VID => dualvar( 0x1050, 'Yubico'),
+ YUBIKEY_PID => dualvar( 0x0010, 'YubiKey 1/2'),
+ NEO_OTP_PID => dualvar( 0x0110, 'YubiKey NEO OTP'),
+ NEO_OTP_CCID_PID => dualvar( 0x0111, 'YubiKey NEO OTP+CCID'),
+ NEO_CCID_PID => dualvar( 0x0112, 'YubiKey NEO CCID'),
+ NEO_U2F_PID => dualvar( 0x0113, 'YubiKey NEO FIDO'),
+ NEO_OTP_U2F_PID => dualvar( 0x0114, 'YubiKey NEO OTP+FIDO'),
+ NEO_U2F_CCID_PID => dualvar( 0x0115, 'YubiKey NEO FIDO+CCID'),
+ NEO_OTP_U2F_CCID_PID => dualvar( 0x0116, 'YubiKey NEO OTP+FIDO+CCID'),
+ YK4_OTP_PID => dualvar( 0x0401, 'YubiKey 4/5 OTP'),
+ YK4_U2F_PID => dualvar( 0x0402, 'YubiKey 4/5 FIDO'),
+ YK4_OTP_U2F_PID => dualvar( 0x0403, 'YubiKey 4/5 OTP+FIDO'),
+ YK4_CCID_PID => dualvar( 0x0404, 'YubiKey 4/5 CCID'),
+ YK4_OTP_CCID_PID => dualvar( 0x0405, 'YubiKey 4/5 OTP+CCID'),
+ YK4_U2F_CCID_PID => dualvar( 0x0406, 'YubiKey 4/5 FIDO+CCID'),
+ YK4_OTP_U2F_CCID_PID => dualvar( 0x0407, 'YubiKey 4/5 OTP+FIDO+CCID'),
+ PLUS_U2F_OTP_PID => dualvar( 0x0410, 'YubiKey Plus OTP+FIDO'),
+
+ ONLYKEY_VID => dualvar( 0x1d50, 'OnlyKey'),
+ ONLYKEY_PID => dualvar( 0x60fc, 'OnlyKey'),
+
+ YK_EUSBERR => dualvar( 0x01, 'USB error'),
+ YK_EWRONGSIZ => dualvar( 0x02, 'wrong size'),
+ YK_EWRITEERR => dualvar( 0x03, 'write error'),
+ YK_ETIMEOUT => dualvar( 0x04, 'timeout'),
+ YK_ENOKEY => dualvar( 0x05, 'no yubikey present'),
+ YK_EFIRMWARE => dualvar( 0x06, 'unsupported firmware version'),
+ YK_ENOMEM => dualvar( 0x07, 'out of memory'),
+ YK_ENOSTATUS => dualvar( 0x08, 'no status structure given'),
+ YK_ENOTYETIMPL => dualvar( 0x09, 'not yet implemented'),
+ YK_ECHECKSUM => dualvar( 0x0a, 'checksum mismatch'),
+ YK_EWOULDBLOCK => dualvar( 0x0b, 'operation would block'),
+ YK_EINVALIDCMD => dualvar( 0x0c, 'invalid command for operation'),
+ YK_EMORETHANONE => dualvar( 0x0d, 'expected only one YubiKey but serveral present'),
+ YK_ENODATA => dualvar( 0x0e, 'no data returned from device'),
+
+ CONFIG1_VALID => 0x01,
+ CONFIG2_VALID => 0x02,
+ CONFIG1_TOUCH => 0x04,
+ CONFIG2_TOUCH => 0x08,
+ CONFIG_LED_INV => 0x10,
+ CONFIG_STATUS_MASK => 0x1f,
+ },
+ );
+
+ our %EXPORT_TAGS;
+ my %seen;
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ while (my ($tag, $constants) = each %CONSTANTS) {
+ my $prefix = delete $constants->{__prefix};
+ while (my ($name, $value) = each %$constants) {
+ my $val = $value;
+ $val = $val+0 if $tag eq 'icon'; # TODO
+ $name =~ s/^_+//;
+ my $full_name = $prefix ? "${prefix}_${name}" : $name;
+ die "Duplicate constant: $full_name\n" if $seen{$full_name};
+ *{$full_name} = sub() { $value };
+ push @{$EXPORT_TAGS{$tag} //= []}, $full_name;
+ $seen{$full_name}++;
+ }
+ }
+}
+
+our %EXPORT_TAGS;
+push @{$EXPORT_TAGS{header}}, 'to_header_constant';
+push @{$EXPORT_TAGS{compression}}, 'to_compression_constant';
+push @{$EXPORT_TAGS{inner_header}}, 'to_inner_header_constant';
+push @{$EXPORT_TAGS{icon}}, 'to_icon_constant';
+
+$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
+our @EXPORT_OK = sort @{$EXPORT_TAGS{all}};
+
+my %HEADER;
+for my $header (
+ HEADER_END, HEADER_COMMENT, HEADER_CIPHER_ID, HEADER_COMPRESSION_FLAGS,
+ HEADER_MASTER_SEED, HEADER_TRANSFORM_SEED, HEADER_TRANSFORM_ROUNDS,
+ HEADER_ENCRYPTION_IV, HEADER_INNER_RANDOM_STREAM_KEY, HEADER_STREAM_START_BYTES,
+ HEADER_INNER_RANDOM_STREAM_ID, HEADER_KDF_PARAMETERS, HEADER_PUBLIC_CUSTOM_DATA,
+) {
+ $HEADER{$header} = $HEADER{0+$header} = $header;
+}
+sub to_header_constant { $HEADER{$_[0] // ''} }
+
+my %COMPRESSION;
+for my $compression (COMPRESSION_NONE, COMPRESSION_GZIP) {
+ $COMPRESSION{$compression} = $COMPRESSION{0+$compression} = $compression;
+}
+sub to_compression_constant { $COMPRESSION{$_[0] // ''} }
+
+my %INNER_HEADER;
+for my $inner_header (
+ INNER_HEADER_END, INNER_HEADER_INNER_RANDOM_STREAM_ID,
+ INNER_HEADER_INNER_RANDOM_STREAM_KEY, INNER_HEADER_BINARY,
+) {
+ $INNER_HEADER{$inner_header} = $INNER_HEADER{0+$inner_header} = $inner_header;
+}
+sub to_inner_header_constant { $INNER_HEADER{$_[0] // ''} }
+
+my %ICON;
+for my $icon (
+ ICON_PASSWORD, ICON_PACKAGE_NETWORK, ICON_MESSAGEBOX_WARNING, ICON_SERVER, ICON_KLIPPER,
+ ICON_EDU_LANGUAGES, ICON_KCMDF, ICON_KATE, ICON_SOCKET, ICON_IDENTITY, ICON_KONTACT, ICON_CAMERA,
+ ICON_IRKICKFLASH, ICON_KGPG_KEY3, ICON_LAPTOP_POWER, ICON_SCANNER, ICON_MOZILLA_FIREBIRD,
+ ICON_CDROM_UNMOUNT, ICON_DISPLAY, ICON_MAIL_GENERIC, ICON_MISC, ICON_KORGANIZER, ICON_ASCII, ICON_ICONS,
+ ICON_CONNECT_ESTABLISHED, ICON_FOLDER_MAIL, ICON_FILESAVE, ICON_NFS_UNMOUNT, ICON_MESSAGE, ICON_KGPG_TERM,
+ ICON_KONSOLE, ICON_FILEPRINT, ICON_FSVIEW, ICON_RUN, ICON_CONFIGURE, ICON_KRFB, ICON_ARK,
+ ICON_KPERCENTAGE, ICON_SAMBA_UNMOUNT, ICON_HISTORY, ICON_MAIL_FIND, ICON_VECTORGFX, ICON_KCMMEMORY,
+ ICON_TRASHCAN_FULL, ICON_KNOTES, ICON_CANCEL, ICON_HELP, ICON_KPACKAGE, ICON_FOLDER,
+ ICON_FOLDER_BLUE_OPEN, ICON_FOLDER_TAR, ICON_DECRYPTED, ICON_ENCRYPTED, ICON_APPLY, ICON_SIGNATURE,
+ ICON_THUMBNAIL, ICON_KADDRESSBOOK, ICON_VIEW_TEXT, ICON_KGPG, ICON_PACKAGE_DEVELOPMENT, ICON_KFM_HOME,
+ ICON_SERVICES, ICON_TUX, ICON_FEATHER, ICON_APPLE, ICON_W, ICON_MONEY, ICON_CERTIFICATE, ICON_SMARTPHONE,
+) {
+ $ICON{$icon} = $ICON{0+$icon} = $icon;
+}
+sub to_icon_constant { $ICON{$_[0] // ''} // ICON_PASSWORD }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Constants - All the KDBX-related constants you could ever want
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Constants qw(:all);
+
+ say KDBX_VERSION_4_1;
+
+=head1 DESCRIPTION
+
+This module provides importable constants related to KDBX. Constants can be imported individually or in groups
+(by tag). The available tags are:
+
+=over 4
+
+=item *
+
+L</:magic>
+
+=item *
+
+L</:version>
+
+=item *
+
+L</:header>
+
+=item *
+
+L</:compression>
+
+=item *
+
+L</:cipher>
+
+=item *
+
+L</:random_stream>
+
+=item *
+
+L</:kdf>
+
+=item *
+
+L</:variant_map>
+
+=item *
+
+L</:inner_header>
+
+=item *
+
+L</:key_file>
+
+=item *
+
+L</:history>
+
+=item *
+
+L</:icon>
+
+=item *
+
+L</:bool>
+
+=item *
+
+L</:time>
+
+=item *
+
+L</:yubikey>
+
+=item *
+
+C<:all> - All of the above
+
+=back
+
+View the source of this module to see the constant values (but really you shouldn't care).
+
+=head1 FUNCTIONS
+
+=head2 to_header_constant
+
+ $constant = to_header_constant($number);
+ $constant = to_header_constant($string);
+
+Get a header constant from an integer or string value.
+
+=head2 to_compression_constant
+
+ $constant = to_compression_constant($number);
+ $constant = to_compression_constant($string);
+
+Get a compression constant from an integer or string value.
+
+=head2 to_inner_header_constant
+
+ $constant = to_inner_header_constant($number);
+ $constant = to_inner_header_constant($string);
+
+Get an inner header constant from an integer or string value.
+
+=head2 to_icon_constant
+
+ $constant = to_icon_constant($number);
+ $constant = to_icon_constant($string);
+
+Get an icon constant from an integer or string value.
+
+=head1 CONSTANTS
+
+=head2 :magic
+
+Constants related to identifying the file types:
+
+=over 4
+
+=item C<KDBX_SIG1>
+
+=item C<KDBX_SIG1_FIRST_BYTE>
+
+=item C<KDBX_SIG2_1>
+
+=item C<KDBX_SIG2_2>
+
+=back
+
+=head2 :version
+
+Constants related to identifying the format version of a file:
+
+=over 4
+
+=item C<KDBX_VERSION_2_0>
+
+=item C<KDBX_VERSION_3_0>
+
+=item C<KDBX_VERSION_3_1>
+
+=item C<KDBX_VERSION_4_0>
+
+=item C<KDBX_VERSION_4_1>
+
+=item C<KDBX_VERSION_OLDEST>
+
+=item C<KDBX_VERSION_LATEST>
+
+=item C<KDBX_VERSION_MAJOR_MASK>
+
+=item C<KDBX_VERSION_MINOR_MASK>
+
+=back
+
+=head2 :header
+
+Constants related to parsing and generating KDBX file headers:
+
+=over 4
+
+=item C<HEADER_END>
+
+=item C<HEADER_COMMENT>
+
+=item C<HEADER_CIPHER_ID>
+
+=item C<HEADER_COMPRESSION_FLAGS>
+
+=item C<HEADER_MASTER_SEED>
+
+=item C<HEADER_TRANSFORM_SEED>
+
+=item C<HEADER_TRANSFORM_ROUNDS>
+
+=item C<HEADER_ENCRYPTION_IV>
+
+=item C<HEADER_INNER_RANDOM_STREAM_KEY>
+
+=item C<HEADER_STREAM_START_BYTES>
+
+=item C<HEADER_INNER_RANDOM_STREAM_ID>
+
+=item C<HEADER_KDF_PARAMETERS>
+
+=item C<HEADER_PUBLIC_CUSTOM_DATA>
+
+=back
+
+=head2 :compression
+
+Constants related to identifying the compression state of a file:
+
+=over 4
+
+=item C<COMPRESSION_NONE>
+
+=item C<COMPRESSION_GZIP>
+
+=back
+
+=head2 :cipher
+
+Constants related ciphers:
+
+=over 4
+
+=item C<CIPHER_UUID_AES128>
+
+=item C<CIPHER_UUID_AES256>
+
+=item C<CIPHER_UUID_CHACHA20>
+
+=item C<CIPHER_UUID_SALSA20>
+
+=item C<CIPHER_UUID_SERPENT>
+
+=item C<CIPHER_UUID_TWOFISH>
+
+=back
+
+=head2 :random_stream
+
+Constants related to memory protection stream ciphers:
+
+=over 4
+
+=item C<STREAM_ID_RC4_VARIANT>
+
+This is insecure and not implemented.
+
+=item C<STREAM_ID_SALSA20>
+
+=item C<STREAM_ID_CHACHA20>
+
+=item C<STREAM_SALSA20_IV>
+
+=back
+
+=head2 :kdf
+
+Constants related to key derivation functions and configuration:
+
+=over 4
+
+=item C<KDF_UUID_AES>
+
+=item C<KDF_UUID_AES_CHALLENGE_RESPONSE>
+
+This is what KeePassXC calls C<KDF_AES_KDBX4>.
+
+=item C<KDF_UUID_ARGON2D>
+
+=item C<KDF_UUID_ARGON2ID>
+
+=item C<KDF_PARAM_UUID>
+
+=item C<KDF_PARAM_AES_ROUNDS>
+
+=item C<KDF_PARAM_AES_SEED>
+
+=item C<KDF_PARAM_ARGON2_SALT>
+
+=item C<KDF_PARAM_ARGON2_PARALLELISM>
+
+=item C<KDF_PARAM_ARGON2_MEMORY>
+
+=item C<KDF_PARAM_ARGON2_ITERATIONS>
+
+=item C<KDF_PARAM_ARGON2_VERSION>
+
+=item C<KDF_PARAM_ARGON2_SECRET>
+
+=item C<KDF_PARAM_ARGON2_ASSOCDATA>
+
+=item C<KDF_DEFAULT_AES_ROUNDS>
+
+=item C<KDF_DEFAULT_ARGON2_ITERATIONS>
+
+=item C<KDF_DEFAULT_ARGON2_MEMORY>
+
+=item C<KDF_DEFAULT_ARGON2_PARALLELISM>
+
+=item C<KDF_DEFAULT_ARGON2_VERSION>
+
+=back
+
+=head2 :variant_map
+
+Constants related to parsing and generating KDBX4 variant maps:
+
+=over 4
+
+=item C<VMAP_VERSION>
+
+=item C<VMAP_VERSION_MAJOR_MASK>
+
+=item C<VMAP_TYPE_END>
+
+=item C<VMAP_TYPE_UINT32>
+
+=item C<VMAP_TYPE_UINT64>
+
+=item C<VMAP_TYPE_BOOL>
+
+=item C<VMAP_TYPE_INT32>
+
+=item C<VMAP_TYPE_INT64>
+
+=item C<VMAP_TYPE_STRING>
+
+=item C<VMAP_TYPE_BYTEARRAY>
+
+=back
+
+=head2 :inner_header
+
+Constants related to parsing and generating KDBX4 inner headers:
+
+=over 4
+
+=item C<INNER_HEADER_END>
+
+=item C<INNER_HEADER_INNER_RANDOM_STREAM_ID>
+
+=item C<INNER_HEADER_INNER_RANDOM_STREAM_KEY>
+
+=item C<INNER_HEADER_BINARY>
+
+=item C<INNER_HEADER_BINARY_FLAG_PROTECT>
+
+=back
+
+=head2 :key_file
+
+Constants related to identifying key file types:
+
+=over 4
+
+=item C<KEY_FILE_TYPE_BINARY>
+
+=item C<KEY_FILE_TYPE_HASHED>
+
+=item C<KEY_FILE_TYPE_HEX>
+
+=item C<KEY_FILE_TYPE_XML>
+
+=back
+
+=head2 :history
+
+Constants for history-related default values:
+
+=over 4
+
+=item C<HISTORY_DEFAULT_MAX_AGE>
+
+=item C<HISTORY_DEFAULT_MAX_ITEMS>
+
+=item C<HISTORY_DEFAULT_MAX_SIZE>
+
+=back
+
+=head2 :iteration
+
+Constants for searching algorithms.
+
+=over 4
+
+=item C<ITERATION_IDS> - Iterative deepening search
+
+=item C<ITERATION_BFS> - Breadth-first search
+
+=item C<ITERATION_DFS> - Depth-first search
+
+=back
+
+=head2 :icon
+
+Constants for default icons used by KeePass password safe implementations:
+
+=over 4
+
+=item C<ICON_PASSWORD>
+
+=item C<ICON_PACKAGE_NETWORK>
+
+=item C<ICON_MESSAGEBOX_WARNING>
+
+=item C<ICON_SERVER>
+
+=item C<ICON_KLIPPER>
+
+=item C<ICON_EDU_LANGUAGES>
+
+=item C<ICON_KCMDF>
+
+=item C<ICON_KATE>
+
+=item C<ICON_SOCKET>
+
+=item C<ICON_IDENTITY>
+
+=item C<ICON_KONTACT>
+
+=item C<ICON_CAMERA>
+
+=item C<ICON_IRKICKFLASH>
+
+=item C<ICON_KGPG_KEY3>
+
+=item C<ICON_LAPTOP_POWER>
+
+=item C<ICON_SCANNER>
+
+=item C<ICON_MOZILLA_FIREBIRD>
+
+=item C<ICON_CDROM_UNMOUNT>
+
+=item C<ICON_DISPLAY>
+
+=item C<ICON_MAIL_GENERIC>
+
+=item C<ICON_MISC>
+
+=item C<ICON_KORGANIZER>
+
+=item C<ICON_ASCII>
+
+=item C<ICON_ICONS>
+
+=item C<ICON_CONNECT_ESTABLISHED>
+
+=item C<ICON_FOLDER_MAIL>
+
+=item C<ICON_FILESAVE>
+
+=item C<ICON_NFS_UNMOUNT>
+
+=item C<ICON_MESSAGE>
+
+=item C<ICON_KGPG_TERM>
+
+=item C<ICON_KONSOLE>
+
+=item C<ICON_FILEPRINT>
+
+=item C<ICON_FSVIEW>
+
+=item C<ICON_RUN>
+
+=item C<ICON_CONFIGURE>
+
+=item C<ICON_KRFB>
+
+=item C<ICON_ARK>
+
+=item C<ICON_KPERCENTAGE>
+
+=item C<ICON_SAMBA_UNMOUNT>
+
+=item C<ICON_HISTORY>
+
+=item C<ICON_MAIL_FIND>
+
+=item C<ICON_VECTORGFX>
+
+=item C<ICON_KCMMEMORY>
+
+=item C<ICON_TRASHCAN_FULL>
+
+=item C<ICON_KNOTES>
+
+=item C<ICON_CANCEL>
+
+=item C<ICON_HELP>
+
+=item C<ICON_KPACKAGE>
+
+=item C<ICON_FOLDER>
+
+=item C<ICON_FOLDER_BLUE_OPEN>
+
+=item C<ICON_FOLDER_TAR>
+
+=item C<ICON_DECRYPTED>
+
+=item C<ICON_ENCRYPTED>
+
+=item C<ICON_APPLY>
+
+=item C<ICON_SIGNATURE>
+
+=item C<ICON_THUMBNAIL>
+
+=item C<ICON_KADDRESSBOOK>
+
+=item C<ICON_VIEW_TEXT>
+
+=item C<ICON_KGPG>
+
+=item C<ICON_PACKAGE_DEVELOPMENT>
+
+=item C<ICON_KFM_HOME>
+
+=item C<ICON_SERVICES>
+
+=item C<ICON_TUX>
+
+=item C<ICON_FEATHER>
+
+=item C<ICON_APPLE>
+
+=item C<ICON_W>
+
+=item C<ICON_MONEY>
+
+=item C<ICON_CERTIFICATE>
+
+=item C<ICON_SMARTPHONE>
+
+=back
+
+=head2 :bool
+
+Boolean values:
+
+=over 4
+
+=item C<FALSE>
+
+=item C<TRUE>
+
+=back
+
+=head2 :time
+
+Constants related to time:
+
+=over 4
+
+=item C<TIME_SECONDS_AD1_TO_UNIX_EPOCH>
+
+=back
+
+=head2 :yubikey
+
+Constants related to working with YubiKeys:
+
+=over 4
+
+=item C<YUBICO_VID>
+
+=item C<YUBIKEY_PID>
+
+=item C<NEO_OTP_PID>
+
+=item C<NEO_OTP_CCID_PID>
+
+=item C<NEO_CCID_PID>
+
+=item C<NEO_U2F_PID>
+
+=item C<NEO_OTP_U2F_PID>
+
+=item C<NEO_U2F_CCID_PID>
+
+=item C<NEO_OTP_U2F_CCID_PID>
+
+=item C<YK4_OTP_PID>
+
+=item C<YK4_U2F_PID>
+
+=item C<YK4_OTP_U2F_PID>
+
+=item C<YK4_CCID_PID>
+
+=item C<YK4_OTP_CCID_PID>
+
+=item C<YK4_U2F_CCID_PID>
+
+=item C<YK4_OTP_U2F_CCID_PID>
+
+=item C<PLUS_U2F_OTP_PID>
+
+=item C<ONLYKEY_VID>
+
+=item C<ONLYKEY_PID>
+
+=item C<YK_EUSBERR>
+
+=item C<YK_EWRONGSIZ>
+
+=item C<YK_EWRITEERR>
+
+=item C<YK_ETIMEOUT>
+
+=item C<YK_ENOKEY>
+
+=item C<YK_EFIRMWARE>
+
+=item C<YK_ENOMEM>
+
+=item C<YK_ENOSTATUS>
+
+=item C<YK_ENOTYETIMPL>
+
+=item C<YK_ECHECKSUM>
+
+=item C<YK_EWOULDBLOCK>
+
+=item C<YK_EINVALIDCMD>
+
+=item C<YK_EMORETHANONE>
+
+=item C<YK_ENODATA>
+
+=item C<CONFIG1_VALID>
+
+=item C<CONFIG2_VALID>
+
+=item C<CONFIG1_TOUCH>
+
+=item C<CONFIG2_TOUCH>
+
+=item C<CONFIG_LED_INV>
+
+=item C<CONFIG_STATUS_MASK>
+
+=back
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper;
+# ABSTRACT: Write KDBX files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Constants qw(:magic :header :version :random_stream);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class);
+use File::KDBX;
+use IO::Handle;
+use Module::Load;
+use Ref::Util qw(is_ref is_scalarref);
+use Scalar::Util qw(looks_like_number openhandle);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->init(@_);
+}
+
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+sub _rebless {
+ my $self = shift;
+ my $format = shift // $self->format;
+
+ my $version = $self->kdbx->version;
+
+ my $subclass;
+
+ if (defined $format) {
+ $subclass = $format;
+ }
+ elsif (!defined $version) {
+ $subclass = 'XML';
+ }
+ elsif ($self->kdbx->sig2 == KDBX_SIG2_1) {
+ $subclass = 'KDB';
+ }
+ elsif (looks_like_number($version)) {
+ my $major = $version & KDBX_VERSION_MAJOR_MASK;
+ my %subclasses = (
+ KDBX_VERSION_2_0() => 'V3',
+ KDBX_VERSION_3_0() => 'V3',
+ KDBX_VERSION_4_0() => 'V4',
+ );
+ if ($major == KDBX_VERSION_2_0) {
+ alert sprintf("Upgrading KDBX version %x to version %x\n", $version, KDBX_VERSION_3_1);
+ $self->kdbx->version(KDBX_VERSION_3_1);
+ }
+ $subclass = $subclasses{$major}
+ or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
+ }
+ else {
+ throw sprintf('Unknown file version: %s', $version), version => $version;
+ }
+
+ load "File::KDBX::Dumper::$subclass";
+ bless $self, "File::KDBX::Dumper::$subclass";
+}
+
+
+sub reset {
+ my $self = shift;
+ %$self = ();
+ return $self;
+}
+
+
+sub dump {
+ my $self = shift;
+ my $dst = shift;
+ return $self->dump_handle($dst, @_) if openhandle($dst);
+ return $self->dump_string($dst, @_) if is_scalarref($dst);
+ return $self->dump_file($dst, @_) if defined $dst && !is_ref($dst);
+ throw 'Programmer error: Must pass a stringref, filepath or IO handle to dump';
+}
+
+
+sub dump_string {
+ my $self = shift;
+ my $ref = is_scalarref($_[0]) ? shift : undef;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ $ref //= do {
+ my $buf = '';
+ \$buf;
+ };
+
+ open(my $fh, '>', $ref) or throw "Failed to open string buffer: $!";
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_dump($fh, $key);
+
+ return $ref;
+}
+
+
+sub dump_file {
+ my $self = shift;
+ my $filepath = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ require File::Temp;
+ my ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
+ if (!$fh or my $err = $@) {
+ $err //= 'Unknown error';
+ throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
+ error => $err,
+ filepath => $filepath_temp;
+ }
+ $fh->autoflush(1);
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh, filepath => $filepath);
+ $self->_dump($fh, $key);
+ close($fh);
+
+ my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
+
+ my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
+ my $uid = $args{uid} // $file_uid // -1;
+ my $gid = $args{gid} // $file_gid // -1;
+ chmod($mode, $filepath_temp) if defined $mode;
+ chown($uid, $gid, $filepath_temp);
+ rename($filepath_temp, $filepath) or throw "Failed to write file ($filepath): $!", filepath => $filepath;
+
+ return $self;
+}
+
+
+sub dump_handle {
+ my $self = shift;
+ my $fh = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ $fh = *STDOUT if $fh eq '-';
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_dump($fh, $key);
+}
+
+
+sub kdbx {
+ my $self = shift;
+ return File::KDBX->new if !ref $self;
+ $self->{kdbx} = shift if @_;
+ $self->{kdbx} //= File::KDBX->new;
+}
+
+
+has 'format', is => 'ro';
+has 'inner_format', is => 'ro', default => 'XML';
+has 'allow_upgrade', is => 'ro', default => 1;
+has 'randomize_seeds', is => 'ro', default => 1;
+
+
+sub min_version { KDBX_VERSION_OLDEST }
+
+sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
+
+sub _dump {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+
+ my $kdbx = $self->kdbx;
+
+ my $min_version = $kdbx->minimum_version;
+ if ($kdbx->version < $min_version && $self->allow_upgrade) {
+ alert sprintf("Implicitly upgrading database from %x to %x\n", $kdbx->version, $min_version),
+ version => $kdbx->version, min_version => $min_version;
+ $kdbx->version($min_version);
+ }
+ $self->_rebless;
+
+ if (ref($self) =~ /::(?:KDB|V[34])$/) {
+ $key //= $kdbx->key ? $kdbx->key->reload : undef;
+ defined $key or throw 'Must provide a master key', type => 'key.missing';
+ }
+
+ $self->_prepare;
+
+ my $magic = $self->_write_magic_numbers($fh);
+ my $headers = $self->_write_headers($fh);
+
+ $kdbx->unlock;
+
+ $self->_write_body($fh, $key, "$magic$headers");
+
+ return $kdbx;
+}
+
+sub _prepare {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ if ($kdbx->version < KDBX_VERSION_4_0) {
+ # force Salsa20 inner random stream
+ $kdbx->inner_random_stream_id(STREAM_ID_SALSA20);
+ my $key = $kdbx->inner_random_stream_key;
+ substr($key, 32) = '';
+ $kdbx->inner_random_stream_key($key);
+ }
+
+ $kdbx->randomize_seeds if $self->randomize_seeds;
+}
+
+sub _write_magic_numbers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+
+ $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', sig1 => $kdbx->sig1;
+ $kdbx->version < $self->min_version || KDBX_VERSION_LATEST < $kdbx->version
+ and throw 'Unsupported file version', version => $kdbx->version;
+
+ my @magic = ($kdbx->sig1, $kdbx->sig2, $kdbx->version);
+
+ my $buf = pack('L<3', @magic);
+ $fh->print($buf) or throw 'Failed to write file signature';
+
+ return $buf;
+}
+
+sub _write_headers { die "Not implemented" }
+
+sub _write_body { die "Not implemented" }
+
+sub _write_inner_body {
+ my $self = shift;
+
+ my $current_pkg = ref $self;
+ require Scope::Guard;
+ my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
+
+ $self->_rebless($self->inner_format);
+ $self->_write_inner_body(@_);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Dumper - Write KDBX files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 ATTRIBUTES
+
+=head2 kdbx
+
+ $kdbx = $dumper->kdbx;
+ $dumper->kdbx($kdbx);
+
+Get or set the L<File::KDBX> instance with the data to be dumped.
+
+=head2 format
+
+Get the file format used for writing the database. Normally the format is auto-detected from the database,
+which is the safest choice. Possible formats:
+
+=over 4
+
+=item *
+
+C<V3>
+
+=item *
+
+C<V4>
+
+=item *
+
+C<KDB>
+
+=item *
+
+C<XML> (only used if explicitly set)
+
+=item *
+
+C<Raw> (only used if explicitly set)
+
+=back
+
+B<WARNING:> There is a potential for data loss if you explicitly use a format that doesn't support the
+features used by the KDBX database being written.
+
+The most common reason to explicitly specify the file format is to save a database as an unencrypted XML file:
+
+ $kdbx->dump_file('database.xml', format => 'XML');
+
+=head2 inner_format
+
+Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
+formats:
+
+=over 4
+
+=item *
+
+C<XML> - Write the database groups and entries as XML (default)
+
+=item *
+
+C<Raw> - Write L<File::KDBX/raw> instead of the actual database contents
+
+=back
+
+=head2 allow_upgrade
+
+ $bool = $dumper->allow_upgrade;
+
+Whether or not to allow implicitly upgrading a database to a newer version. When enabled, in order to avoid
+potential data loss, the database can be upgraded as-needed in cases where the database file format version is
+too low to support new features being used.
+
+The default is to allow upgrading.
+
+=head2 randomize_seeds
+
+ $bool = $dumper->randomize_seeds;
+
+Whether or not to randomize seeds in a database before writing. The default is to randomize seeds, and there's
+not often a good reason not to do so. If disabled, the seeds associated with the KDBX database will be used as
+they are.
+
+=head1 METHODS
+
+=head2 new
+
+ $dumper = File::KDBX::Dumper->new(%attributes);
+
+Construct a new L<File::KDBX::Dumper>.
+
+=head2 init
+
+ $dumper = $dumper->init(%attributes);
+
+Initialize a L<File::KDBX::Dumper> with a new set of attributes.
+
+This is called by L</new>.
+
+=head2 reset
+
+ $dumper = $dumper->reset;
+
+Set a L<File::KDBX::Dumper> to a blank state, ready to dumper another KDBX file.
+
+=head2 dump
+
+ $dumper->dump(\$string, $key);
+ $dumper->dump(*IO, $key);
+ $dumper->dump($filepath, $key);
+
+Dump a KDBX file.
+
+The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object.
+
+=head2 dump_string
+
+ $dumper->dump_string(\$string, $key);
+ \$string = $dumper->dump_string($key);
+
+Dump a KDBX file to a string / memory buffer.
+
+=head2 dump_file
+
+ $dumper->dump_file($filepath, $key);
+
+Dump a KDBX file to a filesystem.
+
+=head2 dump_handle
+
+ $dumper->dump_handle($fh, $key);
+ $dumper->dump_handle(*IO, $key);
+
+Dump a KDBX file to an input stream / file handle.
+
+=head2 min_version
+
+ $min_version = File::KDBX::Dumper->min_version;
+
+Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
+it is encoded.
+
+To generate older KDBX files unsupported by this module, try L<File::KeePass>.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::KDB;
+# ABSTRACT: Write KDB files
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(irand);
+use Encode qw(encode);
+use File::KDBX::Constants qw(:magic);
+use File::KDBX::Error;
+use File::KDBX::Loader::KDB;
+use File::KDBX::Util qw(:class :uuid load_optional);
+use namespace::clean;
+
+extends 'File::KDBX::Dumper';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _write_magic_numbers { '' }
+sub _write_headers { '' }
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+
+ load_optional(qw{File::KeePass File::KeePass::KDBX});
+
+ my $k = File::KeePass::KDBX->new($self->kdbx)->to_fkp;
+ $self->_write_custom_icons($self->kdbx, $k);
+
+ # TODO create a KPX_CUSTOM_ICONS_4 meta stream. FKP itself handles KPX_GROUP_TREE_STATE
+
+ substr($k->header->{seed_rand}, 16) = '';
+
+ $key = $self->kdbx->composite_key($key, keep_primitive => 1);
+
+ my $dump = eval { $k->gen_db(File::KDBX::Loader::KDB::_convert_kdbx_to_keepass_master_key($key)) };
+ if (my $err = $@) {
+ throw 'Failed to generate KDB file', error => $err;
+ }
+
+ $self->kdbx->key($key);
+
+ print $fh $dump;
+}
+
+sub _write_custom_icons {
+ my $self = shift;
+ my $kdbx = shift;
+ my $k = shift;
+
+ return if $kdbx->sig2 != KDBX_SIG2_1;
+ return if $k->find_entries({
+ title => 'Meta-Info',
+ username => 'SYSTEM',
+ url => '$',
+ comment => 'KPX_CUSTOM_ICONS_4',
+ });
+
+ my @icons; # icon data
+ my %icons; # icon uuid -> index
+ my %entries; # id -> index
+ my %groups; # id -> index
+ my %gid;
+
+ for my $icon (@{$kdbx->custom_icons}) {
+ my $uuid = $icon->{uuid};
+ my $data = $icon->{data} or next;
+ push @icons, $data;
+ $icons{$uuid} = $#icons;
+ }
+ for my $entry ($k->find_entries({})) {
+ my $icon_uuid = $entry->{custom_icon_uuid} // next;
+ my $icon_index = $icons{$icon_uuid} // next;
+
+ $entry->{id} //= generate_uuid;
+ next if $entries{$entry->{id}};
+
+ $entries{$entry->{id}} = $icon_index;
+ }
+ for my $group ($k->find_groups({})) {
+ $gid{$group->{id} || ''}++;
+ my $icon_uuid = $group->{custom_icon_uuid} // next;
+ my $icon_index = $icons{$icon_uuid} // next;
+
+ if ($group->{id} =~ /^[A-Fa-f0-9]{16}$/) {
+ $group->{id} = hex($group->{id});
+ }
+ elsif ($group->{id} !~ /^\d+$/) {
+ do {
+ $group->{id} = irand;
+ } while $gid{$group->{id}};
+ }
+ $gid{$group->{id}}++;
+ next if $groups{$group->{id}};
+
+ $groups{$group->{id}} = $icon_index;
+ }
+
+ return if !@icons;
+
+ my $stream = '';
+ $stream .= pack('L<3', scalar @icons, scalar keys %entries, scalar keys %groups);
+ for (my $i = 0; $i < @icons; ++$i) {
+ $stream .= pack('L<', length($icons[$i]));
+ $stream .= $icons[$i];
+ }
+ while (my ($id, $icon_index) = each %entries) {
+ $stream .= pack('a16 L<', $id, $icon_index);
+ }
+ while (my ($id, $icon_index) = each %groups) {
+ $stream .= pack('L<2', $id, $icon_index);
+ }
+
+ $k->add_entry({
+ comment => 'KPX_CUSTOM_ICONS_4',
+ title => 'Meta-Info',
+ username => 'SYSTEM',
+ url => '$',
+ id => '0' x 16,
+ icon => 0,
+ binary => {'bin-stream' => $stream},
+ });
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Dumper::KDB - Write KDB files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+Dump older KDB (KeePass 1) files. This feature requires additional modules to be installed:
+
+=over 4
+
+=item *
+
+L<File::KeePass>
+
+=item *
+
+L<File::KeePass::KDBX>
+
+=back
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::Raw;
+# ABSTRACT: A no-op dumper that dumps content as-is
+
+use warnings;
+use strict;
+
+use File::KDBX::Util qw(:class);
+use namespace::clean;
+
+extends 'File::KDBX::Dumper';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _dump {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_body($fh);
+}
+
+sub _write_headers { '' }
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_inner_body($fh);
+}
+
+sub _write_inner_body {
+ my $self = shift;
+ my $fh = shift;
+
+ $fh->print($self->kdbx->raw);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Dumper::Raw - A no-op dumper that dumps content as-is
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Dumper;
+ use File::KDBX;
+
+ my $kdbx = File::KDBX->new;
+ $kdbx->raw("Secret file contents\n");
+
+ $kdbx->dump_file('file.kdbx', $key, inner_format => 'Raw');
+ # OR
+ File::KDBX::Dumper->dump_file('file.kdbx', $key,
+ kdbx => $kdbx,
+ inner_format => 'Raw',
+ );
+
+=head1 DESCRIPTION
+
+A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The
+inner section is usually dumped using L<File::KDBX::Dumper::XML>, but you can use the
+B<File::KDBX::Dumper::Raw> dumper to just write some arbitrary data as the body content. The result won't
+necessarily be parseable by typical KeePass implementations, but it can be read back using
+L<File::KDBX::Loader::Raw>. It's a way to encrypt any file with the same high level of security as a KDBX
+database.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::V3;
+# ABSTRACT: Dump KDBX3 files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Encode qw(encode);
+use File::KDBX::Constants qw(:header :compression);
+use File::KDBX::Error;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HashBlock;
+use File::KDBX::Util qw(:class :empty :load assert_64bit erase_scoped);
+use IO::Handle;
+use namespace::clean;
+
+extends 'File::KDBX::Dumper';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _write_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+ my $headers = $kdbx->headers;
+ my $buf = '';
+
+ # FIXME kinda janky - maybe add a "prepare" hook to massage the KDBX into the correct shape before we get
+ # this far
+ local $headers->{+HEADER_TRANSFORM_SEED} = $kdbx->transform_seed;
+ local $headers->{+HEADER_TRANSFORM_ROUNDS} = $kdbx->transform_rounds;
+
+ if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) {
+ $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment);
+ }
+ for my $type (
+ HEADER_CIPHER_ID,
+ HEADER_COMPRESSION_FLAGS,
+ HEADER_MASTER_SEED,
+ HEADER_TRANSFORM_SEED,
+ HEADER_TRANSFORM_ROUNDS,
+ HEADER_ENCRYPTION_IV,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_STREAM_START_BYTES,
+ HEADER_INNER_RANDOM_STREAM_ID,
+ ) {
+ defined $headers->{$type} or throw "Missing value for required header: $type", type => $type;
+ $buf .= $self->_write_header($fh, $type, $headers->{$type});
+ }
+ $buf .= $self->_write_header($fh, HEADER_END);
+
+ return $buf;
+}
+
+sub _write_header {
+ my $self = shift;
+ my $fh = shift;
+ my $type = shift;
+ my $val = shift // '';
+
+ $type = to_header_constant($type);
+ if ($type == HEADER_END) {
+ $val = "\r\n\r\n";
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = encode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ my $size = length($val);
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ my $size = length($val);
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_TRANSFORM_SEED) {
+ # nothing
+ }
+ elsif ($type == HEADER_TRANSFORM_ROUNDS) {
+ assert_64bit;
+ $val = pack('Q<', $val);
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) {
+ # nothing
+ }
+ elsif ($type == HEADER_STREAM_START_BYTES) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS ||
+ $type == HEADER_PUBLIC_CUSTOM_DATA) {
+ throw "Unexpected KDBX4 header: $type", type => $type;
+ }
+ elsif ($type == HEADER_COMMENT) {
+ throw "Unexpected KDB header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ my $size = length($val);
+ my $buf = pack('C S<', 0+$type, $size);
+
+ $fh->print($buf, $val) or throw 'Failed to write header';
+
+ return "$buf$val";
+}
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_STREAM_START_BYTES,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing $field";
+ }
+
+ my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED};
+
+ my @cleanup;
+ $key = $kdbx->composite_key($key);
+
+ my $response = $key->challenge($master_seed);
+ push @cleanup, erase_scoped $response;
+
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
+
+ $fh->print($kdbx->headers->{+HEADER_STREAM_START_BYTES})
+ or throw 'Failed to write start bytes';
+ $fh->flush;
+
+ $kdbx->key($key);
+
+ $fh = File::KDBX::IO::HashBlock->new($fh);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ load_optional('IO::Compress::Gzip');
+ $fh = IO::Compress::Gzip->new($fh,
+ -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
+ -TextFlag => 1,
+ ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
+ error => $IO::Compress::Gzip::GzipError;
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ my $header_hash = digest_data('SHA256', $header_data);
+ $self->_write_inner_body($fh, $header_hash);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Dumper::V3 - Dump KDBX3 files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::V4;
+# ABSTRACT: Dump KDBX4 files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use Encode qw(encode is_utf8);
+use File::KDBX::Constants qw(:header :inner_header :compression :kdf :variant_map);
+use File::KDBX::Error;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HmacBlock;
+use File::KDBX::Util qw(:class :empty :load assert_64bit erase_scoped);
+use IO::Handle;
+use Scalar::Util qw(looks_like_number);
+use boolean qw(:all);
+use namespace::clean;
+
+extends 'File::KDBX::Dumper';
+
+our $VERSION = '0.800'; # VERSION
+
+has _binaries_written => {}, is => 'ro';
+
+sub _write_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+ my $headers = $kdbx->headers;
+ my $buf = '';
+
+ # Always write the standard AES KDF UUID, for compatibility
+ local $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} = KDF_UUID_AES
+ if $headers->{+HEADER_KDF_PARAMETERS}->{+KDF_PARAM_UUID} eq KDF_UUID_AES_CHALLENGE_RESPONSE;
+
+ if (nonempty (my $comment = $headers->{+HEADER_COMMENT})) {
+ $buf .= $self->_write_header($fh, HEADER_COMMENT, $comment);
+ }
+ for my $type (
+ HEADER_CIPHER_ID,
+ HEADER_COMPRESSION_FLAGS,
+ HEADER_MASTER_SEED,
+ HEADER_ENCRYPTION_IV,
+ HEADER_KDF_PARAMETERS,
+ ) {
+ defined $headers->{$type} or throw "Missing value for required header: $type", type => $type;
+ $buf .= $self->_write_header($fh, $type, $headers->{$type});
+ }
+ $buf .= $self->_write_header($fh, HEADER_PUBLIC_CUSTOM_DATA, $headers->{+HEADER_PUBLIC_CUSTOM_DATA})
+ if defined $headers->{+HEADER_PUBLIC_CUSTOM_DATA} && keys %{$headers->{+HEADER_PUBLIC_CUSTOM_DATA}};
+ $buf .= $self->_write_header($fh, HEADER_END);
+
+ return $buf;
+}
+
+sub _write_header {
+ my $self = shift;
+ my $fh = shift;
+ my $type = shift;
+ my $val = shift // '';
+
+ $type = to_header_constant($type);
+ if ($type == HEADER_END) {
+ # nothing
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = encode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ my $size = length($val);
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ my $size = length($val);
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS) {
+ $val = $self->_write_variant_dictionary($val, {
+ KDF_PARAM_UUID() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_AES_ROUNDS() => VMAP_TYPE_UINT64,
+ KDF_PARAM_AES_SEED() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_ARGON2_SALT() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_ARGON2_PARALLELISM() => VMAP_TYPE_UINT32,
+ KDF_PARAM_ARGON2_MEMORY() => VMAP_TYPE_UINT64,
+ KDF_PARAM_ARGON2_ITERATIONS() => VMAP_TYPE_UINT64,
+ KDF_PARAM_ARGON2_VERSION() => VMAP_TYPE_UINT32,
+ KDF_PARAM_ARGON2_SECRET() => VMAP_TYPE_BYTEARRAY,
+ KDF_PARAM_ARGON2_ASSOCDATA() => VMAP_TYPE_BYTEARRAY,
+ });
+ }
+ elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) {
+ $val = $self->_write_variant_dictionary($val);
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID ||
+ $type == HEADER_INNER_RANDOM_STREAM_KEY ||
+ $type == HEADER_TRANSFORM_SEED ||
+ $type == HEADER_TRANSFORM_ROUNDS ||
+ $type == HEADER_STREAM_START_BYTES) {
+ throw "Unexpected KDBX3 header: $type", type => $type;
+ }
+ elsif ($type == HEADER_COMMENT) {
+ throw "Unexpected KDB header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ my $size = length($val);
+ my $buf = pack('C L<', 0+$type, $size);
+
+ $fh->print($buf, $val) or throw 'Failed to write header';
+
+ return "$buf$val";
+}
+
+sub _intuit_variant_type {
+ my $self = shift;
+ my $variant = shift;
+
+ if (isBoolean($variant)) {
+ return VMAP_TYPE_BOOL;
+ }
+ elsif (looks_like_number($variant) && ($variant + 0) =~ /^\d+$/) {
+ assert_64bit;
+ my $neg = $variant < 0;
+ my @b = unpack('L>2', pack('Q>', $variant));
+ return VMAP_TYPE_INT64 if $b[0] && $neg;
+ return VMAP_TYPE_UINT64 if $b[0];
+ return VMAP_TYPE_INT32 if $neg;
+ return VMAP_TYPE_UINT32;
+ }
+ elsif (is_utf8($variant)) {
+ return VMAP_TYPE_STRING;
+ }
+ return VMAP_TYPE_BYTEARRAY;
+}
+
+sub _write_variant_dictionary {
+ my $self = shift;
+ my $dict = shift || {};
+ my $types = shift || {};
+
+ my $buf = '';
+
+ $buf .= pack('S<', VMAP_VERSION);
+
+ for my $key (sort keys %$dict) {
+ my $val = $dict->{$key};
+
+ my $type = $types->{$key} // $self->_intuit_variant_type($val);
+ $buf .= pack('C', $type);
+
+ if ($type == VMAP_TYPE_UINT32) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == VMAP_TYPE_UINT64) {
+ assert_64bit;
+ $val = pack('Q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_BOOL) {
+ $val = pack('C', $val);
+ }
+ elsif ($type == VMAP_TYPE_INT32) {
+ $val = pack('l', $val);
+ }
+ elsif ($type == VMAP_TYPE_INT64) {
+ assert_64bit;
+ $val = pack('q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_STRING) {
+ $val = encode('UTF-8', $val);
+ }
+ elsif ($type == VMAP_TYPE_BYTEARRAY) {
+ # $val = substr($$buf, $pos, $vlen);
+ # $val = [split //, $val];
+ }
+ else {
+ throw 'Unknown variant dictionary value type', type => $type;
+ }
+
+ my ($klen, $vlen) = (length($key), length($val));
+ $buf .= pack("L< a$klen L< a$vlen", $klen, $key, $vlen, $val);
+ }
+
+ $buf .= pack('C', VMAP_TYPE_END);
+
+ return $buf;
+}
+
+sub _write_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing header: $field";
+ }
+
+ my @cleanup;
+
+ # write 32-byte checksum
+ my $header_hash = digest_data('SHA256', $header_data);
+ $fh->print($header_hash) or throw 'Failed to write header hash';
+
+ $key = $kdbx->composite_key($key);
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ # write 32-byte HMAC for header
+ my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01");
+ push @cleanup, erase_scoped $hmac_key;
+ my $header_hmac = hmac('SHA256',
+ digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key),
+ $header_data,
+ );
+ $fh->print($header_hmac) or throw 'Failed to write header HMAC';
+
+ $kdbx->key($key);
+
+ # HMAC-block the rest of the stream
+ $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key);
+
+ my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ load_optional('IO::Compress::Gzip');
+ $fh = IO::Compress::Gzip->new($fh,
+ -Level => IO::Compress::Gzip::Z_BEST_COMPRESSION(),
+ -TextFlag => 1,
+ ) or throw "Failed to initialize compression library: $IO::Compress::Gzip::GzipError",
+ error => $IO::Compress::Gzip::GzipError;
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ $self->_write_inner_headers($fh);
+
+ local $self->{compress_datetimes} = 1;
+ $self->_write_inner_body($fh, $header_hash);
+}
+
+sub _write_inner_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+ my $headers = $kdbx->inner_headers;
+
+ for my $type (
+ INNER_HEADER_INNER_RANDOM_STREAM_ID,
+ INNER_HEADER_INNER_RANDOM_STREAM_KEY,
+ ) {
+ defined $headers->{$type} or throw "Missing inner header: $type";
+ $self->_write_inner_header($fh, $type => $headers->{$type});
+ }
+
+ $self->_write_binaries($fh);
+
+ $self->_write_inner_header($fh, INNER_HEADER_END);
+}
+
+sub _write_inner_header {
+ my $self = shift;
+ my $fh = shift;
+ my $type = shift;
+ my $val = shift // '';
+
+ my $buf = pack('C', $type);
+ $fh->print($buf) or throw 'Failed to write inner header type';
+
+ $type = to_inner_header_constant($type);
+ if ($type == INNER_HEADER_END) {
+ # nothing
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = pack('L<', $val);
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
+ # nothing
+ }
+ elsif ($type == INNER_HEADER_BINARY) {
+ # nothing
+ }
+
+ $buf = pack('L<', length($val));
+ $fh->print($buf) or throw 'Failed to write inner header value size';
+ $fh->print($val) or throw 'Failed to write inner header value';
+}
+
+sub _write_binaries {
+ my $self = shift;
+ my $fh = shift;
+
+ my $kdbx = $self->kdbx;
+
+ my $new_ref = 0;
+ my $written = $self->_binaries_written;
+
+ my $entries = $kdbx->entries(history => 1);
+ while (my $entry = $entries->next) {
+ for my $key (keys %{$entry->binaries}) {
+ my $binary = $entry->binaries->{$key};
+ if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
+ $binary = $kdbx->binaries->{$binary->{ref}};
+ }
+
+ if (!defined $binary->{value}) {
+ alert "Skipping binary which has no value: $key", key => $key;
+ next;
+ }
+
+ my $hash = digest_data('SHA256', $binary->{value});
+ if (defined $written->{$hash}) {
+ # nothing
+ }
+ else {
+ my $flags = 0;
+ $flags &= INNER_HEADER_BINARY_FLAG_PROTECT if $binary->{protect};
+
+ $self->_write_binary($fh, \$binary->{value}, $flags);
+ $written->{$hash} = $new_ref++;
+ }
+ }
+ }
+}
+
+sub _write_binary {
+ my $self = shift;
+ my $fh = shift;
+ my $data = shift;
+ my $flags = shift || 0;
+
+ my $buf = pack('C', 0 + INNER_HEADER_BINARY);
+ $fh->print($buf) or throw 'Failed to write inner header type';
+
+ $buf = pack('L<', 1 + length($$data));
+ $fh->print($buf) or throw 'Failed to write inner header value size';
+
+ $buf = pack('C', $flags);
+ $fh->print($buf) or throw 'Failed to write inner header binary flags';
+
+ $fh->print($$data) or throw 'Failed to write inner header value';
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Dumper::V4 - Dump KDBX4 files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Dumper::XML;
+# ABSTRACT: Dump unencrypted XML KeePass files
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Misc 0.029 qw(encode_b64);
+use Encode qw(encode);
+use File::KDBX::Constants qw(:version :time);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class assert_64bit erase_scoped gzip snakify);
+use IO::Handle;
+use Scalar::Util qw(blessed isdual looks_like_number);
+use Time::Piece;
+use XML::LibXML;
+use boolean;
+use namespace::clean;
+
+extends 'File::KDBX::Dumper';
+
+our $VERSION = '0.800'; # VERSION
+
+
+has allow_protection => 1;
+has binaries => sub { $_[0]->kdbx->version < KDBX_VERSION_4_0 };
+has 'compress_binaries';
+has 'compress_datetimes';
+
+sub header_hash { $_[0]->{header_hash} }
+
+sub _binaries_written { $_[0]->{_binaries_written} //= {} }
+
+sub _random_stream { $_[0]->{random_stream} //= $_[0]->kdbx->random_stream }
+
+sub _dump {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_inner_body($fh, $self->header_hash);
+}
+
+sub _write_inner_body {
+ my $self = shift;
+ my $fh = shift;
+ my $header_hash = shift;
+
+ my $dom = XML::LibXML::Document->new('1.0', 'UTF-8');
+ $dom->setStandalone(1);
+
+ my $doc = XML::LibXML::Element->new('KeePassFile');
+ $dom->setDocumentElement($doc);
+
+ my $meta = XML::LibXML::Element->new('Meta');
+ $doc->appendChild($meta);
+ $self->_write_xml_meta($meta, $header_hash);
+
+ my $root = XML::LibXML::Element->new('Root');
+ $doc->appendChild($root);
+ $self->_write_xml_root($root);
+
+ $dom->toFH($fh, 1);
+}
+
+sub _write_xml_meta {
+ my $self = shift;
+ my $node = shift;
+ my $header_hash = shift;
+
+ my $meta = $self->kdbx->meta;
+ local $meta->{generator} = $self->kdbx->user_agent_string // __PACKAGE__;
+ local $meta->{header_hash} = $header_hash;
+
+ $self->_write_xml_from_pairs($node, $meta,
+ Generator => 'text',
+ $self->kdbx->version < KDBX_VERSION_4_0 && defined $meta->{header_hash} ? (
+ HeaderHash => 'binary',
+ ) : (),
+ DatabaseName => 'text',
+ DatabaseNameChanged => 'datetime',
+ DatabaseDescription => 'text',
+ DatabaseDescriptionChanged => 'datetime',
+ DefaultUserName => 'text',
+ DefaultUserNameChanged => 'datetime',
+ MaintenanceHistoryDays => 'number',
+ Color => 'text',
+ MasterKeyChanged => 'datetime',
+ MasterKeyChangeRec => 'number',
+ MasterKeyChangeForce => 'number',
+ MemoryProtection => \&_write_xml_memory_protection,
+ CustomIcons => \&_write_xml_custom_icons,
+ RecycleBinEnabled => 'bool',
+ RecycleBinUUID => 'uuid',
+ RecycleBinChanged => 'datetime',
+ EntryTemplatesGroup => 'uuid',
+ EntryTemplatesGroupChanged => 'datetime',
+ LastSelectedGroup => 'uuid',
+ LastTopVisibleGroup => 'uuid',
+ HistoryMaxItems => 'number',
+ HistoryMaxSize => 'number',
+ $self->kdbx->version >= KDBX_VERSION_4_0 ? (
+ SettingsChanged => 'datetime',
+ ) : (),
+ $self->kdbx->version < KDBX_VERSION_4_0 || $self->binaries ? (
+ Binaries => \&_write_xml_binaries,
+ ) : (),
+ CustomData => \&_write_xml_custom_data,
+ );
+}
+
+sub _write_xml_memory_protection {
+ my $self = shift;
+ my $node = shift;
+
+ my $memory_protection = $self->kdbx->meta->{memory_protection};
+
+ $self->_write_xml_from_pairs($node, $memory_protection,
+ ProtectTitle => 'bool',
+ ProtectUserName => 'bool',
+ ProtectPassword => 'bool',
+ ProtectURL => 'bool',
+ ProtectNotes => 'bool',
+ # AutoEnableVisualHiding => 'bool',
+ );
+}
+
+sub _write_xml_binaries {
+ my $self = shift;
+ my $node = shift;
+
+ my $kdbx = $self->kdbx;
+
+ my $new_ref = keys %{$self->_binaries_written};
+ my $written = $self->_binaries_written;
+
+ my $entries = $kdbx->entries(history => 1);
+ while (my $entry = $entries->next) {
+ for my $key (keys %{$entry->binaries}) {
+ my $binary = $entry->binaries->{$key};
+ if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
+ $binary = $kdbx->binaries->{$binary->{ref}};
+ }
+
+ if (!defined $binary->{value}) {
+ alert "Skipping binary which has no value: $key", key => $key;
+ next;
+ }
+
+ my $hash = digest_data('SHA256', $binary->{value});
+ if (defined $written->{$hash}) {
+ # nothing
+ }
+ else {
+ my $binary_node = $node->addNewChild(undef, 'Binary');
+ $binary_node->setAttribute('ID', _encode_text($new_ref));
+ $binary_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect};
+ $self->_write_xml_compressed_content($binary_node, \$binary->{value}, $binary->{protect});
+ $written->{$hash} = $new_ref++;
+ }
+ }
+ }
+}
+
+sub _write_xml_compressed_content {
+ my $self = shift;
+ my $node = shift;
+ my $value = shift;
+ my $protect = shift;
+
+ my @cleanup;
+
+ my $encoded;
+ if (utf8::is_utf8($$value)) {
+ $encoded = encode('UTF-8', $$value);
+ push @cleanup, erase_scoped $encoded;
+ $value = \$encoded;
+ }
+
+ my $should_compress = $self->compress_binaries;
+ my $try_compress = $should_compress || !defined $should_compress;
+
+ my $compressed;
+ if ($try_compress) {
+ $compressed = gzip($$value);
+ push @cleanup, erase_scoped $compressed;
+
+ if ($should_compress || length($compressed) < length($$value)) {
+ $value = \$compressed;
+ $node->setAttribute('Compressed', _encode_bool(true));
+ }
+ }
+
+ my $encrypted;
+ if ($protect) {
+ $encrypted = $self->_random_stream->crypt($$value);
+ push @cleanup, erase_scoped $encrypted;
+ $value = \$encrypted;
+ }
+
+ $node->appendText(_encode_binary($$value));
+}
+
+sub _write_xml_custom_icons {
+ my $self = shift;
+ my $node = shift;
+
+ my $custom_icons = $self->kdbx->custom_icons;
+
+ for my $icon (@$custom_icons) {
+ $icon->{uuid} && $icon->{data} or next;
+ my $icon_node = $node->addNewChild(undef, 'Icon');
+
+ $self->_write_xml_from_pairs($icon_node, $icon,
+ UUID => 'uuid',
+ Data => 'binary',
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ Name => 'text',
+ LastModificationTime => 'datetime',
+ ) : (),
+ );
+ }
+}
+
+sub _write_xml_custom_data {
+ my $self = shift;
+ my $node = shift;
+ my $custom_data = shift || {};
+
+ for my $key (sort keys %$custom_data) {
+ my $item = $custom_data->{$key};
+ my $item_node = $node->addNewChild(undef, 'Item');
+
+ local $item->{key} = $key if !defined $item->{key};
+
+ $self->_write_xml_from_pairs($item_node, $item,
+ Key => 'text',
+ Value => 'text',
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ LastModificationTime => 'datetime',
+ ) : (),
+ );
+ }
+}
+
+sub _write_xml_root {
+ my $self = shift;
+ my $node = shift;
+ my $kdbx = $self->kdbx;
+
+ my $guard = $kdbx->unlock_scoped;
+
+ if (my $group = $kdbx->root) {
+ my $group_node = $node->addNewChild(undef, 'Group');
+ $self->_write_xml_group($group_node, $group->_committed);
+ }
+
+ undef $guard; # re-lock if needed, as early as possible
+
+ my $deleted_objects_node = $node->addNewChild(undef, 'DeletedObjects');
+ $self->_write_xml_deleted_objects($deleted_objects_node);
+}
+
+sub _write_xml_group {
+ my $self = shift;
+ my $node = shift;
+ my $group = shift;
+
+ $self->_write_xml_from_pairs($node, $group,
+ UUID => 'uuid',
+ Name => 'text',
+ Notes => 'text',
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ Tags => 'text',
+ ) : (),
+ IconID => 'number',
+ defined $group->{custom_icon_uuid} ? (
+ CustomIconUUID => 'uuid',
+ ) : (),
+ Times => \&_write_xml_times,
+ IsExpanded => 'bool',
+ DefaultAutoTypeSequence => 'text',
+ EnableAutoType => 'tristate',
+ EnableSearching => 'tristate',
+ LastTopVisibleEntry => 'uuid',
+ KDBX_VERSION_4_0 <= $self->kdbx->version ? (
+ CustomData => \&_write_xml_custom_data,
+ ) : (),
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ PreviousParentGroup => 'uuid',
+ ) : (),
+ );
+
+ for my $entry (@{$group->entries}) {
+ my $entry_node = $node->addNewChild(undef, 'Entry');
+ $self->_write_xml_entry($entry_node, $entry->_committed);
+ }
+
+ for my $group (@{$group->groups}) {
+ my $group_node = $node->addNewChild(undef, 'Group');
+ $self->_write_xml_group($group_node, $group->_committed);
+ }
+}
+
+sub _write_xml_entry {
+ my $self = shift;
+ my $node = shift;
+ my $entry = shift;
+ my $in_history = shift;
+
+ $self->_write_xml_from_pairs($node, $entry,
+ UUID => 'uuid',
+ IconID => 'number',
+ defined $entry->{custom_icon_uuid} ? (
+ CustomIconUUID => 'uuid',
+ ) : (),
+ ForegroundColor => 'text',
+ BackgroundColor => 'text',
+ OverrideURL => 'text',
+ Tags => 'text',
+ Times => \&_write_xml_times,
+ KDBX_VERSION_4_1 <= $self->kdbx->version ? (
+ QualityCheck => 'bool',
+ PreviousParentGroup => 'uuid',
+ ) : (),
+ );
+
+ for my $key (sort keys %{$entry->{strings} || {}}) {
+ my $string = $entry->{strings}{$key};
+ my $string_node = $node->addNewChild(undef, 'String');
+ local $string->{key} = $string->{key} // $key;
+ $self->_write_xml_entry_string($string_node, $string);
+ }
+
+ my $kdbx = $self->kdbx;
+ my $new_ref = keys %{$self->_binaries_written};
+ my $written = $self->_binaries_written;
+
+ for my $key (sort keys %{$entry->{binaries} || {}}) {
+ my $binary = $entry->binaries->{$key};
+ if (defined $binary->{ref} && defined $kdbx->binaries->{$binary->{ref}}) {
+ $binary = $kdbx->binaries->{$binary->{ref}};
+ }
+
+ if (!defined $binary->{value}) {
+ alert "Skipping binary which has no value: $key", key => $key;
+ next;
+ }
+
+ my $binary_node = $node->addNewChild(undef, 'Binary');
+ $binary_node->addNewChild(undef, 'Key')->appendText(_encode_text($key));
+ my $value_node = $binary_node->addNewChild(undef, 'Value');
+
+ my $hash = digest_data('SHA256', $binary->{value});
+ if (defined $written->{$hash}) {
+ # write reference
+ $value_node->setAttribute('Ref', _encode_text($written->{$hash}));
+ }
+ else {
+ # write actual binary
+ $value_node->setAttribute('Protected', _encode_bool(true)) if $binary->{protect};
+ $self->_write_xml_compressed_content($value_node, \$binary->{value}, $binary->{protect});
+ $written->{$hash} = $new_ref++;
+ }
+ }
+
+ $self->_write_xml_from_pairs($node, $entry,
+ AutoType => \&_write_xml_entry_auto_type,
+ );
+
+ $self->_write_xml_from_pairs($node, $entry,
+ KDBX_VERSION_4_0 <= $self->kdbx->version ? (
+ CustomData => \&_write_xml_custom_data,
+ ) : (),
+ );
+
+ if (!$in_history) {
+ if (my @history = @{$entry->history}) {
+ my $history_node = $node->addNewChild(undef, 'History');
+ for my $historical (@history) {
+ my $historical_node = $history_node->addNewChild(undef, 'Entry');
+ $self->_write_xml_entry($historical_node, $historical->_committed, 1);
+ }
+ }
+ }
+}
+
+sub _write_xml_entry_auto_type {
+ my $self = shift;
+ my $node = shift;
+ my $autotype = shift;
+
+ $self->_write_xml_from_pairs($node, $autotype,
+ Enabled => 'bool',
+ DataTransferObfuscation => 'number',
+ DefaultSequence => 'text',
+ );
+
+ for my $association (@{$autotype->{associations} || []}) {
+ my $association_node = $node->addNewChild(undef, 'Association');
+ $self->_write_xml_from_pairs($association_node, $association,
+ Window => 'text',
+ KeystrokeSequence => 'text',
+ );
+ }
+}
+
+sub _write_xml_times {
+ my $self = shift;
+ my $node = shift;
+ my $times = shift;
+
+ $self->_write_xml_from_pairs($node, $times,
+ LastModificationTime => 'datetime',
+ CreationTime => 'datetime',
+ LastAccessTime => 'datetime',
+ ExpiryTime => 'datetime',
+ Expires => 'bool',
+ UsageCount => 'number',
+ LocationChanged => 'datetime',
+ );
+}
+
+sub _write_xml_entry_string {
+ my $self = shift;
+ my $node = shift;
+ my $string = shift;
+
+ my @cleanup;
+
+ my $kdbx = $self->kdbx;
+ my $key = $string->{key};
+
+ $node->addNewChild(undef, 'Key')->appendText(_encode_text($key));
+ my $value_node = $node->addNewChild(undef, 'Value');
+
+ my $value = $string->{value} || '';
+
+ my $memory_protection = $kdbx->meta->{memory_protection};
+ my $memprot_key = 'protect_' . snakify($key);
+ my $protect = $string->{protect} || $memory_protection->{$memprot_key};
+
+ if ($protect) {
+ if ($self->allow_protection) {
+ my $encoded;
+ if (utf8::is_utf8($value)) {
+ $encoded = encode('UTF-8', $value);
+ push @cleanup, erase_scoped $encoded;
+ $value = $encoded;
+ }
+
+ $value_node->setAttribute('Protected', _encode_bool(true));
+ $value = _encode_binary($self->_random_stream->crypt(\$value));
+ }
+ else {
+ $value_node->setAttribute('ProtectInMemory', _encode_bool(true));
+ $value = _encode_text($value);
+ }
+ }
+ else {
+ $value = _encode_text($value);
+ }
+
+ $value_node->appendText($value) if defined $value;
+}
+
+sub _write_xml_deleted_objects {
+ my $self = shift;
+ my $node = shift;
+
+ my $objects = $self->kdbx->deleted_objects;
+
+ for my $uuid (sort keys %{$objects || {}}) {
+ my $object = $objects->{$uuid};
+ local $object->{uuid} = $uuid;
+ my $object_node = $node->addNewChild(undef, 'DeletedObject');
+ $self->_write_xml_from_pairs($object_node, $object,
+ UUID => 'uuid',
+ DeletionTime => 'datetime',
+ );
+ }
+}
+
+##############################################################################
+
+sub _write_xml_from_pairs {
+ my $self = shift;
+ my $node = shift;
+ my $hash = shift;
+ my @spec = @_;
+
+ while (@spec) {
+ my ($name, $type) = splice @spec, 0, 2;
+ my $key = snakify($name);
+
+ if (ref $type eq 'CODE') {
+ my $child_node = $node->addNewChild(undef, $name);
+ $self->$type($child_node, $hash->{$key});
+ }
+ else {
+ next if !exists $hash->{$key};
+ my $child_node = $node->addNewChild(undef, $name);
+ $type = 'datetime_binary' if $type eq 'datetime' && $self->compress_datetimes;
+ $child_node->appendText(_encode_primitive($hash->{$key}, $type));
+ }
+ }
+}
+
+##############################################################################
+
+sub _encode_primitive { goto &{__PACKAGE__."::_encode_$_[1]"} }
+
+sub _encode_binary {
+ return '' if !defined $_[0] || (ref $_[0] && !defined $$_[0]);
+ return encode_b64(ref $_[0] ? $$_[0] : $_[0]);
+}
+
+sub _encode_bool {
+ local $_ = shift;
+ return $_ ? 'True' : 'False';
+}
+
+sub _encode_datetime {
+ local $_ = shift;
+ return $_->strftime('%Y-%m-%dT%H:%M:%SZ');
+}
+
+sub _encode_datetime_binary {
+ local $_ = shift;
+ assert_64bit;
+ my $seconds_since_ad1 = $_ + TIME_SECONDS_AD1_TO_UNIX_EPOCH;
+ my $buf = pack('Q<', $seconds_since_ad1->epoch);
+ return eval { encode_b64($buf) };
+}
+
+sub _encode_tristate {
+ local $_ = shift // return 'null';
+ return $_ ? 'True' : 'False';
+}
+
+sub _encode_number {
+ local $_ = shift // return;
+ looks_like_number($_) || isdual($_) or throw 'Expected number', text => $_;
+ return _encode_text($_+0);
+}
+
+sub _encode_text {
+ return '' if !defined $_[0];
+ return $_[0];
+}
+
+sub _encode_uuid { _encode_binary(@_) }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Dumper::XML - Dump unencrypted XML KeePass files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 ATTRIBUTES
+
+=head2 allow_protection
+
+ $bool = $dumper->allow_protection;
+
+Get whether or not protected strings and binaries should be written in an encrypted stream. Default: C<TRUE>
+
+=head2 binaries
+
+ $bool = $dumper->binaries;
+
+Get whether or not binaries within the database should be written. Default: C<TRUE>
+
+=head2 compress_binaries
+
+ $tristate = $dumper->compress_binaries;
+
+Get whether or not to compress binaries. Possible values:
+
+=over 4
+
+=item *
+
+C<TRUE> - Always compress binaries
+
+=item *
+
+C<FALSE> - Never compress binaries
+
+=item *
+
+C<undef> - Compress binaries if it results in smaller database sizes (default)
+
+=back
+
+=head2 compress_datetimes
+
+ $bool = $dumper->compress_datetimes;
+
+Get whether or not to write compressed datetimes. Datetimes are traditionally written in the human-readable
+string format of C<1970-01-01T00:00:00Z>, but they can also be written in a compressed form to save some
+bytes. The default is to write compressed datetimes if the KDBX file version is 4+, otherwise use the
+human-readable format.
+
+=head2 header_hash
+
+ $octets = $dumper->header_hash;
+
+Get the value to be written as the B<HeaderHash> in the B<Meta> section. This is the way KDBX3 files validate
+the authenticity of header data. This is unnecessary and should not be used with KDBX4 files because that
+format uses HMAC-SHA256 to detect tampering.
+
+L<File::KDBX::Dumper::V3> automatically calculates the header hash an provides it to this module, and plain
+XML files which don't have a KDBX wrapper don't have headers and so should have a header hash. Therefore there
+is probably never any reason to set this manually.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Entry;
+# ABSTRACT: A KDBX database entry
+
+use warnings;
+use strict;
+
+use Crypt::Misc 0.029 qw(decode_b64 encode_b32r);
+use Devel::GlobalDestruction;
+use Encode qw(encode);
+use File::KDBX::Constants qw(:history :icon);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:assert :class :coercion :erase :function :uri generate_uuid load_optional);
+use Hash::Util::FieldHash;
+use List::Util qw(first sum0);
+use Ref::Util qw(is_coderef is_hashref is_plain_hashref);
+use Scalar::Util qw(blessed looks_like_number);
+use Storable qw(dclone);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+extends 'File::KDBX::Object';
+
+our $VERSION = '0.800'; # VERSION
+
+my $PLACEHOLDER_MAX_DEPTH = 10;
+my %PLACEHOLDERS;
+my %STANDARD_STRINGS = map { $_ => 1 } qw(Title UserName Password URL Notes);
+
+
+sub uuid {
+ my $self = shift;
+ if (@_ || !defined $self->{uuid}) {
+ my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
+ my $old_uuid = $self->{uuid};
+ my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
+ for my $entry (@{$self->history}) {
+ $entry->{uuid} = $uuid;
+ }
+ $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid && $self->is_current;
+ }
+ $self->{uuid};
+}
+
+# has uuid => sub { generate_uuid(printable => 1) };
+has icon_id => ICON_PASSWORD, coerce => \&to_icon_constant;
+has custom_icon_uuid => undef, coerce => \&to_uuid;
+has foreground_color => '', coerce => \&to_string;
+has background_color => '', coerce => \&to_string;
+has override_url => '', coerce => \&to_string;
+has tags => '', coerce => \&to_string;
+has auto_type => {};
+has previous_parent_group => undef, coerce => \&to_uuid;
+has quality_check => true, coerce => \&to_bool;
+has strings => {};
+has binaries => {};
+has times => {};
+# has custom_data => {};
+# has history => [];
+
+has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has expires => false, store => 'times', coerce => \&to_bool;
+has usage_count => 0, store => 'times', coerce => \&to_number;
+has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time;
+
+# has 'auto_type.auto_type_enabled' => true, coerce => \&to_bool;
+has 'auto_type_obfuscation' => 0, path => 'auto_type.data_transfer_obfuscation',
+ coerce => \&to_number;
+has 'auto_type_default_sequence' => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
+ path => 'auto_type.default_sequence', coerce => \&to_string;
+has 'auto_type_associations' => [], path => 'auto_type.associations';
+
+my %ATTRS_STRINGS = (
+ title => 'Title',
+ username => 'UserName',
+ password => 'Password',
+ url => 'URL',
+ notes => 'Notes',
+);
+while (my ($attr, $string_key) = each %ATTRS_STRINGS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *{$attr} = sub { shift->string_value($string_key, @_) };
+ *{"expand_${attr}"} = sub { shift->expand_string_value($string_key, @_) };
+}
+
+my @ATTRS = qw(uuid custom_data history auto_type_enabled);
+sub _set_nonlazy_attributes {
+ my $self = shift;
+ $self->$_ for @ATTRS, keys %ATTRS_STRINGS, list_attributes(ref $self);
+}
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ while (my ($key, $val) = each %args) {
+ if (my $method = $self->can($key)) {
+ $self->$method($val);
+ }
+ else {
+ $self->string($key => $val);
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+
+sub string {
+ my $self = shift;
+ my %args = @_ == 2 ? (key => shift, value => shift)
+ : @_ % 2 == 1 ? (key => shift, @_) : @_;
+
+ if (!defined $args{key} && !defined $args{value}) {
+ my %standard = (value => 1, protect => 1);
+ my @other_keys = grep { !$standard{$_} } keys %args;
+ if (@other_keys == 1) {
+ my $key = $args{key} = $other_keys[0];
+ $args{value} = delete $args{$key};
+ }
+ }
+
+ my $key = delete $args{key} or throw 'Must provide a string key to access';
+
+ return $self->{strings}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{strings}{$key}{$field} = $value;
+ }
+
+ # Auto-vivify the standard strings.
+ if ($STANDARD_STRINGS{$key}) {
+ return $self->{strings}{$key} //= {value => '', $self->_protect($key) ? (protect => true) : ()};
+ }
+ return $self->{strings}{$key};
+}
+
+### Get whether or not a standard string is configured to be protected
+sub _protect {
+ my $self = shift;
+ my $key = shift;
+ return false if !$STANDARD_STRINGS{$key};
+ if (my $kdbx = eval { $self->kdbx }) {
+ my $protect = $kdbx->memory_protection($key);
+ return $protect if defined $protect;
+ }
+ return $key eq 'Password';
+}
+
+
+sub string_value {
+ my $self = shift;
+ my $string = $self->string(@_) // return undef;
+ return $string->{value};
+}
+
+
+sub _expand_placeholder {
+ my $self = shift;
+ my $placeholder = shift;
+ my $arg = shift;
+
+ require File::KDBX;
+
+ my $placeholder_key = $placeholder;
+ if (defined $arg) {
+ $placeholder_key = $File::KDBX::PLACEHOLDERS{"${placeholder}:${arg}"} ? "${placeholder}:${arg}"
+ : "${placeholder}:";
+ }
+ return if !defined $File::KDBX::PLACEHOLDERS{$placeholder_key};
+
+ my $local_key = join('/', Hash::Util::FieldHash::id($self), $placeholder_key);
+ local $PLACEHOLDERS{$local_key} = my $handler = $PLACEHOLDERS{$local_key} // do {
+ my $handler = $File::KDBX::PLACEHOLDERS{$placeholder_key} or next;
+ memoize recurse_limit($handler, $PLACEHOLDER_MAX_DEPTH, sub {
+ alert "Detected deep recursion while expanding $placeholder placeholder",
+ placeholder => $placeholder;
+ return; # undef
+ });
+ };
+
+ return $handler->($self, $arg, $placeholder);
+}
+
+sub _expand_string {
+ my $self = shift;
+ my $str = shift;
+
+ my $expand = memoize $self->can('_expand_placeholder'), $self;
+
+ # placeholders (including field references):
+ $str =~ s!\{([^:\}]+)(?::([^\}]*))?\}!$expand->(uc($1), $2, @_) // $&!egi;
+
+ # environment variables (alt syntax):
+ my $vars = join('|', map { quotemeta($_) } keys %ENV);
+ $str =~ s!\%($vars)\%!$expand->(ENV => $1, @_) // $&!eg;
+
+ return $str;
+}
+
+sub expand_string_value {
+ my $self = shift;
+ my $str = $self->string_peek(@_) // return undef;
+ my $cleanup = erase_scoped $str;
+ return $self->_expand_string($str);
+}
+
+
+sub other_strings {
+ my $self = shift;
+ my $delim = shift // "\n";
+
+ my @strings = map { $self->string_value($_) } grep { !$STANDARD_STRINGS{$_} } sort keys %{$self->strings};
+ return join($delim, @strings);
+}
+
+
+sub string_peek {
+ my $self = shift;
+ my $string = $self->string(@_);
+ return defined $string->{value} ? $string->{value} : $self->kdbx->peek($string);
+}
+
+##############################################################################
+
+
+sub add_auto_type_association {
+ my $self = shift;
+ my $association = shift;
+ push @{$self->auto_type_associations}, $association;
+}
+
+
+sub expand_keystroke_sequence {
+ my $self = shift;
+ my $association = shift;
+
+ my $keys;
+ if ($association) {
+ $keys = is_hashref($association) && exists $association->{keystroke_sequence} ?
+ $association->{keystroke_sequence} : defined $association ? $association : '';
+ }
+
+ $keys = $self->auto_type_default_sequence if !$keys;
+ # TODO - Fall back to getting default sequence from parent group, which probably means we shouldn't be
+ # setting a default value in the entry..
+
+ return $self->_expand_string($keys);
+}
+
+##############################################################################
+
+
+sub binary {
+ my $self = shift;
+ my %args = @_ == 2 ? (key => shift, value => shift)
+ : @_ % 2 == 1 ? (key => shift, @_) : @_;
+
+ if (!defined $args{key} && !defined $args{value}) {
+ my %standard = (value => 1, protect => 1);
+ my @other_keys = grep { !$standard{$_} } keys %args;
+ if (@other_keys == 1) {
+ my $key = $args{key} = $other_keys[0];
+ $args{value} = delete $args{$key};
+ }
+ }
+
+ my $key = delete $args{key} or throw 'Must provide a binary key to access';
+
+ return $self->{binaries}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ assert { !defined $args{value} || !utf8::is_utf8($args{value}) };
+ while (my ($field, $value) = each %args) {
+ $self->{binaries}{$key}{$field} = $value;
+ }
+ return $self->{binaries}{$key};
+}
+
+
+sub binary_value {
+ my $self = shift;
+ my $binary = $self->binary(@_) // return undef;
+ return $binary->{value};
+}
+
+##############################################################################
+
+
+sub hmac_otp {
+ my $self = shift;
+ load_optional('Pass::OTP');
+
+ my %params = ($self->_hotp_params, @_);
+ return if !defined $params{type} || !defined $params{secret};
+
+ $params{secret} = encode_b32r($params{secret}) if !$params{base32};
+ $params{base32} = 1;
+
+ my $otp = eval {Pass::OTP::otp(%params, @_) };
+ if (my $err = $@) {
+ throw 'Unable to generate HOTP', error => $err;
+ }
+
+ $self->_hotp_increment_counter($params{counter});
+
+ return $otp;
+}
+
+
+sub time_otp {
+ my $self = shift;
+ load_optional('Pass::OTP');
+
+ my %params = ($self->_totp_params, @_);
+ return if !defined $params{type} || !defined $params{secret};
+
+ $params{secret} = encode_b32r($params{secret}) if !$params{base32};
+ $params{base32} = 1;
+
+ my $otp = eval {Pass::OTP::otp(%params, @_) };
+ if (my $err = $@) {
+ throw 'Unable to generate TOTP', error => $err;
+ }
+
+ return $otp;
+}
+
+
+sub hmac_otp_uri { $_[0]->_otp_uri($_[0]->_hotp_params) }
+sub time_otp_uri { $_[0]->_otp_uri($_[0]->_totp_params) }
+
+sub _otp_uri {
+ my $self = shift;
+ my %params = @_;
+
+ return if 4 != grep { defined } @params{qw(type secret issuer account)};
+ return if $params{type} !~ /^[ht]otp$/i;
+
+ my $label = delete $params{label};
+ $params{$_} = uri_escape_utf8($params{$_}) for keys %params;
+
+ my $type = lc($params{type});
+ my $issuer = $params{issuer};
+ my $account = $params{account};
+
+ $label //= "$issuer:$account";
+
+ my $secret = $params{secret};
+ $secret = uc(encode_b32r($secret)) if !$params{base32};
+
+ delete $params{algorithm} if defined $params{algorithm} && $params{algorithm} eq 'sha1';
+ delete $params{period} if defined $params{period} && $params{period} == 30;
+ delete $params{digits} if defined $params{digits} && $params{digits} == 6;
+ delete $params{counter} if defined $params{counter} && $params{counter} == 0;
+
+ my $uri = "otpauth://$type/$label?secret=$secret&issuer=$issuer";
+
+ if (defined $params{encoder}) {
+ $uri .= "&encoder=$params{encoder}";
+ return $uri;
+ }
+ $uri .= '&algorithm=' . uc($params{algorithm}) if defined $params{algorithm};
+ $uri .= "&digits=$params{digits}" if defined $params{digits};
+ $uri .= "&counter=$params{counter}" if defined $params{counter};
+ $uri .= "&period=$params{period}" if defined $params{period};
+
+ return $uri;
+}
+
+sub _hotp_params {
+ my $self = shift;
+
+ my %params = (
+ type => 'hotp',
+ issuer => $self->title || 'KDBX',
+ account => $self->username || 'none',
+ digits => 6,
+ counter => $self->string_value('HmacOtp-Counter') // 0,
+ $self->_otp_secret_params('Hmac'),
+ );
+ return %params if $params{secret};
+
+ my %otp_params = $self->_otp_params;
+ return () if !$otp_params{secret} || $otp_params{type} ne 'hotp';
+
+ # $otp_params{counter} = 0
+
+ return (%params, %otp_params);
+}
+
+sub _totp_params {
+ my $self = shift;
+
+ my %algorithms = (
+ 'HMAC-SHA-1' => 'sha1',
+ 'HMAC-SHA-256' => 'sha256',
+ 'HMAC-SHA-512' => 'sha512',
+ );
+ my %params = (
+ type => 'totp',
+ issuer => $self->title || 'KDBX',
+ account => $self->username || 'none',
+ digits => $self->string_value('TimeOtp-Length') // 6,
+ algorithm => $algorithms{$self->string_value('TimeOtp-Algorithm') || ''} || 'sha1',
+ period => $self->string_value('TimeOtp-Period') // 30,
+ $self->_otp_secret_params('Time'),
+ );
+ return %params if $params{secret};
+
+ my %otp_params = $self->_otp_params;
+ return () if !$otp_params{secret} || $otp_params{type} ne 'totp';
+
+ return (%params, %otp_params);
+}
+
+# KeePassXC style
+sub _otp_params {
+ my $self = shift;
+ load_optional('Pass::OTP::URI');
+
+ my $uri = $self->string_value('otp') || '';
+ my %params;
+ %params = Pass::OTP::URI::parse($uri) if $uri =~ m!^otpauth://!;
+ return () if !$params{secret} || !$params{type};
+
+ if (($params{encoder} // '') eq 'steam') {
+ $params{digits} = 5;
+ $params{chars} = '23456789BCDFGHJKMNPQRTVWXY';
+ }
+
+ # Pass::OTP::URI doesn't provide the issuer and account separately, so get them from the label
+ my ($issuer, $user) = split(':', $params{label} // ':', 2);
+ $params{issuer} //= uri_unescape_utf8($issuer);
+ $params{account} //= uri_unescape_utf8($user);
+
+ $params{algorithm} = lc($params{algorithm}) if $params{algorithm};
+ $params{counter} = $self->string_value('HmacOtp-Counter') if $params{type} eq 'hotp';
+
+ return %params;
+}
+
+sub _otp_secret_params {
+ my $self = shift;
+ my $type = shift // return ();
+
+ my $secret_txt = $self->string_value("${type}Otp-Secret");
+ my $secret_hex = $self->string_value("${type}Otp-Secret-Hex");
+ my $secret_b32 = $self->string_value("${type}Otp-Secret-Base32");
+ my $secret_b64 = $self->string_value("${type}Otp-Secret-Base64");
+
+ my $count = grep { defined } ($secret_txt, $secret_hex, $secret_b32, $secret_b64);
+ return () if $count == 0;
+ alert "Found multiple ${type}Otp-Secret strings", count => $count if 1 < $count;
+
+ return (secret => $secret_b32, base32 => 1) if defined $secret_b32;
+ return (secret => decode_b64($secret_b64)) if defined $secret_b64;
+ return (secret => pack('H*', $secret_hex)) if defined $secret_hex;
+ return (secret => encode('UTF-8', $secret_txt));
+}
+
+sub _hotp_increment_counter {
+ my $self = shift;
+ my $counter = shift // $self->string_value('HmacOtp-Counter') || 0;
+
+ looks_like_number($counter) or throw 'HmacOtp-Counter value must be a number', value => $counter;
+ my $next = $counter + 1;
+ $self->string('HmacOtp-Counter', $next);
+ return $next;
+}
+
+##############################################################################
+
+
+sub size {
+ my $self = shift;
+
+ my $size = 0;
+
+ # tags
+ $size += length(encode('UTF-8', $self->tags // ''));
+
+ # attributes (strings)
+ while (my ($key, $string) = each %{$self->strings}) {
+ next if !defined $string->{value};
+ $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $string->{value} // ''));
+ }
+
+ # custom data
+ while (my ($key, $item) = each %{$self->custom_data}) {
+ next if !defined $item->{value};
+ $size += length(encode('UTF-8', $key)) + length(encode('UTF-8', $item->{value} // ''));
+ }
+
+ # binaries
+ while (my ($key, $binary) = each %{$self->binaries}) {
+ next if !defined $binary->{value};
+ my $value_len = utf8::is_utf8($binary->{value}) ? length(encode('UTF-8', $binary->{value}))
+ : length($binary->{value});
+ $size += length(encode('UTF-8', $key)) + $value_len;
+ }
+
+ # autotype associations
+ for my $association (@{$self->auto_type->{associations} || []}) {
+ $size += length(encode('UTF-8', $association->{window}))
+ + length(encode('UTF-8', $association->{keystroke_sequence} // ''));
+ }
+
+ return $size;
+}
+
+##############################################################################
+
+sub history {
+ my $self = shift;
+ my $entries = $self->{history} //= [];
+ if (@$entries && !blessed($entries->[0])) {
+ @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
+ }
+ assert { !any { !blessed $_ } @$entries };
+ return $entries;
+}
+
+
+sub history_size {
+ my $self = shift;
+ return sum0 map { $_->size } @{$self->history};
+}
+
+
+sub prune_history {
+ my $self = shift;
+ my %args = @_;
+
+ my $max_items = $args{max_items} // eval { $self->kdbx->history_max_items } // HISTORY_DEFAULT_MAX_ITEMS;
+ my $max_size = $args{max_size} // eval { $self->kdbx->history_max_size } // HISTORY_DEFAULT_MAX_SIZE;
+ my $max_age = $args{max_age} // HISTORY_DEFAULT_MAX_AGE;
+
+ # history is ordered oldest to newest
+ my $history = $self->history;
+
+ my @removed;
+
+ if (0 <= $max_items && $max_items < @$history) {
+ push @removed, splice @$history, -$max_items;
+ }
+
+ if (0 <= $max_size) {
+ my $current_size = $self->history_size;
+ while ($max_size < $current_size) {
+ push @removed, my $entry = shift @$history;
+ $current_size -= $entry->size;
+ }
+ }
+
+ if (0 <= $max_age) {
+ my $cutoff = gmtime - ($max_age * 86400);
+ for (my $i = @$history - 1; 0 <= $i; --$i) {
+ my $entry = $history->[$i];
+ next if $cutoff <= $entry->last_modification_time;
+ push @removed, splice @$history, $i, 1;
+ }
+ }
+
+ @removed = sort { $a->last_modification_time <=> $b->last_modification_time } @removed;
+ return @removed;
+}
+
+
+sub add_historical_entry {
+ my $self = shift;
+ delete $_->{history} for @_;
+ push @{$self->{history} //= []}, map { $self->_wrap_entry($_) } @_;
+}
+
+
+sub remove_historical_entry {
+ my $self = shift;
+ my $entry = shift;
+ my $history = $self->history;
+
+ my @removed;
+ for (my $i = @$history - 1; 0 <= $i; --$i) {
+ my $item = $history->[$i];
+ next if Hash::Util::FieldHash::id($entry) != Hash::Util::FieldHash::id($item);
+ push @removed, splice @{$self->{history}}, $i, 1;
+ }
+ return @removed;
+}
+
+
+sub current_entry {
+ my $self = shift;
+ my $parent = $self->group;
+
+ if ($parent) {
+ my $id = $self->uuid;
+ my $entry = first { $id eq $_->uuid } @{$parent->entries};
+ return $entry if $entry;
+ }
+
+ return $self;
+}
+
+
+sub is_current {
+ my $self = shift;
+ my $current = $self->current_entry;
+ return Hash::Util::FieldHash::id($self) == Hash::Util::FieldHash::id($current);
+}
+
+
+sub is_historical { !$_[0]->is_current }
+
+
+sub remove {
+ my $self = shift;
+ my $current = $self->current_entry;
+ return $self if $current->remove_historical_entry($self);
+ $self->SUPER::remove(@_);
+}
+
+##############################################################################
+
+
+sub searching_enabled {
+ my $self = shift;
+ my $parent = $self->group;
+ return $parent->effective_enable_searching if $parent;
+ return true;
+}
+
+sub auto_type_enabled {
+ my $self = shift;
+ $self->auto_type->{enabled} = to_bool(shift) if @_;
+ $self->auto_type->{enabled} //= true;
+ return false if !$self->auto_type->{enabled};
+ return true if !$self->is_connected;
+ my $parent = $self->group;
+ return $parent->effective_enable_auto_type if $parent;
+ return true;
+}
+
+##############################################################################
+
+sub _signal {
+ my $self = shift;
+ my $type = shift;
+ return $self->SUPER::_signal("entry.$type", @_);
+}
+
+sub _commit {
+ my $self = shift;
+ my $orig = shift;
+ $self->add_historical_entry($orig);
+ my $time = gmtime;
+ $self->last_modification_time($time);
+ $self->last_access_time($time);
+}
+
+sub label { shift->expand_title(@_) }
+
+### Name of the parent attribute expected to contain the object
+sub _parent_container { 'entries' }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Entry - A KDBX database entry
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+An entry in a KDBX database is a record that can contains strings (also called "fields") and binaries (also
+called "files" or "attachments"). Every string and binary has a key or name. There is a default set of strings
+that every entry has:
+
+=over 4
+
+=item *
+
+B<Title>
+
+=item *
+
+B<UserName>
+
+=item *
+
+B<Password>
+
+=item *
+
+B<URL>
+
+=item *
+
+B<Notes>
+
+=back
+
+Beyond this, you can store any number of other strings and any number of binaries that you can use for
+whatever purpose you want.
+
+There is also some metadata associated with an entry. Each entry in a database is identified uniquely by
+a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at
+the attributes to see what's available.
+
+A B<File::KDBX::Entry> is a subclass of L<File::KDBX::Object>.
+
+=head2 Placeholders
+
+Entry string and auto-type key sequences can have placeholders or template tags that can be replaced by other
+values. Placeholders can appear like C<{PLACEHOLDER}>. For example, a B<URL> string might have a value of
+C<http://example.com?user={USERNAME}>. C<{USERNAME}> is a placeholder for the value of the B<UserName> string
+of the same entry. If the B<UserName> string had a value of "batman", the B<URL> string would expand to
+C<http://example.com?user=batman>.
+
+Some placeholders take an argument, where the argument follows the tag after a colon but before the closing
+brace, like C<{PLACEHOLDER:ARGUMENT}>.
+
+Placeholders are documented in the L<KeePass Help Center|https://keepass.info/help/base/placeholders.html>.
+This software supports many (but not all) of the placeholders documented there.
+
+=head3 Entry Placeholders
+
+=over 4
+
+=item *
+
+☑ C<{TITLE}> - B<Title> string
+
+=item *
+
+☑ C<{USERNAME}> - B<UserName> string
+
+=item *
+
+☑ C<{PASSWORD}> - B<Password> string
+
+=item *
+
+☑ C<{NOTES}> - B<Notes> string
+
+=item *
+
+☑ C<{URL}> - B<URL> string
+
+=item *
+
+☑ C<{URL:SCM}> / C<{URL:SCHEME}>
+
+=item *
+
+☑ C<{URL:USERINFO}>
+
+=item *
+
+☑ C<{URL:USERNAME}>
+
+=item *
+
+☑ C<{URL:PASSWORD}>
+
+=item *
+
+☑ C<{URL:HOST}>
+
+=item *
+
+☑ C<{URL:PORT}>
+
+=item *
+
+☑ C<{URL:PATH}>
+
+=item *
+
+☑ C<{URL:QUERY}>
+
+=item *
+
+☑ C<{URL:FRAGMENT}> / C<{URL:HASH}>
+
+=item *
+
+☑ C<{URL:RMVSCM}> / C<{URL:WITHOUTSCHEME}>
+
+=item *
+
+☑ C<{S:Name}> - Custom string where C<Name> is the name or key of the string
+
+=item *
+
+☑ C<{UUID}> - Identifier (32 hexidecimal characters)
+
+=item *
+
+☑ C<{HMACOTP}> - Generate an HMAC-based one-time password (its counter B<will> be incremented)
+
+=item *
+
+☑ C<{TIMEOTP}> - Generate a time-based one-time password
+
+=item *
+
+☑ C<{GROUP_NOTES}> - Notes of the parent group
+
+=item *
+
+☑ C<{GROUP_PATH}> - Full path of the parent group
+
+=item *
+
+☑ C<{GROUP}> - Name of the parent group
+
+=back
+
+=head3 Field References
+
+=over 4
+
+=item *
+
+☑ C<{REF:Wanted@SearchIn:Text}> - See L<File::KDBX/resolve_reference>
+
+=back
+
+=head3 File path Placeholders
+
+=over 4
+
+=item *
+
+☑ C<{APPDIR}> - Program directory path
+
+=item *
+
+☑ C<{FIREFOX}> - Path to the Firefox browser executable
+
+=item *
+
+☑ C<{GOOGLECHROME}> - Path to the Chrome browser executable
+
+=item *
+
+☑ C<{INTERNETEXPLORER}> - Path to the Firefox browser executable
+
+=item *
+
+☑ C<{OPERA}> - Path to the Opera browser executable
+
+=item *
+
+☑ C<{SAFARI}> - Path to the Safari browser executable
+
+=item *
+
+☒ C<{DB_PATH}> - Full file path of the database
+
+=item *
+
+☒ C<{DB_DIR}> - Directory path of the database
+
+=item *
+
+☒ C<{DB_NAME}> - File name (including extension) of the database
+
+=item *
+
+☒ C<{DB_BASENAME}> - File name (excluding extension) of the database
+
+=item *
+
+☒ C<{DB_EXT}> - File name extension
+
+=item *
+
+☑ C<{ENV_DIRSEP}> - Directory separator
+
+=item *
+
+☑ C<{ENV_PROGRAMFILES_X86}> - One of C<%ProgramFiles(x86)%> or C<%ProgramFiles%>
+
+=back
+
+=head3 Date and Time Placeholders
+
+=over 4
+
+=item *
+
+☑ C<{DT_SIMPLE}> - Current local date and time as a sortable string
+
+=item *
+
+☑ C<{DT_YEAR}> - Year component of the current local date
+
+=item *
+
+☑ C<{DT_MONTH}> - Month component of the current local date
+
+=item *
+
+☑ C<{DT_DAY}> - Day component of the current local date
+
+=item *
+
+☑ C<{DT_HOUR}> - Hour component of the current local time
+
+=item *
+
+☑ C<{DT_MINUTE}> - Minute component of the current local time
+
+=item *
+
+☑ C<{DT_SECOND}> - Second component of the current local time
+
+=item *
+
+☑ C<{DT_UTC_SIMPLE}> - Current UTC date and time as a sortable string
+
+=item *
+
+☑ C<{DT_UTC_YEAR}> - Year component of the current UTC date
+
+=item *
+
+☑ C<{DT_UTC_MONTH}> - Month component of the current UTC date
+
+=item *
+
+☑ C<{DT_UTC_DAY}> - Day component of the current UTC date
+
+=item *
+
+☑ C<{DT_UTC_HOUR}> - Hour component of the current UTC time
+
+=item *
+
+☑ C<{DT_UTC_MINUTE}> Minute Year component of the current UTC time
+
+=item *
+
+☑ C<{DT_UTC_SECOND}> - Second component of the current UTC time
+
+=back
+
+If the current date and time is <2012-07-25 17:05:34>, the "simple" form would be C<20120725170534>.
+
+=head3 Special Key Placeholders
+
+Certain placeholders for use in auto-type key sequences are not supported for replacement, but they will
+remain as-is so that an auto-type engine (not included) can parse and replace them with the appropriate
+virtual key presses. For completeness, here is the list that the KeePass program claims to support:
+
+C<{TAB}>, C<{ENTER}>, C<{UP}>, C<{DOWN}>, C<{LEFT}>, C<{RIGHT}>, C<{HOME}>, C<{END}>, C<{PGUP}>, C<{PGDN}>,
+C<{INSERT}>, C<{DELETE}>, C<{SPACE}>
+
+C<{BACKSPACE}>, C<{BREAK}>, C<{CAPSLOCK}>, C<{ESC}>, C<{WIN}>, C<{LWIN}>, C<{RWIN}>, C<{APPS}>, C<{HELP}>,
+C<{NUMLOCK}>, C<{PRTSC}>, C<{SCROLLLOCK}>
+
+C<{F1}>, C<{F2}>, C<{F3}>, C<{F4}>, C<{F5}>, C<{F6}>, C<{F7}>, C<{F8}>, C<{F9}>, C<{F10}>, C<{F11}>, C<{F12}>,
+C<{F13}>, C<{F14}>, C<{F15}>, C<{F16}>
+
+C<{ADD}>, C<{SUBTRACT}>, C<{MULTIPLY}>, C<{DIVIDE}>, C<{NUMPAD0}>, C<{NUMPAD1}>, C<{NUMPAD2}>, C<{NUMPAD3}>,
+C<{NUMPAD4}>, C<{NUMPAD5}>, C<{NUMPAD6}>, C<{NUMPAD7}>, C<{NUMPAD8}>, C<{NUMPAD9}>
+
+=head3 Miscellaneous Placeholders
+
+=over 4
+
+=item *
+
+☒ C<{BASE}>
+
+=item *
+
+☒ C<{BASE:SCM}> / C<{BASE:SCHEME}>
+
+=item *
+
+☒ C<{BASE:USERINFO}>
+
+=item *
+
+☒ C<{BASE:USERNAME}>
+
+=item *
+
+☒ C<{BASE:PASSWORD}>
+
+=item *
+
+☒ C<{BASE:HOST}>
+
+=item *
+
+☒ C<{BASE:PORT}>
+
+=item *
+
+☒ C<{BASE:PATH}>
+
+=item *
+
+☒ C<{BASE:QUERY}>
+
+=item *
+
+☒ C<{BASE:FRAGMENT}> / C<{BASE:HASH}>
+
+=item *
+
+☒ C<{BASE:RMVSCM}> / C<{BASE:WITHOUTSCHEME}>
+
+=item *
+
+☒ C<{CLIPBOARD-SET:/Text/}>
+
+=item *
+
+☒ C<{CLIPBOARD}>
+
+=item *
+
+☒ C<{CMD:/CommandLine/Options/}>
+
+=item *
+
+☑ C<{C:Comment}> - Comments are simply replaced by nothing
+
+=item *
+
+☑ C<{ENV:}> and C<%ENV%> - Environment variables
+
+=item *
+
+☒ C<{GROUP_SEL_NOTES}>
+
+=item *
+
+☒ C<{GROUP_SEL_PATH}>
+
+=item *
+
+☒ C<{GROUP_SEL}>
+
+=item *
+
+☒ C<{NEWPASSWORD}>
+
+=item *
+
+☒ C<{NEWPASSWORD:/Profile/}>
+
+=item *
+
+☒ C<{PASSWORD_ENC}>
+
+=item *
+
+☒ C<{PICKCHARS}>
+
+=item *
+
+☒ C<{PICKCHARS:Field:Options}>
+
+=item *
+
+☒ C<{PICKFIELD}>
+
+=item *
+
+☒ C<{T-CONV:/Text/Type/}>
+
+=item *
+
+☒ C<{T-REPLACE-RX:/Text/Type/Replace/}>
+
+=back
+
+Some of these that remain unimplemented, such as C<{CLIPBOARD}>, cannot be implemented portably. Some of these
+I haven't implemented (yet) just because they don't seem very useful. You can create your own placeholder to
+augment the list of default supported placeholders or to replace a built-in placeholder handler. To create
+a placeholder, just set it in the C<%File::KDBX::PLACEHOLDERS> hash. For example:
+
+ $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER'} = sub {
+ my ($entry) = @_;
+ ...;
+ };
+
+If the placeholder is expanded in the context of an entry, C<$entry> is the B<File::KDBX::Entry> object in
+context. Otherwise it is C<undef>. An entry is in context if, for example, the placeholder is in an entry's
+strings or auto-complete key sequences.
+
+ $File::KDBX::PLACEHOLDERS{'MY_PLACEHOLDER:'} = sub {
+ my ($entry, $arg) = @_; # ^ Notice the colon here
+ ...;
+ };
+
+If the name of the placeholder ends in a colon, then it is expected to receive an argument. During expansion,
+everything after the colon and before the end of the placeholder is passed to your placeholder handler
+subroutine. So if the placeholder is C<{MY_PLACEHOLDER:whatever}>, C<$arg> will have the value B<whatever>.
+
+An argument is required for placeholders than take one. I.e. The placeholder handler won't be called if there
+is no argument. If you want a placeholder to support an optional argument, you'll need to set the placeholder
+both with and without a colon (or they could be different subroutines):
+
+ $File::KDBX::PLACEHOLDERS{'RAND'} = $File::KDBX::PLACEHOLDERS{'RAND:'} = sub {
+ (undef, my $arg) = @_;
+ return defined $arg ? rand($arg) : rand;
+ };
+
+You can also remove placeholder handlers. If you want to disable placeholder expansion entirely, just delete
+all the handlers:
+
+ %File::KDBX::PLACEHOLDERS = ();
+
+=head2 One-time Passwords
+
+An entry can be configured to generate one-time passwords, both HOTP (HMAC-based) and TOTP (time-based). The
+configuration storage isn't completely standardized, but this module supports two predominant configuration
+styles:
+
+=over 4
+
+=item *
+
+L<KeePass 2|https://keepass.info/help/base/placeholders.html#otp>
+
+=item *
+
+KeePassXC
+
+=back
+
+B<NOTE:> To use this feature, you must install the suggested dependency:
+
+=over 4
+
+=item *
+
+L<Pass::OTP>
+
+=back
+
+To configure TOTP in the KeePassXC style, there is only one string to set: C<otp>. The value should be any
+valid otpauth URI. When generating an OTP, all of the relevant OTP properties are parsed from the URI.
+
+To configure TOTP in the KeePass 2 style, set the following strings:
+
+=over 4
+
+=item *
+
+C<TimeOtp-Algorithm> - Cryptographic algorithm, one of C<HMAC-SHA-1> (default), C<HMAC-SHA-256> and C<HMAC-SHA-512>
+
+=item *
+
+C<TimeOtp-Length> - Number of digits each one-time password is (default: 6, maximum: 8)
+
+=item *
+
+C<TimeOtp-Period> - Time-step size in seconds (default: 30)
+
+=item *
+
+C<TimeOtp-Secret> - Text string secret, OR
+
+=item *
+
+C<TimeOtp-Secret-Hex> - Hexidecimal-encoded secret, OR
+
+=item *
+
+C<TimeOtp-Secret-Base32> - Base32-encoded secret (most common), OR
+
+=item *
+
+C<TimeOtp-Secret-Base64> - Base64-encoded secret
+
+=back
+
+To configure HOTP in the KeePass 2 style, set the following strings:
+
+=over 4
+
+=item *
+
+C<HmacOtp-Counter> - Counting value in decimal, starts on C<0> by default and increments when L</hmac_otp> is called
+
+=item *
+
+C<HmacOtp-Secret> - Text string secret, OR
+
+=item *
+
+C<HmacOtp-Secret-Hex> - Hexidecimal-encoded secret, OR
+
+=item *
+
+C<HmacOtp-Secret-Base32> - Base32-encoded secret (most common), OR
+
+=item *
+
+C<HmacOtp-Secret-Base64> - Base64-encoded secret
+
+=back
+
+B<NOTE:> The multiple "Secret" strings are simply a way to store a secret in different formats. Only one of
+these should actually be set or an error will be thrown.
+
+Here's a basic example:
+
+ $entry->string(otp => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer');
+ # OR
+ $entry->string('TimeOtp-Secret-Base32' => 'NBSWY3DP');
+
+ my $otp = $entry->time_otp;
+
+=head1 ATTRIBUTES
+
+=head2 uuid
+
+128-bit UUID identifying the entry within the database.
+
+=head2 icon_id
+
+Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values.
+
+=head2 custom_icon_uuid
+
+128-bit UUID identifying a custom icon within the database.
+
+=head2 foreground_color
+
+Text color represented as a string of the form C<#000000>.
+
+=head2 background_color
+
+Background color represented as a string of the form C<#FFFFFF>.
+
+=head2 override_url
+
+TODO
+
+=head2 tags
+
+Text string with arbitrary tags which can be used to build a taxonomy.
+
+=head2 auto_type_enabled
+
+Whether or not the entry is eligible to be matched for auto-typing.
+
+=head2 auto_type_obfuscation
+
+Whether or not to use some kind of obfuscation when sending keystroke sequences to applications.
+
+=head2 auto_type_default_sequence
+
+The default auto-type keystroke sequence.
+
+=head2 auto_type_associations
+
+An array of window title / keystroke sequence associations.
+
+ {
+ window => 'Example Window Title',
+ keystroke_sequence => '{USERNAME}{TAB}{PASSWORD}{ENTER}',
+ }
+
+Keystroke sequences can have </Placeholders>, most commonly C<{USERNAME}> and C<{PASSWORD}>.
+
+=head2 previous_parent_group
+
+128-bit UUID identifying a group within the database.
+
+=head2 quality_check
+
+Boolean indicating whether the entry password should be tested for weakness and show up in reports.
+
+=head2 strings
+
+Hash with entry strings, including the standard strings as well as any custom ones.
+
+ {
+ # Every entry has these five strings:
+ Title => { value => 'Example Entry' },
+ UserName => { value => 'jdoe' },
+ Password => { value => 's3cr3t', protect => true },
+ URL => { value => 'https://example.com' }
+ Notes => { value => '' },
+ # May also have custom strings:
+ MySystem => { value => 'The mainframe' },
+ }
+
+There are methods available to provide more convenient access to strings, including L</string>,
+L</string_value>, L</expand_string_value> and L</string_peek>.
+
+=head2 binaries
+
+Files or attachments. Binaries are similar to strings except they have a value of bytes instead of test
+characters.
+
+ {
+ 'myfile.txt' => {
+ value => '...',
+ },
+ 'mysecrets.txt' => {
+ value => '...',
+ protect => true,
+ },
+ }
+
+There are methods available to provide more convenient access to binaries, including L</binary> and
+L</binary_value>.
+
+=head2 custom_data
+
+A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather
+than by end users (who typically work with the strings and binaries).
+
+=head2 history
+
+Array of historical entries. Historical entries are prior versions of the same entry so they all share the
+same UUID with the current entry.
+
+=head2 last_modification_time
+
+Date and time when the entry was last modified.
+
+=head2 creation_time
+
+Date and time when the entry was created.
+
+=head2 last_access_time
+
+Date and time when the entry was last accessed.
+
+=head2 expiry_time
+
+Date and time when the entry expired or will expire.
+
+=head2 expires
+
+Boolean value indicating whether or not an entry is expired.
+
+=head2 usage_count
+
+The number of times an entry has been used, which typically means how many times the B<Password> string has
+been accessed.
+
+=head2 location_changed
+
+Date and time when the entry was last moved to a different parent group.
+
+=head2 notes
+
+Alias for the B<Notes> string value.
+
+=head2 password
+
+Alias for the B<Password> string value.
+
+=head2 title
+
+Alias for the B<Title> string value.
+
+=head2 url
+
+Alias for the B<URL> string value.
+
+=head2 username
+
+Aliases for the B<UserName> string value.
+
+=head2 expand_notes
+
+Shortcut equivalent to C<< ->expand_string_value('Notes') >>.
+
+=head2 expand_password
+
+Shortcut equivalent to C<< ->expand_string_value('Password') >>.
+
+=head2 expand_title
+
+Shortcut equivalent to C<< ->expand_string_value('Title') >>.
+
+=head2 expand_url
+
+Shortcut equivalent to C<< ->expand_string_value('URL') >>.
+
+=head2 expand_username
+
+Shortcut equivalent to C<< ->expand_string_value('UserName') >>.
+
+=head1 METHODS
+
+=head2 string
+
+ \%string = $entry->string($string_key);
+
+ $entry->string($string_key, \%string);
+ $entry->string($string_key, %attributes);
+ $entry->string($string_key, $value); # same as: value => $value
+
+Get or set a string. Every string has a unique (to the entry) key and flags and so are returned as a hash
+structure. For example:
+
+ $string = {
+ value => 'Password',
+ protect => true, # optional
+ };
+
+Every string should have a value (but might be C<undef> due to memory protection) and these optional flags
+which might exist:
+
+=over 4
+
+=item *
+
+C<protect> - Whether or not the string value should be memory-protected.
+
+=back
+
+=head2 string_value
+
+ $string = $entry->string_value($string_key);
+
+Access a string value directly. The arguments are the same as for L</string>. Returns C<undef> if the string
+is not set or is currently memory-protected. This is just a shortcut for:
+
+ my $string = do {
+ my $s = $entry->string(...);
+ defined $s ? $s->{value} : undef;
+ };
+
+=head2 expand_string_value
+
+ $string = $entry->expand_string_value;
+
+Same as L</string_value> but will substitute placeholders and resolve field references. Any placeholders that
+do not expand to values are left as-is.
+
+See L</Placeholders>.
+
+Some placeholders (notably field references) require the entry be connected to a database and will throw an
+error if it is not.
+
+=head2 other_strings
+
+ $other = $entry->other_strings;
+ $other = $entry->other_strings($delimiter);
+
+Get a concatenation of all non-standard string values. The default delimiter is a newline. This is is useful
+for executing queries to search for entities based on the contents of these other strings (if any).
+
+=head2 string_peek
+
+ $string = $entry->string_peek($string_key);
+
+Same as L</string_value> but can also retrieve the value from protected-memory if the value is currently
+protected.
+
+=head2 add_auto_type_association
+
+ $entry->add_auto_type_association(\%association);
+
+Add a new auto-type association to an entry.
+
+=head2 expand_keystroke_sequence
+
+ $string = $entry->expand_keystroke_sequence($keystroke_sequence);
+ $string = $entry->expand_keystroke_sequence(\%association);
+ $string = $entry->expand_keystroke_sequence; # use default auto-type sequence
+
+Get a keystroke sequence after placeholder expansion.
+
+=head2 binary
+
+ \%binary = $entry->binary($binary_key);
+
+ $entry->binary($binary_key, \%binary);
+ $entry->binary($binary_key, %attributes);
+ $entry->binary($binary_key, $value); # same as: value => $value
+
+Get or set a binary. Every binary has a unique (to the entry) key and flags and so are returned as a hash
+structure. For example:
+
+ $binary = {
+ value => '...',
+ protect => true, # optional
+ };
+
+Every binary should have a value (but might be C<undef> due to memory protection) and these optional flags
+which might exist:
+
+=over 4
+
+=item *
+
+C<protect> - Whether or not the binary value should be memory-protected.
+
+=back
+
+=head2 binary_value
+
+ $binary = $entry->binary_value($binary_key);
+
+Access a binary value directly. The arguments are the same as for L</binary>. Returns C<undef> if the binary
+is not set or is currently memory-protected. This is just a shortcut for:
+
+ my $binary = do {
+ my $b = $entry->binary(...);
+ defined $b ? $b->{value} : undef;
+ };
+
+=head2 hmac_otp
+
+ $otp = $entry->hmac_otp(%options);
+
+Generate an HMAC-based one-time password, or C<undef> if HOTP is not configured for the entry. The entry's
+strings generally must first be unprotected, just like when accessing the password. Valid options are:
+
+=over 4
+
+=item *
+
+C<counter> - Specify the counter value
+
+=back
+
+To configure HOTP, see L</"One-time Passwords">.
+
+=head2 time_otp
+
+ $otp = $entry->time_otp(%options);
+
+Generate a time-based one-time password, or C<undef> if TOTP is not configured for the entry. The entry's
+strings generally must first be unprotected, just like when accessing the password. Valid options are:
+
+=over 4
+
+=item *
+
+C<now> - Specify the value for determining the time-step counter
+
+=back
+
+To configure TOTP, see L</"One-time Passwords">.
+
+=head2 hmac_otp_uri
+
+=head2 time_otp_uri
+
+ $uri_string = $entry->hmac_otp_uri;
+ $uri_string = $entry->time_otp_uri;
+
+Get a HOTP or TOTP otpauth URI for the entry, if available.
+
+To configure OTP, see L</"One-time Passwords">.
+
+=head2 size
+
+ $size = $entry->size;
+
+Get the size (in bytes) of an entry.
+
+B<NOTE:> This is not an exact figure because there is no canonical serialization of an entry. This size should
+only be used as a rough estimate for comparison with other entries or to impose data size limitations.
+
+=head2 history_size
+
+ $size = $entry->history_size;
+
+Get the size (in bytes) of all historical entries combined.
+
+=head2 prune_history
+
+ @removed_historical_entries = $entry->prune_history(%options);
+
+Remove just as many older historical entries as necessary to get under the database limits. The limits are
+taken from the connected database (if any) or can be overridden with C<%options>:
+
+=over 4
+
+=item *
+
+C<max_items> - Maximum number of historical entries to keep (default: 10, no limit: -1)
+
+=item *
+
+C<max_size> - Maximum total size (in bytes) of historical entries to keep (default: 6 MiB, no limit: -1)
+
+=item *
+
+C<max_age> - Maximum age (in days) of historical entries to keep (default: 365, no limit: -1)
+
+=back
+
+=head2 add_historical_entry
+
+ $entry->add_historical_entry($entry);
+
+Add an entry to the history.
+
+=head2 remove_historical_entry
+
+ $entry->remove_historical_entry($historical_entry);
+
+Remove an entry from the history.
+
+=head2 current_entry
+
+ $current_entry = $entry->current_entry;
+
+Get an entry's current entry. If the entry itself is current (not historical), itself is returned.
+
+=head2 is_current
+
+ $bool = $entry->is_current;
+
+Get whether or not an entry is considered current (i.e. not historical). An entry is current if it is directly
+in the parent group's entry list.
+
+=head2 is_historical
+
+ $bool = $entry->is_historical;
+
+Get whether or not an entry is considered historical (i.e. not current).
+
+This is just the inverse of L</is_current>.
+
+=head2 remove
+
+ $entry = $entry->remove;
+
+Remove an entry from its parent group. If the entry is historical, remove it from the history of the current
+entry. If the entry is current, this behaves the same as L<File::KDBX::Object/remove>.
+
+=head2 searching_enabled
+
+ $bool = $entry->searching_enabled;
+
+Get whether or not an entry may show up in search results. This is determine from the entry's parent group's
+L<File::KDBX::Group/effective_enable_searching> value.
+
+Throws if entry has no parent group or if the entry is not connected to a database.
+
+=for Pod::Coverage auto_type times
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Error;
+# ABSTRACT: Represents something bad that happened
+
+use warnings;
+use strict;
+
+use Exporter qw(import);
+use Scalar::Util qw(blessed looks_like_number);
+use namespace::clean -except => 'import';
+
+our $VERSION = '0.800'; # VERSION
+
+our @EXPORT = qw(alert error throw);
+
+my $WARNINGS_CATEGORY;
+BEGIN {
+ $WARNINGS_CATEGORY = 'File::KDBX';
+ if (warnings->can('register_categories')) {
+ warnings::register_categories($WARNINGS_CATEGORY);
+ }
+ else {
+ eval qq{package $WARNINGS_CATEGORY; use warnings::register; 1}; ## no critic ProhibitStringyEval
+ }
+
+ my $debug = $ENV{DEBUG};
+ $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
+ *_DEBUG = $debug == 1 ? sub() { 1 } :
+ $debug == 2 ? sub() { 2 } :
+ $debug == 3 ? sub() { 3 } :
+ $debug == 4 ? sub() { 4 } : sub() { 0 };
+}
+
+use overload '""' => 'to_string', cmp => '_cmp';
+
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 0 ? @_ : (_error => shift, @_);
+
+ my $error = delete $args{_error};
+ my $e = $error;
+ $e =~ s/ at \H+ line \d+.*//g;
+
+ my $self = bless {
+ details => \%args,
+ error => $e // 'Something happened',
+ errno => $!,
+ previous => $@,
+ trace => do {
+ require Carp;
+ local $Carp::CarpInternal{''.__PACKAGE__} = 1;
+ my $mess = $error =~ /at \H+ line \d+/ ? $error : Carp::longmess($error);
+ [map { /^\h*(.*?)\.?$/ ? $1 : $_ } split(/\n/, $mess)];
+ },
+ }, $class;
+ chomp $self->{error};
+ return $self;
+}
+
+
+sub error {
+ my $class = @_ && $_[0] eq __PACKAGE__ ? shift : undef;
+ my $self = (blessed($_[0]) && $_[0]->isa('File::KDBX::Error'))
+ ? shift
+ : $class
+ ? $class->new(@_)
+ : __PACKAGE__->new(@_);
+ return $self;
+}
+
+
+sub details {
+ my $self = shift;
+ my %args = @_;
+ my $details = $self->{details} //= {};
+ @$details{keys %args} = values %args;
+ return $details;
+}
+
+
+
+sub errno { $_[0]->{errno} }
+sub previous { $_[0]->{previous} }
+sub trace { $_[0]->{trace} // [] }
+sub type { $_[0]->details->{type} // '' }
+
+
+sub _cmp { "$_[0]" cmp "$_[1]" }
+
+sub to_string {
+ my $self = shift;
+ my $msg = "$self->{trace}[0]";
+ $msg .= '.' if $msg !~ /[\.\!\?]$/;
+ if (2 <= _DEBUG) {
+ require Data::Dumper;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Trailingcomma = 1;
+ local $Data::Dumper::Useqq = 1;
+ $msg .= "\n" . Data::Dumper::Dumper $self;
+ }
+ $msg .= "\n" if $msg !~ /\n$/;
+ return $msg;
+}
+
+
+sub throw {
+ my $self = error(@_);
+ die $self;
+}
+
+
+sub warn {
+ return if !($File::KDBX::WARNINGS // 1);
+
+ my $self = error(@_);
+
+ # Use die and warn directly instead of warnings::warnif because the latter only provides the stringified
+ # error to the warning signal handler (perl 5.34). Maybe that's a warnings.pm bug?
+
+ if (my $fatal = warnings->can('fatal_enabled_at_level')) {
+ my $blame = _find_blame_frame();
+ die $self if $fatal->($WARNINGS_CATEGORY, $blame);
+ }
+
+ if (my $enabled = warnings->can('enabled_at_level')) {
+ my $blame = _find_blame_frame();
+ warn $self if $enabled->($WARNINGS_CATEGORY, $blame);
+ }
+ elsif ($enabled = warnings->can('enabled')) {
+ warn $self if $enabled->($WARNINGS_CATEGORY);
+ }
+ else {
+ warn $self;
+ }
+ return $self;
+}
+
+
+sub alert { goto &warn }
+
+sub _find_blame_frame {
+ my $frame = 1;
+ while (1) {
+ my ($package) = caller($frame);
+ last if !$package;
+ return $frame - 1 if $package !~ /^\Q$WARNINGS_CATEGORY\E/;
+ $frame++;
+ }
+ return 0;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Error - Represents something bad that happened
+
+=head1 VERSION
+
+version 0.800
+
+=head1 ATTRIBUTES
+
+=head2 details
+
+ \%details = $error->details;
+
+Get the error details.
+
+=head2 errno
+
+Get the value of C<errno> when the exception was created.
+
+=head2 previous
+
+Get the value of C<$@> (i.e. latest exception) at the time the exception was created.
+
+=head2 trace
+
+Get a stack trace indicating where in the code the exception was created.
+
+=head2 type
+
+Get the exception type, if any.
+
+=head1 METHODS
+
+=head2 new
+
+ $error = File::KDBX::Error->new($message, %details);
+
+Construct a new error.
+
+=head2 error
+
+ $error = error($error);
+ $error = error($message, %details);
+ $error = File::KDBX::Error->error($error);
+ $error = File::KDBX::Error->error($message, %details);
+
+Wrap a thing to make it an error object. If the thing is already an error, it gets returned. Otherwise what is
+passed will be forwarded to L</new> to create a new error object.
+
+This can be convenient for error handling when you're not sure what the exception is but you want to treat it
+as a B<File::KDBX::Error>. Example:
+
+ eval { ... };
+ if (my $error = error(@_)) {
+ if ($error->type eq 'key.missing') {
+ handle_missing_key($error);
+ }
+ else {
+ handle_other_error($error);
+ }
+ }
+
+=head2 to_string
+
+ $message = $error->to_string;
+ $message = "$error";
+
+Stringify an error.
+
+This does not contain a stack trace, but you can set the C<DEBUG> environment variable to at least 2 to
+stringify the whole error object.
+
+=head2 throw
+
+ File::KDBX::Error::throw($message, %details);
+ $error->throw;
+
+Throw an error.
+
+=head2 warn
+
+ File::KDBX::Error::warn($message, %details);
+ $error->warn;
+
+Log a warning.
+
+=head2 alert
+
+ alert $error;
+
+Importable alias for L</warn>.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Group;
+# ABSTRACT: A KDBX database group
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:bool :icon :iteration);
+use File::KDBX::Error;
+use File::KDBX::Iterator;
+use File::KDBX::Util qw(:assert :class :coercion generate_uuid);
+use Hash::Util::FieldHash;
+use List::Util qw(any sum0);
+use Ref::Util qw(is_coderef is_ref);
+use Scalar::Util qw(blessed);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+extends 'File::KDBX::Object';
+
+our $VERSION = '0.800'; # VERSION
+
+
+# has uuid => sub { generate_uuid(printable => 1) };
+has name => '', coerce => \&to_string;
+has notes => '', coerce => \&to_string;
+has tags => '', coerce => \&to_string;
+has icon_id => ICON_FOLDER, coerce => \&to_icon_constant;
+has custom_icon_uuid => undef, coerce => \&to_uuid;
+has is_expanded => false, coerce => \&to_bool;
+has default_auto_type_sequence => '', coerce => \&to_string;
+has enable_auto_type => undef, coerce => \&to_tristate;
+has enable_searching => undef, coerce => \&to_tristate;
+has last_top_visible_entry => undef, coerce => \&to_uuid;
+# has custom_data => {};
+has previous_parent_group => undef, coerce => \&to_uuid;
+# has entries => [];
+# has groups => [];
+has times => {};
+
+has last_modification_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has creation_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has last_access_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has expiry_time => sub { gmtime }, store => 'times', coerce => \&to_time;
+has expires => false, store => 'times', coerce => \&to_bool;
+has usage_count => 0, store => 'times', coerce => \&to_number;
+has location_changed => sub { gmtime }, store => 'times', coerce => \&to_time;
+
+my @ATTRS = qw(uuid custom_data entries groups);
+sub _set_nonlazy_attributes {
+ my $self = shift;
+ $self->$_ for @ATTRS, list_attributes(ref $self);
+}
+
+sub uuid {
+ my $self = shift;
+ if (@_ || !defined $self->{uuid}) {
+ my %args = @_ % 2 == 1 ? (uuid => shift, @_) : @_;
+ my $old_uuid = $self->{uuid};
+ my $uuid = $self->{uuid} = delete $args{uuid} // generate_uuid;
+ $self->_signal('uuid.changed', $uuid, $old_uuid) if defined $old_uuid;
+ }
+ $self->{uuid};
+}
+
+##############################################################################
+
+
+sub entries {
+ my $self = shift;
+ my $entries = $self->{entries} //= [];
+ if (@$entries && !blessed($entries->[0])) {
+ @$entries = map { $self->_wrap_entry($_, $self->kdbx) } @$entries;
+ }
+ assert { !any { !blessed $_ } @$entries };
+ return $entries;
+}
+
+
+sub entries_deeply {
+ my $self = shift;
+ my %args = @_;
+
+ my $searching = delete $args{searching};
+ my $auto_type = delete $args{auto_type};
+ my $history = delete $args{history};
+
+ my $groups = $self->groups_deeply(%args);
+ my @entries;
+
+ return File::KDBX::Iterator->new(sub {
+ if (!@entries) {
+ while (my $group = $groups->next) {
+ next if $searching && !$group->effective_enable_searching;
+ next if $auto_type && !$group->effective_enable_auto_type;
+ @entries = @{$group->entries};
+ @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
+ @entries = map { ($_, @{$_->history}) } @entries if $history;
+ last if @entries;
+ }
+ }
+ shift @entries;
+ });
+}
+
+
+sub add_entry {
+ my $self = shift;
+ my $entry = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
+
+ $entry = $self->_wrap_entry($entry // [%args]);
+ $entry->uuid;
+ $entry->kdbx($kdbx) if $kdbx;
+
+ push @{$self->{entries} ||= []}, $entry->remove;
+ return $entry->_set_group($self)->_signal('added', $self);
+}
+
+
+sub remove_entry {
+ my $self = shift;
+ my $uuid = is_ref($_[0]) ? $self->_wrap_entry(shift)->uuid : shift;
+ my %args = @_;
+ my $objects = $self->{entries};
+ for (my $i = 0; $i < @$objects; ++$i) {
+ my $object = $objects->[$i];
+ next if $uuid ne $object->uuid;
+ $object->_set_group(undef);
+ $object->_signal('removed') if $args{signal} // 1;
+ return splice @$objects, $i, 1;
+ }
+}
+
+##############################################################################
+
+
+sub groups {
+ my $self = shift;
+ my $groups = $self->{groups} //= [];
+ if (@$groups && !blessed($groups->[0])) {
+ @$groups = map { $self->_wrap_group($_, $self->kdbx) } @$groups;
+ }
+ assert { !any { !blessed $_ } @$groups };
+ return $groups;
+}
+
+
+sub groups_deeply {
+ my $self = shift;
+ my %args = @_;
+
+ my @groups = ($args{inclusive} // 1) ? $self : @{$self->groups};
+ my $algo = lc($args{algorithm} || 'ids');
+
+ if ($algo eq ITERATION_DFS) {
+ my %visited;
+ return File::KDBX::Iterator->new(sub {
+ my $next = shift @groups or return;
+ if (!$visited{Hash::Util::FieldHash::id($next)}++) {
+ while (my @children = @{$next->groups}) {
+ unshift @groups, @children, $next;
+ $next = shift @groups;
+ $visited{Hash::Util::FieldHash::id($next)}++;
+ }
+ }
+ $next;
+ });
+ }
+ elsif ($algo eq ITERATION_BFS) {
+ return File::KDBX::Iterator->new(sub {
+ my $next = shift @groups or return;
+ push @groups, @{$next->groups};
+ $next;
+ });
+ }
+ return File::KDBX::Iterator->new(sub {
+ my $next = shift @groups or return;
+ unshift @groups, @{$next->groups};
+ $next;
+ });
+}
+
+sub _kpx_groups { shift->groups(@_) }
+
+
+sub add_group {
+ my $self = shift;
+ my $group = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+
+ my $kdbx = delete $args{kdbx} // eval { $self->kdbx };
+
+ $group = $self->_wrap_group($group // [%args]);
+ $group->uuid;
+ $group->kdbx($kdbx) if $kdbx;
+
+ push @{$self->{groups} ||= []}, $group->remove;
+ return $group->_set_group($self)->_signal('added', $self);
+}
+
+
+sub remove_group {
+ my $self = shift;
+ my $uuid = is_ref($_[0]) ? $self->_wrap_group(shift)->uuid : shift;
+ my %args = @_;
+ my $objects = $self->{groups};
+ for (my $i = 0; $i < @$objects; ++$i) {
+ my $object = $objects->[$i];
+ next if $uuid ne $object->uuid;
+ $object->_set_group(undef);
+ $object->_signal('removed') if $args{signal} // 1;
+ return splice @$objects, $i, 1;
+ }
+}
+
+##############################################################################
+
+
+sub objects_deeply {
+ my $self = shift;
+ my %args = @_;
+
+ my $searching = delete $args{searching};
+ my $auto_type = delete $args{auto_type};
+ my $history = delete $args{history};
+
+ my $groups = $self->groups_deeply(%args);
+ my @entries;
+
+ return File::KDBX::Iterator->new(sub {
+ if (!@entries) {
+ while (my $group = $groups->next) {
+ next if $searching && !$group->effective_enable_searching;
+ next if $auto_type && !$group->effective_enable_auto_type;
+ @entries = @{$group->entries};
+ @entries = grep { $_->auto_type->{enabled} } @entries if $auto_type;
+ @entries = map { ($_, @{$_->history}) } @entries if $history;
+ return $group;
+ }
+ }
+ shift @entries;
+ });
+}
+
+
+sub add_object {
+ my $self = shift;
+ my $obj = shift;
+ if ($obj->isa('File::KDBX::Entry')) {
+ $self->add_entry($obj);
+ }
+ elsif ($obj->isa('File::KDBX::Group')) {
+ $self->add_group($obj);
+ }
+}
+
+
+sub remove_object {
+ my $self = shift;
+ my $object = shift;
+ my $blessed = blessed($object);
+ return $self->remove_group($object, @_) if $blessed && $object->isa('File::KDBX::Group');
+ return $self->remove_entry($object, @_) if $blessed && $object->isa('File::KDBX::Entry');
+ return $self->remove_group($object, @_) || $self->remove_entry($object, @_);
+}
+
+##############################################################################
+
+
+sub effective_default_auto_type_sequence {
+ my $self = shift;
+ my $sequence = $self->default_auto_type_sequence;
+ return $sequence if defined $sequence;
+
+ my $parent = $self->group or return '{USERNAME}{TAB}{PASSWORD}{ENTER}';
+ return $parent->effective_default_auto_type_sequence;
+}
+
+
+sub effective_enable_auto_type {
+ my $self = shift;
+ my $enabled = $self->enable_auto_type;
+ return $enabled if defined $enabled;
+
+ my $parent = $self->group or return true;
+ return $parent->effective_enable_auto_type;
+}
+
+
+sub effective_enable_searching {
+ my $self = shift;
+ my $enabled = $self->enable_searching;
+ return $enabled if defined $enabled;
+
+ my $parent = $self->group or return true;
+ return $parent->effective_enable_searching;
+}
+
+##############################################################################
+
+
+sub is_empty {
+ my $self = shift;
+ return @{$self->groups} == 0 && @{$self->entries} == 0;
+}
+
+
+sub is_root {
+ my $self = shift;
+ my $kdbx = eval { $self->kdbx } or return FALSE;
+ return Hash::Util::FieldHash::id($kdbx->root) == Hash::Util::FieldHash::id($self);
+}
+
+
+sub is_recycle_bin {
+ my $self = shift;
+ my $kdbx = eval { $self->kdbx } or return FALSE;
+ my $group = $kdbx->recycle_bin;
+ return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+
+sub is_entry_templates {
+ my $self = shift;
+ my $kdbx = eval { $self->kdbx } or return FALSE;
+ my $group = $kdbx->entry_templates;
+ return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+
+sub is_last_selected {
+ my $self = shift;
+ my $kdbx = eval { $self->kdbx } or return FALSE;
+ my $group = $kdbx->last_selected;
+ return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+
+sub is_last_top_visible {
+ my $self = shift;
+ my $kdbx = eval { $self->kdbx } or return FALSE;
+ my $group = $kdbx->last_top_visible;
+ return $group && Hash::Util::FieldHash::id($group) == Hash::Util::FieldHash::id($self);
+}
+
+
+sub path {
+ my $self = shift;
+ return $self->name if $self->is_root;
+ my $lineage = $self->lineage or return;
+ my @parts = (@$lineage, $self);
+ shift @parts;
+ return join('.', map { $_->name } @parts);
+}
+
+
+sub size {
+ my $self = shift;
+ return sum0 map { $_->size } @{$self->groups}, @{$self->entries};
+}
+
+
+sub depth { $_[0]->is_root ? 0 : (scalar @{$_[0]->lineage || []} || -1) }
+
+sub _signal {
+ my $self = shift;
+ my $type = shift;
+ return $self->SUPER::_signal("group.$type", @_);
+}
+
+sub _commit {
+ my $self = shift;
+ my $time = gmtime;
+ $self->last_modification_time($time);
+ $self->last_access_time($time);
+}
+
+sub label { shift->name(@_) }
+
+### Name of the parent attribute expected to contain the object
+sub _parent_container { 'groups' }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Group - A KDBX database group
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+A group in a KDBX database is a type of object that can contain entries and other groups.
+
+There is also some metadata associated with a group. Each group in a database is identified uniquely by
+a UUID. An entry can also have an icon associated with it, and there are various timestamps. Take a look at
+the attributes to see what's available.
+
+=head1 ATTRIBUTES
+
+=head2 uuid
+
+128-bit UUID identifying the group within the database.
+
+=head2 name
+
+The human-readable name of the group.
+
+=head2 notes
+
+Free form text string associated with the group.
+
+=head2 tags
+
+Text string with arbitrary tags which can be used to build a taxonomy.
+
+=head2 icon_id
+
+Integer representing a default icon. See L<File::KDBX::Constants/":icon"> for valid values.
+
+=head2 custom_icon_uuid
+
+128-bit UUID identifying a custom icon within the database.
+
+=head2 is_expanded
+
+Whether or not subgroups are visible when listed for user selection.
+
+=head2 default_auto_type_sequence
+
+The default auto-type keystroke sequence, inheritable by entries and subgroups.
+
+=head2 enable_auto_type
+
+Whether or not the entry is eligible to be matched for auto-typing, inheritable by entries and subgroups.
+
+=head2 enable_searching
+
+Whether or not entries within the group can show up in search results, inheritable by subgroups.
+
+=head2 last_top_visible_entry
+
+The UUID of the entry visible at the top of the list.
+
+=head2 custom_data
+
+A set of key-value pairs used to store arbitrary data, usually used by software to keep track of state rather
+than by end users (who typically work with the strings and binaries).
+
+=head2 previous_parent_group
+
+128-bit UUID identifying a group within the database.
+
+=head2 entries
+
+Array of entries contained within the group.
+
+=head2 groups
+
+Array of subgroups contained within the group.
+
+=head2 last_modification_time
+
+Date and time when the entry was last modified.
+
+=head2 creation_time
+
+Date and time when the entry was created.
+
+=head2 last_access_time
+
+Date and time when the entry was last accessed.
+
+=head2 expiry_time
+
+Date and time when the entry expired or will expire.
+
+=head2 expires
+
+Boolean value indicating whether or not an entry is expired.
+
+=head2 usage_count
+
+TODO
+
+=head2 location_changed
+
+Date and time when the entry was last moved to a different parent group.
+
+=head1 METHODS
+
+=head2 entries
+
+ \@entries = $group->entries;
+
+Get an array of direct entries within a group.
+
+=head2 entries_deeply
+
+ \&iterator = $kdbx->entries_deeply(%options);
+
+Get an L<File::KDBX::Iterator> over I<entries> within a group. Supports the same options as L</groups>,
+plus some new ones:
+
+=over 4
+
+=item *
+
+C<auto_type> - Only include entries with auto-type enabled (default: false, include all)
+
+=item *
+
+C<searching> - Only include entries within groups with searching enabled (default: false, include all)
+
+=item *
+
+C<history> - Also include historical entries (default: false, include only current entries)
+
+=back
+
+=head2 add_entry
+
+ $entry = $group->add_entry($entry);
+ $entry = $group->add_entry(%entry_attributes);
+
+Add an entry to a group. If C<$entry> already has a parent group, it will be removed from that group before
+being added to C<$group>.
+
+=head2 remove_entry
+
+ $entry = $group->remove_entry($entry);
+ $entry = $group->remove_entry($entry_uuid);
+
+Remove an entry from a group's array of entries. Returns the entry removed or C<undef> if nothing removed.
+
+=head2 groups
+
+ \@groups = $group->groups;
+
+Get an array of direct subgroups within a group.
+
+=head2 groups_deeply
+
+ \&iterator = $group->groups_deeply(%options);
+
+Get an L<File::KDBX::Iterator> over I<groups> within a groups, deeply. Options:
+
+=over 4
+
+=item *
+
+C<inclusive> - Include C<$group> itself in the results (default: true)
+
+=item *
+
+C<algorithm> - Search algorithm, one of C<ids>, C<bfs> or C<dfs> (default: C<ids>)
+
+=back
+
+=head2 add_group
+
+ $new_group = $group->add_group($new_group);
+ $new_group = $group->add_group(%group_attributes);
+
+Add a group to a group. If C<$new_group> already has a parent group, it will be removed from that group before
+being added to C<$group>.
+
+=head2 remove_group
+
+ $removed_group = $group->remove_group($group);
+ $removed_group = $group->remove_group($group_uuid);
+
+Remove a group from a group's array of subgroups. Returns the group removed or C<undef> if nothing removed.
+
+=head2 objects_deeply
+
+ \&iterator = $groups->objects_deeply(%options);
+
+Get an L<File::KDBX::Iterator> over I<objects> within a group, deeply. Groups and entries are considered
+objects, so this is essentially a combination of L</groups> and L</entries>. This won't often be useful, but
+it can be convenient for maintenance tasks. This method takes the same options as L</groups> and L</entries>.
+
+=head2 add_object
+
+ $new_entry = $group->add_object($new_entry);
+ $new_group = $group->add_object($new_group);
+
+Add an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) to a group. This is the generic
+equivalent of the object forms of L</add_entry> and L</add_group>.
+
+=head2 remove_object
+
+ $group->remove_object($entry);
+ $group->remove_object($group);
+
+Remove an object (either a L<File::KDBX::Entry> or a L<File::KDBX::Group>) from a group. This is the generic
+equivalent of the object forms of L</remove_entry> and L</remove_group>.
+
+=head2 effective_default_auto_type_sequence
+
+ $text = $group->effective_default_auto_type_sequence;
+
+Get the value of L</default_auto_type_sequence>, if set, or get the inherited effective default auto-type
+sequence of the parent.
+
+=head2 effective_enable_auto_type
+
+ $text = $group->effective_enable_auto_type;
+
+Get the value of L</enable_auto_type>, if set, or get the inherited effective auto-type enabled value of the
+parent.
+
+=head2 effective_enable_searching
+
+ $text = $group->effective_enable_searching;
+
+Get the value of L</enable_searching>, if set, or get the inherited effective searching enabled value of the
+parent.
+
+=head2 is_empty
+
+ $bool = $group->is_empty;
+
+Get whether or not the group is empty (has no subgroups or entries).
+
+=head2 is_root
+
+ $bool = $group->is_root;
+
+Determine if a group is the root group of its connected database.
+
+=head2 is_recycle_bin
+
+ $bool = $group->is_recycle_bin;
+
+Get whether or not a group is the recycle bin of its connected database.
+
+=head2 is_entry_templates
+
+ $bool = $group->is_entry_templates;
+
+Get whether or not a group is the group containing entry template of its connected database.
+
+=head2 is_last_selected
+
+ $bool = $group->is_last_selected;
+
+Get whether or not a group is the prior selected group of its connected database.
+
+=head2 is_last_top_visible
+
+ $bool = $group->is_last_top_visible;
+
+Get whether or not a group is the latest top visible group of its connected database.
+
+=head2 path
+
+ $string = $group->path;
+
+Get a string representation of a group's lineage. This is used as the substitution value for the
+C<{GROUP_PATH}> placeholder. See L<File::KDBX::Entry/Placeholders>.
+
+For a root group, the path is simply the name of the group. For deeper groups, the path is a period-separated
+sequence of group names between the root group and C<$group>, including C<$group> but I<not> the root group.
+In other words, paths of deeper groups leave the root group name out.
+
+ Database
+ -> Root # path is "Root"
+ -> Foo # path is "Foo"
+ -> Bar # path is "Foo.Bar"
+
+Yeah, it doesn't make much sense to me, either, but this matches the behavior of KeePass.
+
+=head2 size
+
+ $size = $group->size;
+
+Get the size (in bytes) of a group, including the size of all subroups and entries, if any.
+
+=head2 depth
+
+ $depth = $group->depth;
+
+Get the depth of a group within a database. The root group is at depth 0, its direct children are at depth 1,
+etc. A group not in a database tree structure returns a depth of -1.
+
+=for Pod::Coverage times
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::IO;
+# ABSTRACT: Base IO class for KDBX-related streams
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:bool);
+use File::KDBX::Util qw(:class :empty);
+use List::Util qw(sum0);
+use Ref::Util qw(is_blessed_ref is_ref is_scalarref);
+use Symbol qw(gensym);
+use namespace::clean;
+
+extends 'IO::Handle';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _croak { require Carp; goto &Carp::croak }
+
+my %ATTRS = (
+ _append_output => 0,
+ _buffer_in => sub { [] },
+ _buffer_out => sub { [] },
+ _error => undef,
+ _fh => undef,
+ _mode => '',
+);
+while (my ($attr, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *$attr = sub {
+ my $self = shift;
+ *$self->{$attr} = shift if @_;
+ *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+
+sub new {
+ my $class = shift || (caller)[0];
+ my $self = bless gensym, ref($class) || $class;
+ tie *$self, $self if 5.005 <= $];
+ return $self;
+}
+
+sub DESTROY {
+ return if in_global_destruction;
+ local ($., $@, $!, $^E, $?);
+ my $self = shift;
+ $self->close;
+}
+
+sub close {
+ my $self = shift;
+ my $fh = $self->_fh // return TRUE;
+ $self->_POPPED($fh);
+ $self->_fh(undef);
+ return $fh->close;
+}
+sub eof {
+ my $self = shift;
+ return FALSE if @{$self->_buffer_in};
+ my $fh = $self->_fh // return TRUE;
+ local *$self->{_error} = *$self->{_error};
+ my $char = $self->getc || return TRUE;
+ $self->ungetc($char);
+}
+sub read { shift->sysread(@_) }
+sub print {
+ my $self = shift;
+ for my $buf (@_) {
+ return FALSE if !$self->write($buf, length($buf));
+ }
+ return TRUE;
+}
+sub printf { shift->print(sprintf(@_)) }
+sub say { shift->print(@_, "\n") }
+sub getc { my $c; (shift->read($c, 1) // 0) == 1 ? $c : undef }
+sub sysread {
+ my $self = shift;
+ my ($out, $len, $offset) = @_;
+ $out = \$_[0] if !is_scalarref($out);
+ $offset //= 0;
+
+ $self->_mode('r') if !$self->_mode;
+
+ my $fh = $self->_fh or return 0;
+ return 0 if defined $len && $len == 0;
+
+ my $append = $self->_append_output;
+ if (!$append) {
+ if (!$offset) {
+ $$out = '';
+ }
+ else {
+ if (length($$out) < $offset) {
+ $$out .= "\0" x ($offset - length($$out));
+ }
+ else {
+ substr($$out, $offset) = '';
+ }
+ }
+ }
+ elsif (!defined $$out) {
+ $$out = '';
+ }
+
+ $len ||= 0;
+
+ my $buffer = $self->_buffer_in;
+ my $buffer_len = $self->_buffer_in_length;
+
+ if (!$len && !$offset) {
+ if (@$buffer) {
+ my $blen = length($buffer->[0]);
+ if ($append) {
+ $$out .= shift @$buffer;
+ }
+ else {
+ $$out = shift @$buffer;
+ }
+ return $blen;
+ }
+ else {
+ my $fill = $self->_FILL($fh) or return 0;
+ if ($append) {
+ $$out .= $fill;
+ }
+ else {
+ $$out = $fill;
+ }
+ return length($fill);
+ }
+ }
+
+ while ($buffer_len < $len) {
+ my $fill = $self->_FILL($fh);
+ last if empty $fill;
+ $self->_buffer_in_add($fill);
+ $buffer_len += length($fill);
+ }
+
+ my $read_len = 0;
+ while ($read_len < $len && @$buffer) {
+ my $wanted = $len - $read_len;
+ my $read = shift @$buffer;
+ if ($wanted < length($read)) {
+ $$out .= substr($read, 0, $wanted, '');
+ unshift @$buffer, $read;
+ $read_len += $wanted;
+ }
+ else {
+ $$out .= $read;
+ $read_len += length($read);
+ }
+ }
+
+ return $read_len;
+}
+sub syswrite {
+ my ($self, $buf, $len, $offset) = @_;
+ $len //= length($buf);
+ $offset //= 0;
+
+ $self->_mode('w') if !$self->_mode;
+
+ return $self->_WRITE(substr($buf, $offset, $len), $self->_fh);
+}
+
+sub autoflush {
+ my $self = shift;
+ my $fh = $self->_fh // return FALSE;
+ return $fh->autoflush(@_);
+}
+
+sub opened {
+ my $self = shift;
+ my $fh = $self->_fh // return FALSE;
+ return TRUE;
+}
+sub getline {
+ my $self = shift;
+
+ if (!defined $/) { # SLURP
+ local *$self->{_append_output} = 1;
+ my $data;
+ 1 while 0 < $self->read($data);
+ return $data;
+ }
+ elsif (is_scalarref($/) && ${$/} =~ /^\d+$/ && 0 < ${$/}) {
+ # RECORD MODE
+ goto &_not_implemented;
+ }
+ elsif (length $/ == 0) {
+ # PARAGRAPH MODE
+ goto &_not_implemented;
+ }
+ else {
+ # LINE MODE
+ goto &_not_implemented;
+ }
+}
+sub getlines {
+ my $self = shift;
+ wantarray or _croak 'Must call getlines in list context';
+ my @lines;
+ while (defined (my $line = $self->getline)) {
+ push @lines, $line;
+ }
+ return @lines;
+}
+sub ungetc {
+ my ($self, $ord) = @_;
+ unshift @{$self->_buffer_in}, chr($ord);
+ return;
+}
+sub write {
+ my ($self, $buf, $len, $offset) = @_;
+ return $self->syswrite($buf, $len, $offset) == $len;
+}
+sub error {
+ my $self = shift;
+ return !!$self->_error;
+}
+sub clearerr {
+ my $self = shift;
+ my $fh = $self->_fh // return -1;
+ $self->_error(undef);
+ return;
+}
+sub sync {
+ my $self = shift;
+ my $fh = $self->_fh // return undef;
+ return $fh->sync;
+}
+sub flush {
+ my $self = shift;
+ my $fh = $self->_fh // return undef;
+ $self->_FLUSH($fh);
+ return $fh->flush;
+}
+sub printflush {
+ my $self = shift;
+ my $orig = $self->autoflush;
+ my $r = $self->print(@_);
+ $self->autoflush($orig);
+ return $r;
+}
+sub blocking {
+ my $self = shift;
+ my $fh = $self->_fh // return TRUE;
+ return $fh->blocking(@_);
+}
+
+sub format_write { goto &_not_implemented }
+sub new_from_fd { goto &_not_implemented }
+sub fcntl { goto &_not_implemented }
+sub fileno { goto &_not_implemented }
+sub ioctl { goto &_not_implemented }
+sub stat { goto &_not_implemented }
+sub truncate { goto &_not_implemented }
+sub format_page_number { goto &_not_implemented }
+sub format_lines_per_page { goto &_not_implemented }
+sub format_lines_left { goto &_not_implemented }
+sub format_name { goto &_not_implemented }
+sub format_top_name { goto &_not_implemented }
+sub input_line_number { goto &_not_implemented }
+sub fdopen { goto &_not_implemented }
+sub untaint { goto &_not_implemented }
+
+##############################################################################
+
+sub _buffer_in_add { push @{shift->_buffer_in}, @_ }
+sub _buffer_in_length { sum0 map { length($_) } @{shift->_buffer_in} }
+
+sub _buffer_out_add { push @{shift->_buffer_out}, @_ }
+sub _buffer_out_length { sum0 map { length($_) } @{shift->_buffer_out} }
+
+sub _not_implemented { _croak 'Operation not supported' }
+
+##############################################################################
+
+sub TIEHANDLE {
+ return $_[0] if is_blessed_ref($_[0]);
+ die 'wat';
+}
+
+sub UNTIE {
+ my $self = shift;
+}
+
+sub READLINE {
+ goto &getlines if wantarray;
+ goto &getline;
+}
+
+sub binmode { 1 }
+
+{
+ no warnings 'once';
+
+ *READ = \&read;
+ # *READLINE = \&getline;
+ *GETC = \&getc;
+ *FILENO = \&fileno;
+ *PRINT = \&print;
+ *PRINTF = \&printf;
+ *WRITE = \&syswrite;
+ # *SEEK = \&seek;
+ # *TELL = \&tell;
+ *EOF = \&eof;
+ *CLOSE = \&close;
+ *BINMODE = \&binmode;
+}
+
+sub _FILL { die 'Not implemented' }
+
+##############################################################################
+
+if ($ENV{DEBUG_IO}) {
+ my %debug = (level => 0);
+ for my $method (qw{
+ new
+ new_from_fd
+ close
+ eof
+ fcntl
+ fileno
+ format_write
+ getc
+ ioctl
+ read
+ print
+ printf
+ say
+ stat
+ sysread
+ syswrite
+ truncate
+
+ autoflush
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ input_line_number
+
+ fdopen
+ opened
+ getline
+ getlines
+ ungetc
+ write
+ error
+ clearerr
+ sync
+ flush
+ printflush
+ blocking
+
+ untaint
+ }) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ no warnings 'redefine';
+ my $orig = *$method{CODE};
+ *$method = sub {
+ local $debug{level} = $debug{level} + 2;
+ my $indented_method = (' ' x $debug{level}) . $method;
+ my $self = shift;
+ print STDERR sprintf('%-20s -> %s (%s)', $indented_method, $self,
+ join(', ', map { defined $_ ? substr($_, 0, 16) : 'undef' } @_)), "\n";
+ my $r = $orig->($self, @_) // 'undef';
+ print STDERR sprintf('%-20s <- %s [%s]', $indented_method, $self, $r), "\n";
+ return $r;
+ };
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::IO - Base IO class for KDBX-related streams
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+This is a L<IO::Handle> subclass which provides self-tying and buffering. It currently provides an interface
+for subclasses that is similar to L<PerlIO::via>, but this is subject to change. Don't depend on this outside
+of the L<File::KDBX> distribution. Currently-available subclasses:
+
+=over 4
+
+=item *
+
+L<File::KDBX::IO::Crypt>
+
+=item *
+
+L<File::KDBX::IO::HashBlock>
+
+=item *
+
+L<File::KDBX::IO::HmacBlock>
+
+=back
+
+=for Pod::Coverage autoflush
+binmode
+close
+eof
+fcntl
+fileno
+format_lines_left
+format_lines_per_page
+format_name
+format_page_number
+format_top_name
+format_write
+getc
+input_line_number
+ioctl
+print
+printf
+read
+say
+stat
+sysread
+syswrite
+truncate
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::IO::Crypt;
+# ABSTRACT: Encrypter/decrypter IO handle
+
+use warnings;
+use strict;
+
+use Errno;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :empty);
+use namespace::clean;
+
+extends 'File::KDBX::IO';
+
+our $VERSION = '0.800'; # VERSION
+our $BUFFER_SIZE = 16384;
+our $ERROR;
+
+
+my %ATTRS = (
+ cipher => undef,
+);
+while (my ($attr, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *$attr = sub {
+ my $self = shift;
+ *$self->{$attr} = shift if @_;
+ *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
+ my $self = $class->SUPER::new;
+ $self->_fh($args{fh}) or throw 'IO handle required';
+ $self->cipher($args{cipher}) or throw 'Cipher required';
+ return $self;
+}
+
+sub _FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ my $cipher = $self->cipher or return;
+
+ $fh->read(my $buf = '', $BUFFER_SIZE);
+ if (0 < length($buf)) {
+ my $plaintext = eval { $cipher->decrypt($buf) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ return $plaintext if 0 < length($plaintext);
+ }
+
+ # finish
+ my $plaintext = eval { $cipher->finish };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ $self->cipher(undef);
+ return $plaintext;
+}
+
+sub _WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ my $cipher = $self->cipher or return 0;
+
+ my $new_data = eval { $cipher->encrypt($buf) } || '';
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return 0;
+ }
+ $self->_buffer_out_add($new_data) if nonempty $new_data;
+ return length($buf);
+}
+
+sub _POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->_mode ne 'w';
+ my $cipher = $self->cipher or return;
+
+ my $new_data = eval { $cipher->finish } || '';
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ $self->_buffer_out_add($new_data) if nonempty $new_data;
+
+ $self->cipher(undef);
+ $self->_FLUSH($fh);
+}
+
+sub _FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return if $self->_mode ne 'w';
+
+ my $buffer = $self->_buffer_out;
+ while (@$buffer) {
+ my $read = shift @$buffer;
+ next if empty $read;
+ $fh->print($read) or return -1;
+ }
+ return 0;
+}
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->cipher(undef);
+ $self->_error($ERROR = File::KDBX::Error->new(@_));
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::IO::Crypt - Encrypter/decrypter IO handle
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::IO::Crypt;
+ use File::KDBX::Cipher;
+
+ my $cipher = File::KDBX::Cipher->new(...);
+
+ open(my $out_fh, '>:raw', 'ciphertext.bin');
+ $out_fh = File::KDBX::IO::Crypt->new($out_fh, cipher => $cipher);
+
+ print $out_fh $plaintext;
+
+ close($out_fh);
+
+ open(my $in_fh, '<:raw', 'ciphertext.bin');
+ $in_fh = File::KDBX::IO::Crypt->new($in_fh, cipher => $cipher);
+
+ my $plaintext = do { local $/; <$in_fh> );
+
+ close($in_fh);
+
+=head1 ATTRIBUTES
+
+=head2 cipher
+
+A L<File::KDBX::Cipher> instance to do the actual encryption or decryption.
+
+=head1 METHODS
+
+=head2 new
+
+ $fh = File::KDBX::IO::Crypt->new(%attributes);
+ $fh = File::KDBX::IO::Crypt->new($fh, %attributes);
+
+Construct a new crypto IO handle.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::IO::HashBlock;
+# ABSTRACT: Hash block stream IO handle
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Errno;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :io);
+use IO::Handle;
+use namespace::clean;
+
+extends 'File::KDBX::IO';
+
+our $VERSION = '0.800'; # VERSION
+our $ALGORITHM = 'SHA256';
+our $BLOCK_SIZE = 1048576; # 1MiB
+our $ERROR;
+
+
+my %ATTRS = (
+ _block_index => 0,
+ _buffer => sub { \(my $buf = '') },
+ _finished => 0,
+ algorithm => sub { $ALGORITHM },
+ block_size => sub { $BLOCK_SIZE },
+);
+while (my ($attr, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *$attr = sub {
+ my $self = shift;
+ *$self->{$attr} = shift if @_;
+ *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
+ my $self = $class->SUPER::new;
+ $self->_fh($args{fh}) or throw 'IO handle required';
+ $self->algorithm($args{algorithm});
+ $self->block_size($args{block_size});
+ $self->_buffer;
+ return $self;
+}
+
+sub _FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->_finished;
+
+ my $block = eval { $self->_read_hash_block($fh) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ return $$block if defined $block;
+}
+
+sub _WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self\n";
+ return 0 if $self->_finished;
+
+ ${$self->_buffer} .= $buf;
+
+ $self->_FLUSH($fh);
+
+ return length($buf);
+}
+
+sub _POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self\n";
+ return if $self->_mode ne 'w';
+
+ $self->_FLUSH($fh);
+ eval {
+ $self->_write_next_hash_block($fh); # partial block with remaining content
+ $self->_write_final_hash_block($fh); # terminating block
+ };
+ $self->_set_error($@) if $@;
+}
+
+sub _FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self\n";
+ return if $self->_mode ne 'w';
+
+ eval {
+ while ($self->block_size <= length(${*$self->{_buffer}})) {
+ $self->_write_next_hash_block($fh);
+ }
+ };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return -1;
+ }
+
+ return 0;
+}
+
+##############################################################################
+
+sub _read_hash_block {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 4 or throw 'Failed to read hash block index';
+ my ($index) = unpack('L<', $buf);
+
+ $index == $self->_block_index or throw 'Invalid block index', index => $index;
+
+ read_all $fh, my $hash, 32 or throw 'Failed to read hash';
+
+ read_all $fh, $buf, 4 or throw 'Failed to read hash block size';
+ my ($size) = unpack('L<', $buf);
+
+ if ($size == 0) {
+ $hash eq ("\0" x 32) or throw 'Invalid final block hash', hash => $hash;
+ $self->_finished(1);
+ return undef;
+ }
+
+ read_all $fh, my $block, $size or throw 'Failed to read hash block', index => $index, size => $size;
+
+ my $got_hash = digest_data($self->algorithm, $block);
+ $hash eq $got_hash
+ or throw 'Hash mismatch', index => $index, size => $size, got => $got_hash, expected => $hash;
+
+ *$self->{_block_index}++;
+ return \$block;
+}
+
+sub _write_next_hash_block {
+ my $self = shift;
+ my $fh = shift;
+
+ my $size = length(${$self->_buffer});
+ $size = $self->block_size if $self->block_size < $size;
+ return 0 if $size == 0;
+
+ my $block = substr(${$self->_buffer}, 0, $size, '');
+
+ my $buf = pack('L<', $self->_block_index);
+ print $fh $buf or throw 'Failed to write hash block index';
+
+ my $hash = digest_data($self->algorithm, $block);
+ print $fh $hash or throw 'Failed to write hash';
+
+ $buf = pack('L<', length($block));
+ print $fh $buf or throw 'Failed to write hash block size';
+
+ # $fh->write($block, $size) or throw 'Failed to hash write block';
+ print $fh $block or throw 'Failed to hash write block';
+
+ *$self->{_block_index}++;
+ return 0;
+}
+
+sub _write_final_hash_block {
+ my $self = shift;
+ my $fh = shift;
+
+ my $buf = pack('L<', $self->_block_index);
+ print $fh $buf or throw 'Failed to write hash block index';
+
+ my $hash = "\0" x 32;
+ print $fh $hash or throw 'Failed to write hash';
+
+ $buf = pack('L<', 0);
+ print $fh $buf or throw 'Failed to write hash block size';
+
+ $self->_finished(1);
+ return 0;
+}
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->_error($ERROR = error(@_));
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::IO::HashBlock - Hash block stream IO handle
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+Writing to a hash-block handle will transform the data into a series of blocks. Each block is hashed, and the
+hash is included with the block in the stream.
+
+Reading from a handle, each hash block will be verified as the blocks are disassembled back into a data
+stream.
+
+This format helps ensure data integrity of KDBX3 files.
+
+Each block is encoded thusly:
+
+=over 4
+
+=item *
+
+Block index - Little-endian unsigned 32-bit integer, increments starting with 0
+
+=item *
+
+Hash - 32 bytes
+
+=item *
+
+Block size - Little-endian unsigned 32-bit (counting only the data)
+
+=item *
+
+Data - String of bytes
+
+=back
+
+The terminating block is an empty block where hash is 32 null bytes, block size is 0 and there is no data.
+
+=head1 ATTRIBUTES
+
+=head2 algorithm
+
+Digest algorithm in hash-blocking the stream (default: C<SHA-256>)
+
+=head2 block_size
+
+Desired block size when writing (default: C<$File::KDBX::IO::HashBlock::BLOCK_SIZE> or 1,048,576 bytes)
+
+=head1 METHODS
+
+=head2 new
+
+ $fh = File::KDBX::IO::HashBlock->new(%attributes);
+ $fh = File::KDBX::IO::HashBlock->new($fh, %attributes);
+
+Construct a new hash-block stream IO handle.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::IO::HmacBlock;
+# ABSTRACT: HMAC block stream IO handle
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use Errno;
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :io assert_64bit);
+use namespace::clean;
+
+extends 'File::KDBX::IO';
+
+our $VERSION = '0.800'; # VERSION
+our $BLOCK_SIZE = 1048576; # 1MiB
+our $ERROR;
+
+
+my %ATTRS = (
+ _block_index => 0,
+ _buffer => sub { \(my $buf = '') },
+ _finished => 0,
+ block_size => sub { $BLOCK_SIZE },
+ key => undef,
+);
+while (my ($attr, $default) = each %ATTRS) {
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ *$attr = sub {
+ my $self = shift;
+ *$self->{$attr} = shift if @_;
+ *$self->{$attr} //= (ref $default eq 'CODE') ? $default->($self) : $default;
+ };
+}
+
+
+sub new {
+ assert_64bit;
+
+ my $class = shift;
+ my %args = @_ % 2 == 1 ? (fh => shift, @_) : @_;
+ my $self = $class->SUPER::new;
+ $self->_fh($args{fh}) or throw 'IO handle required';
+ $self->key($args{key}) or throw 'Key required';
+ $self->block_size($args{block_size});
+ $self->_buffer;
+ return $self;
+}
+
+sub _FILL {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FILL\t$self\n";
+ return if $self->_finished;
+
+ my $block = eval { $self->_read_hashed_block($fh) };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return;
+ }
+ if (length($block) == 0) {
+ $self->_finished(1);
+ return;
+ }
+ return $block;
+}
+
+sub _WRITE {
+ my ($self, $buf, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "WRITE\t$self ($fh)\n";
+ return 0 if $self->_finished;
+
+ ${*$self->{_buffer}} .= $buf;
+
+ $self->_FLUSH($fh); # TODO only if autoflush?
+
+ return length($buf);
+}
+
+sub _POPPED {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "POPPED\t$self ($fh)\n";
+ return if $self->_mode ne 'w';
+
+ $self->_FLUSH($fh);
+ eval {
+ $self->_write_next_hmac_block($fh); # partial block with remaining content
+ $self->_write_final_hmac_block($fh); # terminating block
+ };
+ $self->_set_error($@) if $@;
+}
+
+sub _FLUSH {
+ my ($self, $fh) = @_;
+
+ $ENV{DEBUG_STREAM} and print STDERR "FLUSH\t$self ($fh)\n";
+ return if $self->_mode ne 'w';
+
+ eval {
+ while ($self->block_size <= length(${*$self->{_buffer}})) {
+ $self->_write_next_hmac_block($fh);
+ }
+ };
+ if (my $err = $@) {
+ $self->_set_error($err);
+ return -1;
+ }
+
+ return 0;
+}
+
+sub _set_error {
+ my $self = shift;
+ $ENV{DEBUG_STREAM} and print STDERR "err\t$self\n";
+ if (exists &Errno::EPROTO) {
+ $! = &Errno::EPROTO;
+ }
+ elsif (exists &Errno::EIO) {
+ $! = &Errno::EIO;
+ }
+ $self->_error($ERROR = error(@_));
+}
+
+##############################################################################
+
+sub _read_hashed_block {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $hmac, 32 or throw 'Failed to read HMAC';
+
+ read_all $fh, my $packed_size, 4 or throw 'Failed to read HMAC block size';
+ my ($size) = unpack('L<', $packed_size);
+
+ my $block = '';
+ if (0 < $size) {
+ read_all $fh, $block, $size
+ or throw 'Failed to read HMAC block', index => $self->_block_index, size => $size;
+ }
+
+ my $packed_index = pack('Q<', $self->_block_index);
+ my $got_hmac = hmac('SHA256', $self->_hmac_key,
+ $packed_index,
+ $packed_size,
+ $block,
+ );
+
+ $hmac eq $got_hmac
+ or throw 'Block authentication failed', index => $self->_block_index, got => $got_hmac, expected => $hmac;
+
+ *$self->{_block_index}++;
+ return $block;
+}
+
+sub _write_next_hmac_block {
+ my $self = shift;
+ my $fh = shift;
+ my $buffer = shift // $self->_buffer;
+ my $allow_empty = shift;
+
+ my $size = length($$buffer);
+ $size = $self->block_size if $self->block_size < $size;
+ return 0 if $size == 0 && !$allow_empty;
+
+ my $block = '';
+ $block = substr($$buffer, 0, $size, '') if 0 < $size;
+
+ my $packed_index = pack('Q<', $self->_block_index);
+ my $packed_size = pack('L<', $size);
+ my $hmac = hmac('SHA256', $self->_hmac_key,
+ $packed_index,
+ $packed_size,
+ $block,
+ );
+
+ $fh->print($hmac, $packed_size, $block)
+ or throw 'Failed to write HMAC block', hmac => $hmac, block_size => $size;
+
+ *$self->{_block_index}++;
+ return 0;
+}
+
+sub _write_final_hmac_block {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_write_next_hmac_block($fh, \'', 1);
+}
+
+sub _hmac_key {
+ my $self = shift;
+ my $key = shift // $self->key;
+ my $index = shift // $self->_block_index;
+
+ my $packed_index = pack('Q<', $index);
+ my $hmac_key = digest_data('SHA512', $packed_index, $key);
+ return $hmac_key;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::IO::HmacBlock - HMAC block stream IO handle
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+Writing to a HMAC-block stream handle will transform the data into a series of blocks. An HMAC is calculated
+for each block and is included in the output.
+
+Reading from a handle, each block will be verified and authenticated as the blocks are disassembled back into
+a data stream.
+
+This format helps ensure data integrity and authenticity of KDBX4 files.
+
+Each block is encoded thusly:
+
+=over 4
+
+=item *
+
+HMAC - 32 bytes, calculated over [block index (increments starting with 0), block size and data]
+
+=item *
+
+Block size - Little-endian unsigned 32-bit (counting only the data)
+
+=item *
+
+Data - String of bytes
+
+=back
+
+The terminating block is an empty block encoded as usual but block size is 0 and there is no data.
+
+=head1 ATTRIBUTES
+
+=head2 block_size
+
+Desired block size when writing (default: C<$File::KDBX::IO::HmacBlock::BLOCK_SIZE> or 1,048,576 bytes)
+
+=head2 key
+
+HMAC-SHA256 key for authenticating the data stream (required)
+
+=head1 METHODS
+
+=head2 new
+
+ $fh = File::KDBX::IO::HmacBlock->new(%attributes);
+ $fh = File::KDBX::IO::HmacBlock->new($fh, %attributes);
+
+Construct a new HMAC-block stream IO handle.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Iterator;
+# ABSTRACT: KDBX database iterator
+
+use warnings;
+use strict;
+
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :load :search);
+use Iterator::Simple;
+use Module::Loaded;
+use Ref::Util qw(is_arrayref is_coderef is_ref is_scalarref);
+use namespace::clean;
+
+BEGIN { mark_as_loaded('Iterator::Simple::Iterator') }
+extends 'Iterator::Simple::Iterator';
+
+our $VERSION = '0.800'; # VERSION
+
+
+sub new {
+ my $class = shift;
+ my $code = is_coderef($_[0]) ? shift : sub { undef };
+
+ my $items = @_ == 1 && is_arrayref($_[0]) ? $_[0] : \@_;
+ return $class->SUPER::new(sub {
+ if (@_) { # put back
+ if (@_ == 1 && is_arrayref($_[0])) {
+ $items = $_[0];
+ }
+ else {
+ unshift @$items, @_;
+ }
+ return;
+ }
+ else {
+ my $next = shift @$items;
+ return $next if defined $next;
+ return $code->();
+ }
+ });
+}
+
+
+sub next {
+ my $self = shift;
+ my $code = shift or return $self->();
+
+ $code = query_any($code, @_);
+
+ while (defined (local $_ = $self->())) {
+ return $_ if $code->($_);
+ }
+ return;
+}
+
+
+sub peek {
+ my $self = shift;
+
+ my $next = $self->();
+ $self->($next) if defined $next;
+ return $next;
+}
+
+
+sub unget {
+ my $self = shift; # Must shift in a statement before calling.
+ $self->(@_);
+}
+
+
+sub each {
+ my $self = shift;
+ my $cb = shift or return @{$self->to_array};
+
+ if (is_coderef($cb)) {
+ my $count = 0;
+ $cb->($_, $count++, @_) while defined (local $_ = $self->());
+ }
+ elsif (!is_ref($cb)) {
+ $_->$cb(@_) while defined (local $_ = $self->());
+ }
+ return $self;
+}
+
+
+sub where { shift->grep(@_) }
+
+sub grep {
+ my $self = shift;
+ my $code = query_any(@_);
+
+ ref($self)->new(sub {
+ while (defined (local $_ = $self->())) {
+ return $_ if $code->($_);
+ }
+ return;
+ });
+}
+
+
+sub map {
+ my $self = shift;
+ my $code = shift;
+
+ ref($self)->new(sub {
+ local $_ = $self->();
+ return if !defined $_;
+ return $code->();
+ });
+}
+
+
+sub order_by {
+ my $self = shift;
+ my $field = shift;
+ my %args = @_;
+
+ my $ascending = delete $args{ascending} // !delete $args{descending} // 1;
+ my $case = delete $args{case} // !delete $args{no_case} // 1;
+ my $collate = (delete $args{collate} // !delete $args{no_collate} // 1)
+ && try_load_optional('Unicode::Collate');
+
+ if ($collate && !$case) {
+ $case = 1;
+ # use a proper Unicode::Collate level to ignore case
+ $args{level} //= 2;
+ }
+ $args{upper_before_lower} //= 1;
+
+ my $value = $field;
+ $value = $case ? sub { $_[0]->$field // '' } : sub { uc($_[0]->$field) // '' } if !is_coderef($value);
+ my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array};
+
+ if ($collate) {
+ my $c = Unicode::Collate->new(%args);
+ if ($ascending) {
+ @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($a->[1], $b->[1]) } @all;
+ } else {
+ @all = CORE::map { $_->[0] } CORE::sort { $c->cmp($b->[1], $a->[1]) } @all;
+ }
+ } else {
+ if ($ascending) {
+ @all = CORE::map { $_->[0] } CORE::sort { $a->[1] cmp $b->[1] } @all;
+ } else {
+ @all = CORE::map { $_->[0] } CORE::sort { $b->[1] cmp $a->[1] } @all;
+ }
+ }
+
+ $self->(\@all);
+ return $self;
+}
+
+
+sub sort_by { shift->order_by(@_) }
+
+
+sub norder_by {
+ my $self = shift;
+ my $field = shift;
+ my %args = @_;
+
+ my $ascending = $args{ascending} // !$args{descending} // 1;
+
+ my $value = $field;
+ $value = sub { $_[0]->$field // 0 } if !is_coderef($value);
+ my @all = CORE::map { [$_, $value->($_)] } @{$self->to_array};
+
+ if ($ascending) {
+ @all = CORE::map { $_->[0] } CORE::sort { $a->[1] <=> $b->[1] } @all;
+ } else {
+ @all = CORE::map { $_->[0] } CORE::sort { $b->[1] <=> $a->[1] } @all;
+ }
+
+ $self->(\@all);
+ return $self;
+}
+
+
+sub nsort_by { shift->norder_by(@_) }
+
+
+sub limit { shift->head(@_) }
+
+
+sub to_array {
+ my $self = shift;
+
+ my @all;
+ push @all, $_ while defined (local $_ = $self->());
+ return \@all;
+}
+
+
+sub count {
+ my $self = shift;
+
+ my $items = $self->to_array;
+ $self->($items);
+ return scalar @$items;
+}
+
+
+sub size { shift->count }
+
+##############################################################################
+
+sub TO_JSON { $_[0]->to_array }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Iterator - KDBX database iterator
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ my $kdbx = File::KDBX->load('database.kdbx', 'masterpw');
+
+ $kdbx->entries
+ ->where(sub { $_->title =~ /bank/i })
+ ->order_by('title')
+ ->limit(5)
+ ->each(sub {
+ say $_->title;
+ });
+
+=head1 DESCRIPTION
+
+A buffered iterator compatible with and expanding upon L<Iterator::Simple>, this provides an easy way to
+navigate a L<File::KDBX> database. The documentation for B<Iterator::Simple> documents functions and methods
+supported but this iterator that are not documented here, so consider that additional reading.
+
+=head2 Buffer
+
+This iterator is buffered, meaning it can drain from an iterator subroutine under the hood, storing items
+temporarily to be accessed later. This allows features like L</peek> and L</sort> which might be useful in the
+context of KDBX databases which are normally pretty small so draining an iterator isn't cost-prohibitive.
+
+The way this works is that if you call an iterator without arguments, it acts like a normal iterator. If you
+call it with arguments, however, the arguments are added to the buffer. When called without arguments, the
+buffer is drained before the iterator function is. Using L</unget> is equivalent to calling the iterator with
+arguments, and as L</next> is equivalent to calling the iterator without arguments.
+
+=head1 METHODS
+
+=head2 new
+
+ \&iterator = File::KDBX::Iterator->new(\&iterator);
+
+Blesses an iterator to augment it with buffering plus some useful utility methods.
+
+=head2 next
+
+ $item = $iterator->next;
+ # OR equivalently
+ $item = $iterator->();
+
+ $item = $iterator->next(\&query);
+ $item = $iterator->next([\'simple expression', @fields]);
+
+Get the next item or C<undef> if there are no more items. If a query is passed, get the next matching item,
+discarding any unmatching items before the matching item. Example:
+
+ my $item = $iterator->next(sub { $_->label =~ /Gym/ });
+
+=head2 peek
+
+ $item = $iterator->peek;
+
+Peek at the next item. Returns C<undef> if the iterator is empty. This allows you to access the next item
+without draining it from the iterator. The same item will be returned the next time L</next> is called.
+
+=head2 unget
+
+ $iterator->unget(\@items);
+ $iterator->unget(...);
+ # OR equivalently
+ $iterator->(\@items);
+ $iterator->(...);
+
+Replace the buffer or unshift one or more items to the current buffer.
+
+See L</Buffer>.
+
+=head2 each
+
+ @items = $iterator->each;
+
+ $iterator->each(sub($item, $num, @args) { ... }, @args);
+
+ $iterator->each($method_name, ...);
+
+Get or act on the rest of the items. There are three forms:
+
+=over 4
+
+=item 1
+
+Without arguments, C<each> returns a list of the rest of the items.
+
+=item 2
+
+Pass a coderef to be called once per item, in order. Arguments to the coderef are the item itself (also C<$_>), its index number and then any extra arguments that were passed to C<each> after the coderef.
+
+=item 3
+
+Pass a string that is the name of a method to be called on each object, in order. Any extra arguments passed to C<each> after the method name are passed through to each method call. This form requires each item be an object that C<can> the given method.
+
+=back
+
+B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>.
+
+=head2 grep
+
+=head2 where
+
+ \&iterator = $iterator->grep(\&query);
+ \&iterator = $iterator->grep([\'simple expression', @fields]);
+
+Get a new iterator draining from an existing iterator but providing only items that pass a test or are matched
+by a query.
+
+=head2 map
+
+ \&iterator = $iterator->map(\&code);
+
+Get a new iterator draining from an existing iterator but providing modified items.
+
+=head2 order_by
+
+ \&iterator = $iterator->sort_by($field, %options);
+ \&iterator = $iterator->sort_by(\&get_value, %options);
+
+Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting
+is done using L<Unicode::Collate> (if available) or C<cmp> to sort alphanumerically. The C<\&get_value>
+subroutine is called once for each item and should return a string value. Options:
+
+=over 4
+
+=item *
+
+C<ascending> - Order ascending if true, descending otherwise (default: true)
+
+=item *
+
+C<case> - If true, take case into account, otherwise ignore case (default: true)
+
+=item *
+
+C<collate> - If true, use B<Unicode::Collate> (if available), otherwise use perl built-ins (default: true)
+
+=item *
+
+Any B<Unicode::Collate> option is also supported.
+
+=back
+
+C<sort_by> and C<order_by> are aliases.
+
+B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See
+L</CAVEATS>.
+
+=head2 sort_by
+
+Alias for L</order_by>.
+
+=head2 norder_by
+
+ \&iterator = $iterator->nsort_by($field, %options);
+ \&iterator = $iterator->nsort_by(\&get_value, %options);
+
+Get a new iterator draining from an existing iterator but providing items sorted by an object field. Sorting
+is done numerically using C<< <=> >>. The C<\&get_value> subroutine or C<$field> accessor is called once for
+each item and should return a numerical value. Options:
+
+=over 4
+
+=item *
+
+C<ascending> - Order ascending if true, descending otherwise (default: true)
+
+=back
+
+C<nsort_by> and C<norder_by> are aliases.
+
+B<NOTE:> This method drains the iterator completely and places the sorted items onto the buffer. See
+L</CAVEATS>.
+
+=head2 nsort_by
+
+Alias for L</norder_by>.
+
+=head2 limit
+
+ \&iterator = $iterator->limit($count);
+
+Get a new iterator draining from an existing iterator but providing only a limited number of items.
+
+C<limit> as an alias for L<Iterator::Simple/"$iterator->head($count)">.
+
+=head2 to_array
+
+ \@array = $iterator->to_array;
+
+Get the rest of the items from an iterator as an arrayref.
+
+B<NOTE:> This method drains the iterator completely, leaving it empty. See L</CAVEATS>.
+
+=head2 count
+
+ $size = $iterator->count;
+
+Count the rest of the items from an iterator.
+
+B<NOTE:> This method drains the iterator completely but restores it to its pre-drained state. See L</CAVEATS>.
+
+=head2 size
+
+Alias for L</count>.
+
+=for Pod::Coverage TO_JSON
+
+=head1 CAVEATS
+
+Some methods attempt to drain the iterator completely before returning. For obvious reasons, this won't work
+for infinite iterators because your computer doesn't have infinite memory. This isn't a practical issue with
+B<File::KDBX> lists which are always finite -- unless you do something weird like force a child group to be
+its own ancestor -- but I'm noting it here as a potential issue if you use this iterator class for other
+things (which you probably shouldn't do).
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::KDF;
+# ABSTRACT: A key derivation function
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes);
+use File::KDBX::Constants qw(:version :kdf);
+use File::KDBX::Error;
+use File::KDBX::Util qw(format_uuid);
+use Module::Load;
+use Scalar::Util qw(blessed);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+my %KDFS;
+
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+
+ my $uuid = $args{+KDF_PARAM_UUID} //= delete $args{uuid} or throw 'Missing KDF UUID', args => \%args;
+ my $formatted_uuid = format_uuid($uuid);
+
+ my $kdf = $KDFS{$uuid} or throw "Unsupported KDF ($formatted_uuid)", uuid => $uuid;
+ ($class, my %registration_args) = @$kdf;
+
+ load $class;
+ my $self = bless {KDF_PARAM_UUID() => $uuid}, $class;
+ return $self->init(%args, %registration_args);
+}
+
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+
+sub uuid { $_[0]->{+KDF_PARAM_UUID} }
+
+
+sub seed { die 'Not implemented' }
+
+
+sub transform {
+ my $self = shift;
+ my $key = shift;
+
+ if (blessed $key && $key->can('raw_key')) {
+ return $self->_transform($key->raw_key) if $self->uuid eq KDF_UUID_AES;
+ return $self->_transform($key->raw_key($self->seed, @_));
+ }
+
+ return $self->_transform($key);
+}
+
+sub _transform { die 'Not implemented' }
+
+
+sub randomize_seed {
+ my $self = shift;
+ $self->{+KDF_PARAM_AES_SEED} = random_bytes(length($self->seed));
+}
+
+
+sub register {
+ my $class = shift;
+ my $id = shift;
+ my $package = shift;
+ my @args = @_;
+
+ my $formatted_id = format_uuid($id);
+ $package = "${class}::${package}" if $package !~ s/^\+// && $package !~ /^\Q${class}::\E/;
+
+ my %blacklist = map { File::KDBX::Util::uuid($_) => 1 } split(/,/, $ENV{FILE_KDBX_KDF_BLACKLIST} // '');
+ if ($blacklist{$id} || $blacklist{$package}) {
+ alert "Ignoring blacklisted KDF ($formatted_id)", id => $id, package => $package;
+ return;
+ }
+
+ if (defined $KDFS{$id}) {
+ alert "Overriding already-registered KDF ($formatted_id) with package $package",
+ id => $id,
+ package => $package;
+ }
+
+ $KDFS{$id} = [$package, @args];
+}
+
+
+sub unregister {
+ delete $KDFS{$_} for @_;
+}
+
+BEGIN {
+ __PACKAGE__->register(KDF_UUID_AES, 'AES');
+ __PACKAGE__->register(KDF_UUID_AES_CHALLENGE_RESPONSE, 'AES');
+ __PACKAGE__->register(KDF_UUID_ARGON2D, 'Argon2');
+ __PACKAGE__->register(KDF_UUID_ARGON2ID, 'Argon2');
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::KDF - A key derivation function
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+A KDF (key derivation function) is used in the transformation of a master key (i.e. one or more component
+keys) to produce the final encryption key protecting a KDBX database. The L<File::KDBX> distribution comes
+with several pre-registered KDFs ready to go:
+
+=over 4
+
+=item *
+
+C<C9D9F39A-628A-4460-BF74-0D08C18A4FEA> - AES
+
+=item *
+
+C<7C02BB82-79A7-4AC0-927D-114A00648238> - AES (challenge-response variant)
+
+=item *
+
+C<EF636DDF-8C29-444B-91F7-A9A403E30A0C> - Argon2d
+
+=item *
+
+C<9E298B19-56DB-4773-B23D-FC3EC6F0A1E6> - Argon2id
+
+=back
+
+B<NOTE:> If you want your KDBX file to be readable by other KeePass implementations, you must use a UUID and
+algorithm that they support. From the list above, all are well-supported except the AES challenge-response
+variant which is kind of a pseudo KDF and isn't usually written into files. All of these are good. AES has
+a longer track record, but Argon2 has better ASIC resistance.
+
+You can also L</register> your own KDF. Here is a skeleton:
+
+ package File::KDBX::KDF::MyKDF;
+
+ use parent 'File::KDBX::KDF';
+
+ File::KDBX::KDF->register(
+ # $uuid, $package, %args
+ "\x12\x34\x56\x78\x9a\xbc\xde\xfg\x12\x34\x56\x78\x9a\xbc\xde\xfg" => __PACKAGE__,
+ );
+
+ sub init { ... } # optional
+
+ sub _transform { my ($key) = @_; ... }
+
+=head1 ATTRIBUTES
+
+=head2 uuid
+
+ $uuid => $kdf->uuid;
+
+Get the UUID used to determine which function to use.
+
+=head2 seed
+
+ $seed = $kdf->seed;
+
+Get the seed (or salt, depending on the function).
+
+=head1 METHODS
+
+=head2 new
+
+ $kdf = File::KDBX::KDF->new(parameters => \%params);
+
+Construct a new KDF.
+
+=head2 init
+
+ $kdf = $kdf->init(%attributes);
+
+Called by method to set attributes. You normally shouldn't call this.
+
+=head2 transform
+
+ $transformed_key = $kdf->transform($key);
+ $transformed_key = $kdf->transform($key, $challenge);
+
+Transform a key. The input key can be either a L<File::KDBX::Key> or a raw binary key, and the
+transformed key will be a raw key.
+
+This can take awhile, depending on the KDF parameters.
+
+If a challenge is provided (and the KDF is AES except for the KeePassXC variant), it will be passed to the key
+so challenge-response keys can produce raw keys. See L<File::KDBX::Key/raw_key>.
+
+=head2 randomize_seed
+
+ $kdf->randomize_seed;
+
+Generate a new random seed/salt.
+
+=head2 register
+
+ File::KDBX::KDF->register($uuid => $package, %args);
+
+Register a KDF. Registered KDFs can be used to encrypt and decrypt KDBX databases. A KDF's UUID B<must> be
+unique and B<musn't change>. A KDF UUID is written into each KDBX file and the associated KDF must be
+registered with the same UUID in order to decrypt the KDBX file.
+
+C<$package> should be a Perl package relative to C<File::KDBX::KDF::> or prefixed with a C<+> if it is
+a fully-qualified package. C<%args> are passed as-is to the KDF's L</init> method.
+
+=head2 unregister
+
+ File::KDBX::KDF->unregister($uuid);
+
+Unregister a KDF. Unregistered KDFs can no longer be used to encrypt and decrypt KDBX databases, until
+reregistered (see L</register>).
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::KDF::AES;
+# ABSTRACT: Using the AES cipher as a key derivation function
+
+use warnings;
+use strict;
+
+use Crypt::Cipher;
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Constants qw(:bool :kdf);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :load can_fork);
+use namespace::clean;
+
+extends 'File::KDBX::KDF';
+
+our $VERSION = '0.800'; # VERSION
+
+# Rounds higher than this are eligible for forking:
+my $FORK_OPTIMIZATION_THRESHOLD = 100_000;
+
+BEGIN {
+ my $use_fork = $ENV{NO_FORK} || !can_fork;
+ *_USE_FORK = $use_fork ? \&TRUE : \&FALSE;
+}
+
+
+sub rounds { $_[0]->{+KDF_PARAM_AES_ROUNDS} || KDF_DEFAULT_AES_ROUNDS }
+sub seed { $_[0]->{+KDF_PARAM_AES_SEED} }
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+ return $self->SUPER::init(
+ KDF_PARAM_AES_ROUNDS() => $args{+KDF_PARAM_AES_ROUNDS} // $args{rounds},
+ KDF_PARAM_AES_SEED() => $args{+KDF_PARAM_AES_SEED} // $args{seed},
+ );
+}
+
+sub _transform {
+ my $self = shift;
+ my $key = shift;
+
+ my $seed = $self->seed;
+ my $rounds = $self->rounds;
+
+ length($key) == 32 or throw 'Raw key must be 32 bytes', size => length($key);
+ length($seed) == 32 or throw 'Invalid seed length', size => length($seed);
+
+ my ($key_l, $key_r) = unpack('(a16)2', $key);
+
+ goto NO_FORK if !_USE_FORK || $rounds < $FORK_OPTIMIZATION_THRESHOLD;
+ {
+ my $pid = open(my $read, '-|') // do { alert "fork failed: $!"; goto NO_FORK };
+ if ($pid == 0) { # child
+ my $l = _transform_half($seed, $key_l, $rounds);
+ require POSIX;
+ print $l or POSIX::_exit(1);
+ POSIX::_exit(0);
+ }
+ my $r = _transform_half($seed, $key_r, $rounds);
+ read($read, my $l, length($key_l)) == length($key_l) or do { alert "read failed: $!", goto NO_FORK };
+ close($read) or do { alert "worker thread exited abnormally", status => $?; goto NO_FORK };
+ return digest_data('SHA256', $l, $r);
+ }
+
+ # FIXME: This used to work but now it crashes frequently. Threads are now discouraged anyway, but it might
+ # be nice if this was available for no-fork platforms.
+ # if ($ENV{THREADS} && eval 'use threads; 1') {
+ # my $l = threads->create(\&_transform_half, $key_l, $seed, $rounds);
+ # my $r = _transform_half($key_r, $seed, $rounds);
+ # return digest_data('SHA256', $l->join, $r);
+ # }
+
+ NO_FORK:
+ my $l = _transform_half($seed, $key_l, $rounds);
+ my $r = _transform_half($seed, $key_r, $rounds);
+ return digest_data('SHA256', $l, $r);
+}
+
+sub _transform_half_pp {
+ my $seed = shift;
+ my $key = shift;
+ my $rounds = shift;
+
+ my $c = Crypt::Cipher->new('AES', $seed);
+
+ my $result = $key;
+ for (my $i = 0; $i < $rounds; ++$i) {
+ $result = $c->encrypt($result);
+ }
+
+ return $result;
+}
+
+BEGIN {
+ my $use_xs = load_xs;
+ *_transform_half = $use_xs ? \&File::KDBX::XS::kdf_aes_transform_half : \&_transform_half_pp;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::KDF::AES - Using the AES cipher as a key derivation function
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+An AES-256-based key derivation function. This is a L<File::KDBX::KDF> subclass.
+
+This KDF has a long, solid track record. It is supported in both KDBX3 and KDBX4.
+
+=head1 ATTRIBUTES
+
+=head2 rounds
+
+ $rounds = $kdf->rounds;
+
+Get the number of times to run the function during transformation.
+
+=head1 CAVEATS
+
+This module can be pretty slow when the number of rounds is high. If you have L<File::KDBX::XS>, that will
+help. If your perl has C<fork>, that will also help. If you need to turn off one or both of these
+optimizations for some reason, set the C<PERL_ONLY> (to prevent Loading C<File::KDBX::XS>) and C<NO_FORK>
+environment variables.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::KDF::Argon2;
+# ABSTRACT: The Argon2 family of key derivation functions
+
+use warnings;
+use strict;
+
+use Crypt::Argon2 qw(argon2d_raw argon2id_raw);
+use File::KDBX::Constants qw(:kdf);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class);
+use namespace::clean;
+
+extends 'File::KDBX::KDF';
+
+our $VERSION = '0.800'; # VERSION
+
+
+sub salt { $_[0]->{+KDF_PARAM_ARGON2_SALT} or throw 'Salt is not set' }
+sub seed { $_[0]->salt }
+sub parallelism { $_[0]->{+KDF_PARAM_ARGON2_PARALLELISM} //= KDF_DEFAULT_ARGON2_PARALLELISM }
+sub memory { $_[0]->{+KDF_PARAM_ARGON2_MEMORY} //= KDF_DEFAULT_ARGON2_MEMORY }
+sub iterations { $_[0]->{+KDF_PARAM_ARGON2_ITERATIONS} //= KDF_DEFAULT_ARGON2_ITERATIONS }
+sub version { $_[0]->{+KDF_PARAM_ARGON2_VERSION} //= KDF_DEFAULT_ARGON2_VERSION }
+sub secret { $_[0]->{+KDF_PARAM_ARGON2_SECRET} }
+sub assocdata { $_[0]->{+KDF_PARAM_ARGON2_ASSOCDATA} }
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+ return $self->SUPER::init(
+ KDF_PARAM_ARGON2_SALT() => $args{+KDF_PARAM_ARGON2_SALT} // $args{salt},
+ KDF_PARAM_ARGON2_PARALLELISM() => $args{+KDF_PARAM_ARGON2_PARALLELISM} // $args{parallelism},
+ KDF_PARAM_ARGON2_MEMORY() => $args{+KDF_PARAM_ARGON2_MEMORY} // $args{memory},
+ KDF_PARAM_ARGON2_ITERATIONS() => $args{+KDF_PARAM_ARGON2_ITERATIONS} // $args{iterations},
+ KDF_PARAM_ARGON2_VERSION() => $args{+KDF_PARAM_ARGON2_VERSION} // $args{version},
+ KDF_PARAM_ARGON2_SECRET() => $args{+KDF_PARAM_ARGON2_SECRET} // $args{secret},
+ KDF_PARAM_ARGON2_ASSOCDATA() => $args{+KDF_PARAM_ARGON2_ASSOCDATA} // $args{assocdata},
+ );
+}
+
+sub _transform {
+ my $self = shift;
+ my $key = shift;
+
+ my ($uuid, $salt, $iterations, $memory, $parallelism)
+ = ($self->uuid, $self->salt, $self->iterations, $self->memory, $self->parallelism);
+
+ if ($uuid eq KDF_UUID_ARGON2D) {
+ return argon2d_raw($key, $salt, $iterations, $memory, $parallelism, length($salt));
+ }
+ elsif ($uuid eq KDF_UUID_ARGON2ID) {
+ return argon2id_raw($key, $salt, $iterations, $memory, $parallelism, length($salt));
+ }
+
+ throw 'Unknown Argon2 type', uuid => $uuid;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::KDF::Argon2 - The Argon2 family of key derivation functions
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+An Argon2 key derivation function. This is a L<File::KDBX::KDF> subclass.
+
+This KDF allows for excellent resistance to ASIC password cracking. It's a solid choice but doesn't have the
+track record of L<File::KDBX::KDF::AES> and requires using the KDBX4+ file format.
+
+=head1 ATTRIBUTES
+
+=head2 salt
+
+=head2 parallelism
+
+=head2 memory
+
+=head2 iterations
+
+=head2 version
+
+=head2 secret
+
+=head2 assocdata
+
+Get various KDF parameters.
+
+C<version>, C<secret> and C<assocdata> are currently unused.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Key;
+# ABSTRACT: A credential that can protect a KDBX file
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Error;
+use File::KDBX::Safe;
+use File::KDBX::Util qw(erase);
+use Hash::Util::FieldHash qw(fieldhashes);
+use Module::Load;
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_scalarref);
+use Scalar::Util qw(blessed openhandle);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+fieldhashes \my %SAFE;
+
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 1 ? (primitive => shift, @_) : @_;
+
+ my $primitive = $args{primitive};
+ delete $args{primitive} if !$args{keep_primitive};
+ return $primitive->hide if blessed $primitive && $primitive->isa($class);
+
+ my $self = bless \%args, $class;
+ return $self->init($primitive) if defined $primitive;
+ return $self;
+}
+
+sub DESTROY {
+ local ($., $@, $!, $^E, $?);
+ !in_global_destruction and do { $_[0]->_clear_raw_key; eval { erase \$_[0]->{primitive} } }
+}
+
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ my $pkg;
+
+ if (is_arrayref($primitive)) {
+ $pkg = __PACKAGE__.'::Composite';
+ }
+ elsif (is_scalarref($primitive) || openhandle($primitive)) {
+ $pkg = __PACKAGE__.'::File';
+ }
+ elsif (is_coderef($primitive)) {
+ $pkg = __PACKAGE__.'::ChallengeResponse';
+ }
+ elsif (!is_ref($primitive)) {
+ $pkg = __PACKAGE__.'::Password';
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{composite}) {
+ $pkg = __PACKAGE__.'::Composite';
+ $primitive = $primitive->{composite};
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{password}) {
+ $pkg = __PACKAGE__.'::Password';
+ $primitive = $primitive->{password};
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{file}) {
+ $pkg = __PACKAGE__.'::File';
+ $primitive = $primitive->{file};
+ }
+ elsif (is_hashref($primitive) && defined $primitive->{responder}) {
+ $pkg = __PACKAGE__.'::ChallengeResponse';
+ $primitive = $primitive->{responder};
+ }
+ else {
+ throw 'Invalid key primitive', primitive => $primitive;
+ }
+
+ load $pkg;
+ bless $self, $pkg;
+ return $self->init($primitive);
+}
+
+
+sub reload { $_[0] }
+
+
+sub raw_key {
+ my $self = shift;
+ return $self->{raw_key} if !$self->is_hidden;
+ return $self->_safe->peek(\$self->{raw_key});
+}
+
+sub _set_raw_key {
+ my $self = shift;
+ $self->_clear_raw_key;
+ $self->{raw_key} = shift; # after clear
+ $self->_new_safe->add(\$self->{raw_key}); # auto-hide
+}
+
+sub _clear_raw_key {
+ my $self = shift;
+ my $safe = $self->_safe;
+ $safe->clear if $safe;
+ erase \$self->{raw_key};
+}
+
+
+sub hide {
+ my $self = shift;
+ $self->_new_safe->add(\$self->{raw_key}) if defined $self->{raw_key};
+ return $self;
+}
+
+
+sub show {
+ my $self = shift;
+ my $safe = $self->_safe;
+ $safe->unlock if $safe;
+ return $self;
+}
+
+
+sub is_hidden { !!$SAFE{$_[0]} }
+
+sub _safe { $SAFE{$_[0]} }
+sub _new_safe { $SAFE{$_[0]} = File::KDBX::Safe->new }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Key - A credential that can protect a KDBX file
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+A master key is one or more credentials that can protect a KDBX database. When you encrypt a database with
+a master key, you will need the master key to decrypt it. B<Keep your master key safe!> If someone gains
+access to your master key, they can open your database. If you forget or lose any part of your master key, all
+data in the database is lost.
+
+There are several different types of keys, each implemented as a subclass:
+
+=over 4
+
+=item *
+
+L<File::KDBX::Key::Password> - Password or passphrase, knowledge of a string of characters
+
+=item *
+
+L<File::KDBX::Key::File> - Possession of a file ("key file") with a secret.
+
+=item *
+
+L<File::KDBX::Key::ChallengeResponse> - Possession of a device that responds correctly when challenged
+
+=item *
+
+L<File::KDBX::Key::YubiKey> - Possession of a YubiKey hardware device (a type of challenge-response)
+
+=item *
+
+L<File::KDBX::Key::Composite> - One or more keys combined as one
+
+=back
+
+A good master key is produced from a high amount of "entropy" (unpredictability). The more entropy the better.
+Combining multiple keys into a B<Composite> key combines the entropy of each individual key. For example, if
+you have a weak password and you combine it with other keys, the composite key is stronger than the weak
+password key by itself. (Of course it's much better to not have any weak components of your master key.)
+
+B<COMPATIBILITY NOTE:> Most KeePass implementations are limited in the types and numbers of keys they support.
+B<Password> keys are pretty much universally supported. B<File> keys are pretty well-supported. Many do not
+support challenge-response keys. If you are concerned about compatibility, you should stick with one of these
+configurations:
+
+=over 4
+
+=item *
+
+One password
+
+=item *
+
+One key file
+
+=item *
+
+One password and one key file
+
+=back
+
+=head1 METHODS
+
+=head2 new
+
+ $key = File::KDBX::Key->new({ password => $password });
+ $key = File::KDBX::Key->new($password);
+
+ $key = File::KDBX::Key->new({ file => $filepath });
+ $key = File::KDBX::Key->new(\$file);
+ $key = File::KDBX::Key->new(\*FILE);
+
+ $key = File::KDBX::Key->new({ composite => [...] });
+ $key = File::KDBX::Key->new([...]); # composite key
+
+ $key = File::KDBX::Key->new({ responder => \&responder });
+ $key = File::KDBX::Key->new(\&responder); # challenge-response key
+
+Construct a new key.
+
+The primitive used to construct the key is not saved but is immediately converted to a raw encryption key (see
+L</raw_key>).
+
+A L<File::KDBX::Key::Composite> is somewhat special in that it does retain a reference to its component keys,
+and its raw key is calculated from its components on demand.
+
+=head2 init
+
+ $key = $key->init($primitive);
+
+Initialize a L<File::KDBX::Key> with a new primitive. Returns itself to allow method chaining.
+
+=head2 reload
+
+ $key = $key->reload;
+
+Reload a key by re-reading the key source and recalculating the raw key. Returns itself to allow method
+chaining.
+
+=head2 raw_key
+
+ $raw_key = $key->raw_key;
+ $raw_key = $key->raw_key($challenge);
+
+Get the raw encryption key. This is calculated based on the primitive(s). The C<$challenge> argument is for
+challenge-response type keys and is ignored by other types.
+
+B<NOTE:> The raw key is sensitive information and so is memory-protected while not being accessed. If you
+access it, you should memzero or L<File::KDBX::Util/erase> it when you're done.
+
+=head2 hide
+
+ $key = $key->hide;
+
+Put the raw key in L<File::KDBX/"Memory Protection">. Does nothing if the raw key is already in memory
+protection. Returns itself to allow method chaining.
+
+=head2 show
+
+ $key = $key->show;
+
+Bring the raw key out of memory protection. Does nothing if the raw key is already out of memory protection.
+Returns itself to allow method chaining.
+
+=head2 is_hidden
+
+ $bool = $key->is_hidden;
+
+Get whether or not the key's raw secret is currently in memory protection.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Key::ChallengeResponse;
+# ABSTRACT: A challenge-response key
+
+use warnings;
+use strict;
+
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class);
+use namespace::clean;
+
+extends 'File::KDBX::Key';
+
+our $VERSION = '0.800'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift or throw 'Missing key primitive';
+
+ $self->{responder} = $primitive;
+
+ return $self->hide;
+}
+
+
+sub raw_key {
+ my $self = shift;
+ if (@_) {
+ my $challenge = shift // '';
+ # Don't challenge if we already have the response.
+ return $self->SUPER::raw_key if $challenge eq ($self->{challenge} // '');
+ $self->_set_raw_key($self->challenge($challenge, @_));
+ $self->{challenge} = $challenge;
+ }
+ $self->SUPER::raw_key;
+}
+
+
+sub challenge {
+ my $self = shift;
+
+ my $responder = $self->{responder} or throw 'Cannot issue challenge without a responder';
+ return $responder->(@_);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Key::ChallengeResponse - A challenge-response key
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Key::ChallengeResponse;
+
+ my $responder = sub {
+ my $challenge = shift;
+ ...; # generate a response based on a secret of some sort
+ return $response;
+ };
+ my $key = File::KDBX::Key::ChallengeResponse->new($responder);
+
+=head1 DESCRIPTION
+
+A challenge-response key is kind of like multifactor authentication, except you don't really I<authenticate>
+to a KDBX database because it's not a service. Specifically it would be the "what you have" component. It
+assumes there is some device that can store a key that is only known to the unlocker of a database.
+A challenge is made to the device and the response generated based on the key is used as the raw key.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+This is a generic implementation where a responder subroutine is provided to provide the response. There is
+also L<File::KDBX::Key::YubiKey> which is a subclass that allows YubiKeys to be responder devices.
+
+=head1 METHODS
+
+=head2 raw_key
+
+ $raw_key = $key->raw_key;
+ $raw_key = $key->raw_key($challenge);
+
+Get the raw key which is the response to a challenge. The response will be saved so that subsequent calls
+(with or without the challenge) can provide the response without challenging the responder again. Only once
+response is saved at a time; if you call this with a different challenge, the new response is saved over any
+previous response.
+
+=head2 challenge
+
+ $response = $key->challenge($challenge, @options);
+
+Issue a challenge and get a response, or throw if the responder failed to provide one.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Key::Composite;
+# ABSTRACT: A composite key made up of component keys
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :erase);
+use Ref::Util qw(is_arrayref);
+use Scalar::Util qw(blessed);
+use namespace::clean;
+
+extends 'File::KDBX::Key';
+
+our $VERSION = '0.800'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ my @primitive = grep { defined } is_arrayref($primitive) ? @$primitive : $primitive;
+ @primitive or throw 'Composite key must have at least one component key', count => scalar @primitive;
+
+ my @keys = map { blessed $_ && $_->can('raw_key') ? $_ : File::KDBX::Key->new($_,
+ keep_primitive => $self->{keep_primitive}) } @primitive;
+ $self->{keys} = \@keys;
+
+ return $self->hide;
+}
+
+
+sub raw_key {
+ my $self = shift;
+ my $challenge = shift;
+
+ my @keys = @{$self->keys} or throw 'Cannot generate a raw key from an empty composite key';
+
+ my @basic_keys = map { $_->raw_key } grep { !$_->can('challenge') } @keys;
+ my $response;
+ $response = $self->challenge($challenge, @_) if defined $challenge;
+ my $cleanup = erase_scoped \@basic_keys, $response;
+
+ return digest_data('SHA256',
+ @basic_keys,
+ defined $response ? $response : (),
+ );
+}
+
+
+sub keys {
+ my $self = shift;
+ $self->{keys} = shift if @_;
+ return $self->{keys} ||= [];
+}
+
+
+sub challenge {
+ my $self = shift;
+
+ my @chalresp_keys = grep { $_->can('challenge') } @{$self->keys} or return '';
+
+ my @responses = map { $_->challenge(@_) } @chalresp_keys;
+ my $cleanup = erase_scoped \@responses;
+
+ return digest_data('SHA256', @responses);
+}
+
+sub hide {
+ my $self = shift;
+ $_->hide for @{$self->keys};
+ return $self;
+}
+
+sub show {
+ my $self = shift;
+ $_->show for @{$self->keys};
+ return $self;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Key::Composite - A composite key made up of component keys
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Key::Composite;
+
+ my $key = File::KDBX::Key::Composite->(\@component_keys);
+
+=head1 DESCRIPTION
+
+A composite key is a collection of other keys. A master key capable of unlocking a KDBX database is always
+a composite key, even if it only has a single component.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+=head1 ATTRIBUTES
+
+=head2 keys
+
+ \@keys = $key->keys;
+
+Get one or more component L<File::KDBX::Key>.
+
+=head1 METHODS
+
+=head2 raw_key
+
+ $raw_key = $key->raw_key;
+ $raw_key = $key->raw_key($challenge);
+
+Get the raw key from each component key and return a generated composite raw key.
+
+=head2 challenge
+
+ $response = $key->challenge(...);
+
+Issues a challenge to any L<File::KDBX::Key::ChallengeResponse> components keys. Arguments are passed through
+to each component key. The responses are hashed together and the composite response is returned.
+
+Returns empty string if there are no challenge-response components keys.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Key::File;
+# ABSTRACT: A file key
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use Crypt::PRNG qw(random_bytes);
+use File::KDBX::Constants qw(:key_file);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :erase trim);
+use Ref::Util qw(is_ref is_scalarref);
+use Scalar::Util qw(openhandle);
+use XML::LibXML::Reader;
+use namespace::clean;
+
+extends 'File::KDBX::Key';
+
+our $VERSION = '0.800'; # VERSION
+
+
+has 'type', is => 'ro';
+has 'version', is => 'ro';
+has 'filepath', is => 'ro';
+
+
+sub init { shift->load(@_) }
+
+sub load {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ my $data;
+ my $cleanup;
+
+ if (openhandle($primitive)) {
+ seek $primitive, 0, 0; # not using ->seek method so it works on perl 5.10
+ my $buf = do { local $/; <$primitive> };
+ $data = \$buf;
+ $cleanup = erase_scoped $data;
+ }
+ elsif (is_scalarref($primitive)) {
+ $data = $primitive;
+ }
+ elsif (defined $primitive && !is_ref($primitive)) {
+ open(my $fh, '<:raw', $primitive)
+ or throw "Failed to open key file ($primitive)", filepath => $primitive;
+ my $buf = do { local $/; <$fh> };
+ $data = \$buf;
+ $cleanup = erase_scoped $data;
+ $self->{filepath} = $primitive;
+ }
+ else {
+ throw 'Unexpected primitive type', type => ref $primitive;
+ }
+
+ my $raw_key;
+ if (substr($$data, 0, 120) =~ /<KeyFile>/
+ and my ($type, $version) = $self->_load_xml($data, \$raw_key)) {
+ $self->{type} = $type;
+ $self->{version} = $version;
+ $self->_set_raw_key($raw_key);
+ }
+ elsif (length($$data) == 32) {
+ $self->{type} = KEY_FILE_TYPE_BINARY;
+ $self->_set_raw_key($$data);
+ }
+ elsif ($$data =~ /^[A-Fa-f0-9]{64}$/) {
+ $self->{type} = KEY_FILE_TYPE_HEX;
+ $self->_set_raw_key(pack('H64', $$data));
+ }
+ else {
+ $self->{type} = KEY_FILE_TYPE_HASHED;
+ $self->_set_raw_key(digest_data('SHA256', $$data));
+ }
+
+ return $self->hide;
+}
+
+
+sub reload {
+ my $self = shift;
+ $self->init($self->{filepath}) if defined $self->{filepath};
+ return $self;
+}
+
+
+sub save {
+ my $self = shift;
+ my %args = @_;
+
+ my @cleanup;
+ my $raw_key = $args{raw_key} // $self->raw_key // random_bytes(32);
+ push @cleanup, erase_scoped $raw_key;
+ length($raw_key) == 32 or throw 'Raw key must be exactly 256 bits (32 bytes)', length => length($raw_key);
+
+ my $type = $args{type} // $self->type // KEY_FILE_TYPE_XML;
+ my $version = $args{version} // $self->version // 2;
+ my $filepath = $args{filepath} // $self->filepath;
+ my $fh = $args{fh};
+
+ my $filepath_temp;
+ if (!openhandle($fh)) {
+ $filepath or throw 'Must specify where to safe the key file to';
+
+ require File::Temp;
+ ($fh, $filepath_temp) = eval { File::Temp::tempfile("${filepath}-XXXXXX", CLEANUP => 1) };
+ if (!$fh or my $err = $@) {
+ $err //= 'Unknown error';
+ throw sprintf('Open file failed (%s): %s', $filepath_temp, $err),
+ error => $err,
+ filepath => $filepath_temp;
+ }
+ }
+
+ if ($type == KEY_FILE_TYPE_XML) {
+ $self->_save_xml($fh, $raw_key, $version);
+ }
+ elsif ($type == KEY_FILE_TYPE_BINARY) {
+ print $fh $raw_key;
+ }
+ elsif ($type == KEY_FILE_TYPE_HEX) {
+ my $hex = uc(unpack('H*', $raw_key));
+ push @cleanup, erase_scoped $hex;
+ print $fh $hex;
+ }
+ else {
+ throw "Cannot save $type key file (invalid type)", type => $type;
+ }
+
+ close($fh);
+
+ if ($filepath_temp) {
+ my ($file_mode, $file_uid, $file_gid) = (stat($filepath))[2, 4, 5];
+
+ my $mode = $args{mode} // $file_mode // do { my $m = umask; defined $m ? oct(666) &~ $m : undef };
+ my $uid = $args{uid} // $file_uid // -1;
+ my $gid = $args{gid} // $file_gid // -1;
+ chmod($mode, $filepath_temp) if defined $mode;
+ chown($uid, $gid, $filepath_temp);
+ rename($filepath_temp, $filepath)
+ or throw "Failed to write file ($filepath): $!", filepath => $filepath;
+ }
+}
+
+##############################################################################
+
+sub _load_xml {
+ my $self = shift;
+ my $buf = shift;
+ my $out = shift;
+
+ my ($version, $hash, $data);
+
+ my $reader = XML::LibXML::Reader->new(string => $$buf);
+ my $pattern = XML::LibXML::Pattern->new('/KeyFile/Meta/Version|/KeyFile/Key/Data');
+
+ while ($reader->nextPatternMatch($pattern) == 1) {
+ next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
+ my $name = $reader->localName;
+ if ($name eq 'Version') {
+ $reader->read if !$reader->isEmptyElement;
+ $reader->nodeType == XML_READER_TYPE_TEXT
+ or alert 'Expected text node with version', line => $reader->lineNumber;
+ my $val = trim($reader->value);
+ defined $version
+ and alert 'Overwriting version', previous => $version, new => $val, line => $reader->lineNumber;
+ $version = $val;
+ }
+ elsif ($name eq 'Data') {
+ $hash = trim($reader->getAttribute('Hash')) if $reader->hasAttributes;
+ $reader->read if !$reader->isEmptyElement;
+ $reader->nodeType == XML_READER_TYPE_TEXT
+ or alert 'Expected text node with data', line => $reader->lineNumber;
+ $data = $reader->value;
+ $data =~ s/\s+//g if defined $data;
+ }
+ }
+
+ return if !defined $version || !defined $data;
+
+ if ($version =~ /^1\.0/ && $data =~ /^[A-Za-z0-9+\/=]+$/) {
+ $$out = eval { decode_b64($data) };
+ if (my $err = $@) {
+ throw 'Failed to decode key in key file', version => $version, data => $data, error => $err;
+ }
+ return (KEY_FILE_TYPE_XML, $version);
+ }
+ elsif ($version =~ /^2\.0/ && $data =~ /^[A-Fa-f0-9]+$/ && defined $hash && $hash =~ /^[A-Fa-f0-9]+$/) {
+ $$out = pack('H*', $data);
+ $hash = pack('H*', $hash);
+ my $got_hash = digest_data('SHA256', $$out);
+ $hash eq substr($got_hash, 0, length($hash))
+ or throw 'Checksum mismatch', got => $got_hash, expected => $hash;
+ return (KEY_FILE_TYPE_XML, $version);
+ }
+
+ throw 'Unexpected data in key file', version => $version, data => $data;
+}
+
+sub _save_xml {
+ my $self = shift;
+ my $fh = shift;
+ my $raw_key = shift;
+ my $version = shift // 2;
+
+ my @cleanup;
+
+ my $dom = XML::LibXML::Document->new('1.0', 'UTF-8');
+ my $doc = XML::LibXML::Element->new('KeyFile');
+ $dom->setDocumentElement($doc);
+ my $meta_node = XML::LibXML::Element->new('Meta');
+ $doc->appendChild($meta_node);
+ my $version_node = XML::LibXML::Element->new('Version');
+ $version_node->appendText(sprintf('%.1f', $version));
+ $meta_node->appendChild($version_node);
+ my $key_node = XML::LibXML::Element->new('Key');
+ $doc->appendChild($key_node);
+ my $data_node = XML::LibXML::Element->new('Data');
+ $key_node->appendChild($data_node);
+
+ if (int($version) == 1) {
+ my $b64 = encode_b64($raw_key);
+ push @cleanup, erase_scoped $b64;
+ $data_node->appendText($b64);
+ }
+ elsif (int($version) == 2) {
+ my @hex = unpack('(H8)8', $raw_key);
+ my $hex = uc(sprintf("\n %s\n %s\n ", join(' ', @hex[0..3]), join(' ', @hex[4..7])));
+ push @cleanup, erase_scoped $hex, @hex;
+ $data_node->appendText($hex);
+ my $hash = digest_data('SHA256', $raw_key);
+ substr($hash, 4) = '';
+ $hash = uc(unpack('H*', $hash));
+ $data_node->setAttribute('Hash', $hash);
+ }
+ else {
+ throw 'Failed to save unsupported key file version', version => $version;
+ }
+
+ $dom->toFH($fh, 1);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Key::File - A file key
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Constants qw(:key_file);
+ use File::KDBX::Key::File;
+
+ ### Create a key file:
+
+ my $key = File::KDBX::Key::File->new(
+ filepath => 'path/to/file.keyx',
+ type => KEY_FILE_TYPE_XML, # optional
+ version => 2, # optional
+ raw_key => $raw_key, # optional - leave undefined to generate a random key
+ );
+ $key->save;
+
+ ### Use a key file:
+
+ my $key2 = File::KDBX::Key::File->new('path/to/file.keyx');
+ # OR
+ my $key2 = File::KDBX::Key::File->new(\$secret);
+ # OR
+ my $key2 = File::KDBX::Key::File->new($fh); # or *IO
+
+=head1 DESCRIPTION
+
+A file key (or "key file") is the type of key where the secret is a file. The secret is either the file
+contents or is generated based on the file contents. In order to lock and unlock a KDBX database with a key
+file, the same file must be presented. The database cannot be opened without the file.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+There are multiple types of key files supported. See L</type>. This module can read and write key files.
+
+=head1 ATTRIBUTES
+
+=head2 type
+
+ $type = $key->type;
+
+Get the type of key file. Can be one of:
+
+=over 4
+
+=item *
+
+C<KEY_FILE_TYPE_BINARY>
+
+=item *
+
+C<KEY_FILE_TYPE_HEX>
+
+=item *
+
+C<KEY_FILE_TYPE_XML>
+
+=item *
+
+C<KEY_FILE_TYPE_HASHED>
+
+=back
+
+=head2 version
+
+ $version = $key->version;
+
+Get the file version. Only applies to XML key files.
+
+=head2 filepath
+
+ $filepath = $key->filepath;
+
+Get the filepath to the key file, if known.
+
+=head1 METHODS
+
+=head2 load
+
+ $key = $key->load($filepath);
+ $key = $key->load(\$string);
+ $key = $key->load($fh);
+ $key = $key->load(*IO);
+
+Load a key file.
+
+=head2 reload
+
+ $key->reload;
+
+Re-read the key file, if possible, and update the raw key if the key changed.
+
+=head2 save
+
+ $key->save;
+ $key->save(%options);
+
+Write a key file. Available options:
+
+=over 4
+
+=item *
+
+C<type> - Type of key file (default: value of L</type>, or C<KEY_FILE_TYPE_XML>)
+
+=item *
+
+C<verson> - Version of key file (default: value of L</version>, or 2)
+
+=item *
+
+C<filepath> - Where to save the file (default: value of L</filepath>)
+
+=item *
+
+C<fh> - IO handle to write to (overrides C<filepath>, one of which must be defined)
+
+=item *
+
+C<raw_key> - Raw key (default: value of L</raw_key>)
+
+=back
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Key::Password;
+# ABSTRACT: A password key
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Encode qw(encode);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class erase);
+use namespace::clean;
+
+extends 'File::KDBX::Key';
+
+our $VERSION = '0.800'; # VERSION
+
+sub init {
+ my $self = shift;
+ my $primitive = shift // throw 'Missing key primitive';
+
+ $self->_set_raw_key(digest_data('SHA256', encode('UTF-8', $primitive)));
+
+ return $self->hide;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Key::Password - A password key
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Key::Password;
+
+ my $key = File::KDBX::Key::Password->new($password);
+
+=head1 DESCRIPTION
+
+A password key is as simple as it sounds. It's just a password or passphrase.
+
+Inherets methods and attributes from L<File::KDBX::Key>.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Key::YubiKey;
+# ABSTRACT: A Yubico challenge-response key
+
+use warnings;
+use strict;
+
+use File::KDBX::Constants qw(:yubikey);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :io pad_pkcs7);
+use IPC::Cmd 0.52 qw(run_forked);
+use Ref::Util qw(is_arrayref);
+use Symbol qw(gensym);
+use namespace::clean;
+
+extends 'File::KDBX::Key::ChallengeResponse';
+
+our $VERSION = '0.800'; # VERSION
+
+# It can take some time for the USB device to be ready again, so we can retry a few times.
+our $RETRY_COUNT = 5;
+our $RETRY_INTERVAL = 0.1;
+
+my @CONFIG_VALID = (0, CONFIG1_VALID, CONFIG2_VALID);
+my @CONFIG_TOUCH = (0, CONFIG1_TOUCH, CONFIG2_TOUCH);
+
+sub challenge {
+ my $self = shift;
+ my $challenge = shift;
+ my %args = @_;
+
+ my $device = $args{device} // $self->device;
+ my $slot = $args{slot} // $self->slot;
+ my $timeout = $args{timeout} // $self->timeout;
+ local $self->{device} = $device;
+ local $self->{slot} = $slot;
+ local $self->{timeout} = $timeout;
+
+ my $hooks = $challenge ne 'test';
+ if ($hooks and my $hook = $self->{pre_challenge}) {
+ $hook->($self, $challenge);
+ }
+
+ my @cmd = ($self->_program('ykchalresp'), "-n$device", "-$slot", qw{-H -i-}, $timeout == 0 ? '-N' : ());
+
+ my $r;
+ my $try = 0;
+ TRY:
+ {
+ $r = $self->_run_ykpers(\@cmd, {
+ (0 < $timeout ? (timeout => $timeout) : ()),
+ child_stdin => pad_pkcs7($challenge, 64),
+ terminate_on_parent_sudden_death => 1,
+ });
+
+ if (my $t = $r->{timeout}) {
+ throw 'Timed out while waiting for challenge response',
+ command => \@cmd,
+ challenge => $challenge,
+ timeout => $t,
+ result => $r;
+ }
+
+ my $exit_code = $r->{exit_code};
+ if ($exit_code != 0) {
+ my $err = $r->{stderr};
+ chomp $err;
+ my $yk_errno = _yk_errno($err);
+ if ($yk_errno == YK_EUSBERR && $err =~ /resource busy/i && ++$try <= $RETRY_COUNT) {
+ sleep $RETRY_INTERVAL;
+ goto TRY;
+ }
+ throw 'Failed to receive challenge response: ' . ($err ? $err : 'Something happened'),
+ error => $err,
+ yk_errno => $yk_errno || 0;
+ }
+ }
+
+ my $resp = $r->{stdout};
+ chomp $resp;
+ $resp =~ /^[A-Fa-f0-9]+$/ or throw 'Unexpected response from challenge', response => $resp, result => $r;
+ $resp = pack('H*', $resp);
+
+ # HMAC-SHA1 response is only 20 bytes
+ substr($resp, 20) = '';
+
+ if ($hooks and my $hook = $self->{post_challenge}) {
+ $hook->($self, $challenge, $resp);
+ }
+
+ return $resp;
+}
+
+
+sub scan {
+ my $self = shift;
+ my %args = @_;
+
+ my $limit = delete $args{limit} // 4;
+
+ my @keys;
+ for (my $device = 0; $device < $limit; ++$device) {
+ my %info = $self->_get_yubikey_info($device) or last;
+
+ for (my $slot = 1; $slot <= 2; ++$slot) {
+ my $config = $CONFIG_VALID[$slot] // next;
+ next unless $info{touch_level} & $config;
+
+ my $key = $self->new(%args, device => $device, slot => $slot, %info);
+ if ($info{product_id} <= NEO_OTP_U2F_CCID_PID) {
+ # NEO and earlier always require touch, so forego testing
+ $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
+ push @keys, $key;
+ }
+ else {
+ eval { $key->challenge('test', timeout => 0) };
+ if (my $err = $@) {
+ my $yk_errno = ref $err && $err->details->{yk_errno} || 0;
+ if ($yk_errno == YK_EWOULDBLOCK) {
+ $key->touch_level($info{touch_level} | $CONFIG_TOUCH[$slot]);
+ }
+ elsif ($yk_errno != 0) {
+ # alert $err;
+ next;
+ }
+ }
+ push @keys, $key;
+ }
+ }
+ }
+
+ return @keys;
+}
+
+
+has device => 0;
+has slot => 1;
+has timeout => 10;
+has pre_challenge => undef;
+has post_challenge => undef;
+has ykchalresp => sub { $ENV{YKCHALRESP} || 'ykchalresp' };
+has ykinfo => sub { $ENV{YKINFO} || 'ykinfo' };
+
+
+has serial => sub { $_[0]->_set_yubikey_info; $_[0]->{serial} };
+has version => sub { $_[0]->_set_yubikey_info; $_[0]->{version} };
+has touch_level => sub { $_[0]->_set_yubikey_info; $_[0]->{touch_level} };
+has vendor_id => sub { $_[0]->_set_yubikey_info; $_[0]->{vendor_id} };
+has product_id => sub { $_[0]->_set_yubikey_info; $_[0]->{product_id} };
+
+
+sub name {
+ my $self = shift;
+ my $name = _product_name($self->vendor_id, $self->product_id // return);
+ my $serial = $self->serial;
+ my $version = $self->version || '?';
+ my $slot = $self->slot;
+ my $touch = $self->requires_interaction ? ' - Interaction required' : '';
+ return sprintf('%s v%s [%d] (slot #%d)', $name, $version, $serial, $slot);
+}
+
+
+sub requires_interaction {
+ my $self = shift;
+ my $touch = $self->touch_level // return;
+ return $touch & $CONFIG_TOUCH[$self->slot];
+}
+
+##############################################################################
+
+### Call ykinfo to get some information about a YubiKey
+sub _get_yubikey_info {
+ my $self = shift;
+ my $device = shift;
+
+ my $timeout = $self->timeout;
+ my @cmd = ($self->_program('ykinfo'), "-n$device", qw{-a});
+
+ my $r;
+ my $try = 0;
+ TRY:
+ {
+ $r = $self->_run_ykpers(\@cmd, {
+ (0 < $timeout ? (timeout => $timeout) : ()),
+ terminate_on_parent_sudden_death => 1,
+ });
+
+ my $exit_code = $r->{exit_code};
+ if ($exit_code != 0) {
+ my $err = $r->{stderr};
+ chomp $err;
+ my $yk_errno = _yk_errno($err);
+ return if $yk_errno == YK_ENOKEY;
+ if ($yk_errno == YK_EWOULDBLOCK && ++$try <= $RETRY_COUNT) {
+ sleep $RETRY_INTERVAL;
+ goto TRY;
+ }
+ alert 'Failed to get YubiKey device info: ' . ($err ? $err : 'Something happened'),
+ error => $err,
+ yk_errno => $yk_errno || 0;
+ return;
+ }
+ }
+
+ my $out = $r->{stdout};
+ chomp $out;
+ if (!$out) {
+ alert 'Failed to get YubiKey device info: no output';
+ return;
+ }
+
+ my %info = map { $_ => ($out =~ /^\Q$_\E: (.+)$/m)[0] }
+ qw(serial version touch_level vendor_id product_id);
+ $info{vendor_id} = hex($info{vendor_id}) if defined $info{vendor_id};
+ $info{product_id} = hex($info{product_id}) if defined $info{product_id};
+
+ return %info;
+}
+
+### Set the YubiKey information as attributes of a Key object
+sub _set_yubikey_info {
+ my $self = shift;
+ my %info = $self->_get_yubikey_info($self->device);
+ @$self{keys %info} = values %info;
+}
+
+sub _program {
+ my $self = shift;
+ my $name = shift;
+ my @cmd = $self->$name // $name;
+ my $name_uc = uc($name);
+ my $flags = $ENV{"${name_uc}_FLAGS"};
+ push @cmd, split(/\h+/, $flags) if $flags;
+ return @cmd;
+}
+
+sub _run_ykpers {
+ my $self = shift;
+ my $ppid = $$;
+ my $r = eval { run_forked(@_) };
+ my $err = $@;
+ if ($$ != $ppid) {
+ # Work around IPC::Cmd bug where child can return from run_forked.
+ # https://rt.cpan.org/Public/Bug/Display.html?id=127372
+ require POSIX;
+ POSIX::_exit(0);
+ }
+ if ($err || ($r->{exit_code} == 0 && $r->{err_msg} eq '' && $r->{stdout} eq '' && $r->{stderr} eq '')) {
+ $err //= 'No output';
+ my $prog = $_[0][0];
+ throw "Failed to run $prog - Make sure you have the YubiKey Personalization Tool (CLI) package installed.\n",
+ error => $err;
+ }
+ return $r;
+}
+
+sub _yk_errno {
+ local $_ = shift or return 0;
+ return YK_EUSBERR if $_ =~ YK_EUSBERR;
+ return YK_EWRONGSIZ if $_ =~ YK_EWRONGSIZ;
+ return YK_EWRITEERR if $_ =~ YK_EWRITEERR;
+ return YK_ETIMEOUT if $_ =~ YK_ETIMEOUT;
+ return YK_ENOKEY if $_ =~ YK_ENOKEY;
+ return YK_EFIRMWARE if $_ =~ YK_EFIRMWARE;
+ return YK_ENOMEM if $_ =~ YK_ENOMEM;
+ return YK_ENOSTATUS if $_ =~ YK_ENOSTATUS;
+ return YK_ENOTYETIMPL if $_ =~ YK_ENOTYETIMPL;
+ return YK_ECHECKSUM if $_ =~ YK_ECHECKSUM;
+ return YK_EWOULDBLOCK if $_ =~ YK_EWOULDBLOCK;
+ return YK_EINVALIDCMD if $_ =~ YK_EINVALIDCMD;
+ return YK_EMORETHANONE if $_ =~ YK_EMORETHANONE;
+ return YK_ENODATA if $_ =~ YK_ENODATA;
+ return -1;
+}
+
+my %PIDS;
+for my $pid (
+ YUBIKEY_PID, NEO_OTP_PID, NEO_OTP_CCID_PID, NEO_CCID_PID, NEO_U2F_PID, NEO_OTP_U2F_PID, NEO_U2F_CCID_PID,
+ NEO_OTP_U2F_CCID_PID, YK4_OTP_PID, YK4_U2F_PID, YK4_OTP_U2F_PID, YK4_CCID_PID, YK4_OTP_CCID_PID,
+ YK4_U2F_CCID_PID, YK4_OTP_U2F_CCID_PID, PLUS_U2F_OTP_PID, ONLYKEY_PID,
+) {
+ $PIDS{$pid} = $PIDS{0+$pid} = $pid;
+}
+sub _product_name { $PIDS{$_[1]} // 'Unknown' }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Key::YubiKey - A Yubico challenge-response key
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Key::YubiKey;
+ use File::KDBX;
+
+ my $yubikey = File::KDBX::Key::YubiKey->new(%attributes);
+
+ my $kdbx = File::KDBX->load_file('database.kdbx', $yubikey);
+ # OR
+ my $kdbx = File::KDBX->load_file('database.kdbx', ['password', $yubikey]);
+
+ # Scan for USB YubiKeys:
+ my ($first_key, @other_keys) = File::KDBX::Key::YubiKey->scan;
+
+ my $response = $first_key->challenge('hello');
+
+=head1 DESCRIPTION
+
+A L<File::KDBX::Key::YubiKey> is a type of challenge-response key. This module follows the KeePassXC-style
+challenge-response implementation, so this might not work at all with incompatible challenge-response
+implementations (e.g. KeeChallenge).
+
+Inherets methods and attributes from L<File::KDBX::Key::ChallengeResponse>.
+
+To use this type of key to secure a L<File::KDBX> database, you also need to install the
+L<YubiKey Personalization Tool (CLI)|https://developers.yubico.com/yubikey-personalization/> and configure at
+least one of the slots on your YubiKey for HMAC-SHA1 challenge response mode. You can use the YubiKey
+Personalization Tool GUI to do this.
+
+See L<https://keepassxc.org/docs/#faq-yubikey-howto> for more information.
+
+=head1 ATTRIBUTES
+
+=head2 device
+
+ $device = $key->device($device);
+
+Get or set the device number, which is the index number starting and incrementing from zero assigned
+to the YubiKey device. If there is only one detected YubiKey device, it's number is C<0>.
+
+Defaults to C<0>.
+
+=head2 slot
+
+ $slot = $key->slot($slot);
+
+Get or set the slot number, which is a number starting and incrementing from one. A YubiKey can have
+multiple slots (often just two) which can be independently configured.
+
+Defaults to C<1>.
+
+=head2 timeout
+
+ $timeout = $key->timeout($timeout);
+
+Get or set the timeout, in seconds. If the challenge takes longer than this, the challenge will be
+cancelled and an error is thrown.
+
+If the timeout is zero, the challenge is non-blocking; an error is thrown if the challenge would
+block. If the timeout is negative, timeout is disabled and the challenge will block forever or until
+a response is received.
+
+Defaults to C<0>.
+
+=head2 pre_challenge
+
+ $callback = $key->pre_challenge($callback);
+
+Get or set a callback function that will be called immediately before any challenge is issued. This might be
+used to prompt the user so they are aware that they are expected to interact with their YubiKey.
+
+ $key->pre_challenge(sub {
+ my ($key, $challenge) = @_;
+
+ if ($key->requires_interaction) {
+ say 'Please touch your key device to proceed with decrypting your KDBX file.';
+ }
+ say 'Key: ', $key->name;
+ if (0 < $key->timeout) {
+ say 'Key access request expires: ' . localtime(time + $key->timeout);
+ }
+ });
+
+You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
+a KDBX database, the entire load/dump will be aborted.
+
+=head2 post_challenge
+
+ $callback = $key->post_challenge($callback);
+
+Get or set a callback function that will be called immediately after a challenge response has been received.
+
+You can throw from this subroutine to abort the challenge. If the challenge is part of loading or dumping
+a KDBX database, the entire load/dump will be aborted.
+
+=head2 ykchalresp
+
+ $program = $key->ykchalresp;
+
+Get or set the L<ykchalresp(1)> program name or filepath. Defaults to C<$ENV{YKCHALRESP}> or C<ykchalresp>.
+
+=head2 ykinfo
+
+ $program = $key->ykinfo;
+
+Get or set the L<ykinfo(1)> program name or filepath. Defaults to C<$ENV{YKINFO}> or C<ykinfo>.
+
+=head1 METHODS
+
+=head2 scan
+
+ @keys = File::KDBX::Key::YubiKey->scan(%options);
+
+Find connected, configured YubiKeys that are capable of responding to a challenge. This can take several
+second.
+
+Options:
+
+=over 4
+
+=item *
+
+C<limit> - Scan for only up to this many YubiKeys (default: 4)
+
+=back
+
+Other options are passed as-is as attributes to the key constructors of found keys (if any).
+
+=head2 serial
+
+Get the device serial number, as a number, or C<undef> if there is no such device.
+
+=head2 version
+
+Get the device firmware version (or C<undef>).
+
+=head2 touch_level
+
+Get the "touch level" value for the device associated with this key (or C<undef>).
+
+=head2 vendor_id
+
+=head2 product_id
+
+Get the vendor ID or product ID for the device associated with this key (or C<undef>).
+
+=head2 name
+
+ $name = $key->name;
+
+Get a human-readable string identifying the YubiKey (or C<undef>).
+
+=head2 requires_interaction
+
+Get whether or not the key requires interaction (e.g. a touch) to provide a challenge response (or C<undef>).
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item *
+
+C<YKCHALRESP> - Path to the L<ykchalresp(1)> program
+
+=item *
+
+C<YKINFO> - Path to the L<ykinfo(1)> program
+
+=item *
+
+C<YKCHALRESP_FLAGS> - Extra arguments to the B<ykchalresp(1)> program
+
+=item *
+
+C<YKINFO_FLAGS> - Extra arguments to the B<ykinfo(1)> program
+
+=back
+
+B<YubiKey> searches for these programs in the same way perl typically searches for executables (using the
+C<PATH> environment variable on many platforms). If the programs aren't installed normally, or if you want to
+override the default programs, these environment variables can be used.
+
+=head1 CAVEATS
+
+This doesn't work yet on Windows, probably. The hangup is pretty silly: IPC. Theoretically it would work if
+C<run_forked> from L<IPC::Cmd> worked in Windows, but it probably doesn't. I spent a couple hours applying
+various quirks to L<IPC::Open3> and L<IPC::Cmd> implementations but never quite got it to worked reliably
+without deadlocks. Maybe I'll revisit this later. Hit me up so I know if there's demand.
+
+It would also be possible to implement this is an XS module that incorporated ykcore, using libusb-1 which
+would probably make it more portable with Windows. Perhaps if I get around to it.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Loader;
+# ABSTRACT: Load KDBX files
+
+use warnings;
+use strict;
+
+use File::KDBX::Constants qw(:magic :header :version);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :io);
+use File::KDBX;
+use IO::Handle;
+use Module::Load ();
+use Ref::Util qw(is_ref is_scalarref);
+use Scalar::Util qw(looks_like_number openhandle);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->init(@_);
+}
+
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ @$self{keys %args} = values %args;
+
+ return $self;
+}
+
+sub _rebless {
+ my $self = shift;
+ my $format = shift // $self->format;
+
+ my $sig2 = $self->kdbx->sig2;
+ my $version = $self->kdbx->version;
+
+ my $subclass;
+
+ if (defined $format) {
+ $subclass = $format;
+ }
+ elsif (defined $sig2 && $sig2 == KDBX_SIG2_1) {
+ $subclass = 'KDB';
+ }
+ elsif (looks_like_number($version)) {
+ my $major = $version & KDBX_VERSION_MAJOR_MASK;
+ my %subclasses = (
+ KDBX_VERSION_2_0() => 'V3',
+ KDBX_VERSION_3_0() => 'V3',
+ KDBX_VERSION_4_0() => 'V4',
+ );
+ $subclass = $subclasses{$major}
+ or throw sprintf('Unsupported KDBX file version: %x', $version), version => $version;
+ }
+ else {
+ throw sprintf('Unknown file version: %s', $version), version => $version;
+ }
+
+ Module::Load::load "File::KDBX::Loader::$subclass";
+ bless $self, "File::KDBX::Loader::$subclass";
+}
+
+
+sub reset {
+ my $self = shift;
+ %$self = ();
+ return $self;
+}
+
+
+sub load {
+ my $self = shift;
+ my $src = shift;
+ return $self->load_handle($src, @_) if openhandle($src) || $src eq '-';
+ return $self->load_string($src, @_) if is_scalarref($src);
+ return $self->load_file($src, @_) if !is_ref($src) && defined $src;
+ throw 'Programmer error: Must pass a stringref, filepath or IO handle to read';
+}
+
+
+sub load_string {
+ my $self = shift;
+ my $str = shift or throw 'Expected string to load';
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ my $ref = is_scalarref($str) ? $str : \$str;
+
+ open(my $fh, '<', $ref) or throw "Failed to open string buffer: $!";
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_read($fh, $key);
+ return $args{kdbx};
+}
+
+
+sub load_file {
+ my $self = shift;
+ my $filepath = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ open(my $fh, '<:raw', $filepath) or throw 'Open file failed', filepath => $filepath;
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh, filepath => $filepath)->_read($fh, $key);
+ return $args{kdbx};
+}
+
+
+sub load_handle {
+ my $self = shift;
+ my $fh = shift;
+ my %args = @_ % 2 == 0 ? @_ : (key => shift, @_);
+
+ $fh = *STDIN if $fh eq '-';
+
+ my $key = delete $args{key};
+ $args{kdbx} //= $self->kdbx;
+
+ $self = $self->new if !ref $self;
+ $self->init(%args, fh => $fh)->_read($fh, $key);
+ return $args{kdbx};
+}
+
+
+sub kdbx {
+ my $self = shift;
+ return File::KDBX->new if !ref $self;
+ $self->{kdbx} = shift if @_;
+ $self->{kdbx} //= File::KDBX->new;
+}
+
+
+has format => undef, is => 'ro';
+has inner_format => 'XML', is => 'ro';
+
+
+sub min_version { KDBX_VERSION_OLDEST }
+
+
+sub read_magic_numbers {
+ my $self = shift;
+ my $fh = shift;
+ my $kdbx = shift // $self->kdbx;
+
+ read_all $fh, my $magic, 12 or throw 'Failed to read file signature';
+
+ my ($sig1, $sig2, $version) = unpack('L<3', $magic);
+
+ if ($kdbx) {
+ $kdbx->sig1($sig1);
+ $kdbx->sig2($sig2);
+ $kdbx->version($version);
+ $self->_rebless if ref $self;
+ }
+
+ return wantarray ? ($sig1, $sig2, $version, $magic) : $magic;
+}
+
+sub _fh { $_[0]->{fh} or throw 'IO handle not set' }
+
+sub _read {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+
+ my $kdbx = $self->kdbx;
+ $key //= $kdbx->key ? $kdbx->key->reload : undef;
+ $kdbx->reset;
+
+ read_all $fh, my $buf, 1 or throw 'Failed to read the first byte', type => 'parser';
+ my $first = ord($buf);
+ $fh->ungetc($first);
+ if ($first != KDBX_SIG1_FIRST_BYTE) {
+ # not a KDBX file... try skipping the outer layer
+ return $self->_read_inner_body($fh);
+ }
+
+ my $magic = $self->read_magic_numbers($fh, $kdbx);
+ $kdbx->sig1 == KDBX_SIG1 or throw 'Invalid file signature', type => 'parser', sig1 => $kdbx->sig1;
+
+ if (ref($self) =~ /::(?:KDB|V[34])$/) {
+ defined $key or throw 'Must provide a master key', type => 'key.missing';
+ }
+
+ my $headers = $self->_read_headers($fh);
+
+ eval {
+ $self->_read_body($fh, $key, "$magic$headers");
+ };
+ if (my $err = $@) {
+ throw "Failed to load KDBX file: $err",
+ error => $err,
+ compression_error => $IO::Uncompress::Gunzip::GunzipError,
+ crypt_error => $File::KDBX::IO::Crypt::ERROR,
+ hash_error => $File::KDBX::IO::HashBLock::ERROR,
+ hmac_error => $File::KDBX::IO::HmacBLock::ERROR;
+ }
+}
+
+sub _read_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ my $headers = $self->kdbx->headers;
+ my $all_raw = '';
+
+ while (my ($type, $val, $raw) = $self->_read_header($fh)) {
+ $all_raw .= $raw;
+ last if $type == HEADER_END;
+ $headers->{$type} = $val;
+ }
+
+ return $all_raw;
+}
+
+sub _read_body { die "Not implemented" }
+
+sub _read_inner_body {
+ my $self = shift;
+
+ my $current_pkg = ref $self;
+ require Scope::Guard;
+ my $guard = Scope::Guard->new(sub { bless $self, $current_pkg });
+
+ $self->_rebless($self->inner_format);
+ $self->_read_inner_body(@_);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Loader - Load KDBX files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+=head1 ATTRIBUTES
+
+=head2 kdbx
+
+ $kdbx = $loader->kdbx;
+ $loader->kdbx($kdbx);
+
+Get or set the L<File::KDBX> instance for storing the loaded data into.
+
+=head2 format
+
+Get the file format used for reading the database. Normally the format is auto-detected from the data stream.
+This auto-detection works well, so there's not really a good reason to explicitly specify the format.
+Possible formats:
+
+=over 4
+
+=item *
+
+C<V3>
+
+=item *
+
+C<V4>
+
+=item *
+
+C<KDB>
+
+=item *
+
+C<XML>
+
+=item *
+
+C<Raw>
+
+=back
+
+=head2 inner_format
+
+Get the format of the data inside the KDBX envelope. This only applies to C<V3> and C<V4> formats. Possible
+formats:
+
+=over 4
+
+=item *
+
+C<XML> - Read the database groups and entries as XML (default)
+
+=item *
+
+C<Raw> - Read parsing and store the result in L<File::KDBX/raw>
+
+=back
+
+=head1 METHODS
+
+=head2 new
+
+ $loader = File::KDBX::Loader->new(%attributes);
+
+Construct a new L<File::KDBX::Loader>.
+
+=head2 init
+
+ $loader = $loader->init(%attributes);
+
+Initialize a L<File::KDBX::Loader> with a new set of attributes.
+
+This is called by L</new>.
+
+=head2 reset
+
+ $loader = $loader->reset;
+
+Set a L<File::KDBX::Loader> to a blank state, ready to load another KDBX file.
+
+=head2 load
+
+ $kdbx = File::KDBX::Loader->load(\$string, $key);
+ $kdbx = File::KDBX::Loader->load(*IO, $key);
+ $kdbx = File::KDBX::Loader->load($filepath, $key);
+ $kdbx = $loader->load(...); # also instance method
+
+Load a KDBX file.
+
+The C<$key> is either a L<File::KDBX::Key> or a primitive that can be converted to a Key object.
+
+=head2 load_string
+
+ $kdbx = File::KDBX::Loader->load_string($string, $key);
+ $kdbx = File::KDBX::Loader->load_string(\$string, $key);
+ $kdbx = $loader->load_string(...); # also instance method
+
+Load a KDBX file from a string / memory buffer.
+
+=head2 load_file
+
+ $kdbx = File::KDBX::Loader->load_file($filepath, $key);
+ $kdbx = $loader->load_file(...); # also instance method
+
+Read a KDBX file from a filesystem.
+
+=head2 load_handle
+
+ $kdbx = File::KDBX::Loader->load_handle($fh, $key);
+ $kdbx = File::KDBX::Loader->load_handle(*IO, $key);
+ $kdbx->load_handle(...); # also instance method
+
+Read a KDBX file from an input stream / file handle.
+
+=head2 min_version
+
+ $min_version = File::KDBX::Loader->min_version;
+
+Get the minimum KDBX file version supported, which is 3.0 or C<0x00030000> as
+it is encoded.
+
+To read older KDBX files unsupported by this module, try L<File::KeePass>.
+
+=head2 read_magic_numbers
+
+ $magic = File::KDBX::Loader->read_magic_numbers($fh);
+ ($sig1, $sig2, $version, $magic) = File::KDBX::Loader->read_magic_numbers($fh);
+
+ $magic = $loader->read_magic_numbers($fh);
+ ($sig1, $sig2, $version, $magic) = $loader->read_magic_numbers($fh);
+
+Read exactly 12 bytes from an IO handle and parse them into the three magic numbers that begin
+a KDBX file. This is a quick way to determine if a file is actually a KDBX file.
+
+C<$sig1> should always be C<KDBX_SIG1> if reading an actual KDB or KDBX file.
+
+C<$sig2> should be C<KDBX_SIG2_1> for KeePass 1 files and C<KDBX_SIG2_2> for KeePass 2 files.
+
+C<$version> is the file version (e.g. C<0x00040001>).
+
+C<$magic> is the raw 12 bytes read from the IO handle.
+
+If called on an instance, the C<sig1>, C<sig2> and C<version> attributes will be set in the L</kdbx>
+and the instance will be blessed into the correct loader subclass.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Loader::KDB;
+# ABSTRACT: Read KDB files
+
+use warnings;
+use strict;
+
+use Encode qw(encode);
+use File::KDBX::Constants qw(:header :cipher :random_stream :icon);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :empty :io :uuid load_optional);
+use File::KDBX;
+use Ref::Util qw(is_arrayref is_hashref);
+use Scalar::Util qw(looks_like_number);
+use Time::Piece;
+use boolean;
+use namespace::clean;
+
+extends 'File::KDBX::Loader';
+
+our $VERSION = '0.800'; # VERSION
+
+my $DEFAULT_EXPIRATION = Time::Piece->new(32503677839); # 2999-12-31 23:59:59
+
+sub _read_headers { '' }
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $buf = shift;
+
+ load_optional('File::KeePass');
+
+ $buf .= do { local $/; <$fh> };
+
+ $key = $self->kdbx->composite_key($key, keep_primitive => 1);
+
+ my $k = eval { File::KeePass->new->parse_db(\$buf, _convert_kdbx_to_keepass_master_key($key)) };
+ if (my $err = $@) {
+ throw 'Failed to parse KDB file', error => $err;
+ }
+
+ $k->unlock;
+ $self->kdbx->key($key);
+
+ return convert_keepass_to_kdbx($k, $self->kdbx);
+}
+
+# This is also used by File::KDBX::Dumper::KDB.
+sub _convert_kdbx_to_keepass_master_key {
+ my $key = shift;
+
+ my @keys = @{$key->keys};
+ if (@keys == 1 && !$keys[0]->can('filepath')) {
+ return [encode('CP-1252', $keys[0]->{primitive})]; # just a password
+ }
+ elsif (@keys == 1) {
+ return [undef, \$keys[0]->raw_key]; # just a keyfile
+ }
+ elsif (@keys == 2 && !$keys[0]->can('filepath') && $keys[1]->can('filepath')) {
+ return [encode('CP-1252', $keys[0]->{primitive}), \$keys[1]->raw_key];
+ }
+ throw 'Cannot use this key to load a KDB file', key => $key;
+}
+
+
+sub convert_keepass_to_kdbx {
+ my $k = shift;
+ my $kdbx = shift // File::KDBX->new;
+
+ $kdbx->{headers} //= {};
+ _convert_keepass_to_kdbx_headers($k->{header}, $kdbx);
+
+ my @groups = @{$k->{groups} || []};
+ if (@groups == 1) {
+ $kdbx->{root} = _convert_keepass_to_kdbx_group($k->{groups}[0]);
+ }
+ elsif (1 < @groups) {
+ my $root = $kdbx->{root} = {%{File::KDBX->_implicit_root}};
+ for my $group (@groups) {
+ push @{$root->{groups} //= []}, _convert_keepass_to_kdbx_group($group);
+ }
+ }
+
+ $kdbx->entries
+ ->grep({
+ title => 'Meta-Info',
+ username => 'SYSTEM',
+ url => '$',
+ icon_id => 0,
+ -nonempty => 'notes',
+ })
+ ->each(sub {
+ _read_meta_stream($kdbx, $_);
+ $_->remove(signal => 0);
+ });
+
+ return $kdbx;
+}
+
+sub _read_meta_stream {
+ my $kdbx = shift;
+ my $entry = shift;
+
+ my $type = $entry->notes;
+ my $data = $entry->binary_value('bin-stream');
+ open(my $fh, '<', \$data) or throw "Failed to open memory buffer for reading: $!";
+
+ if ($type eq 'KPX_GROUP_TREE_STATE') {
+ read_all $fh, my $buf, 4 or goto PARSE_ERROR;
+ my ($num) = unpack('L<', $buf);
+ $num * 5 + 4 == length($data) or goto PARSE_ERROR;
+ for (my $i = 0; $i < $num; ++$i) {
+ read_all $fh, $buf, 5 or goto PARSE_ERROR;
+ my ($group_id, $expanded) = unpack('L< C', $buf);
+ my $uuid = _decode_uuid($group_id) // next;
+ my $group = $kdbx->groups->grep({uuid => $uuid})->next;
+ $group->is_expanded($expanded) if $group;
+ }
+ }
+ elsif ($type eq 'KPX_CUSTOM_ICONS_4') {
+ read_all $fh, my $buf, 12 or goto PARSE_ERROR;
+ my ($num_icons, $num_entries, $num_groups) = unpack('L<3', $buf);
+ my @icons;
+ for (my $i = 0; $i < $num_icons; ++$i) {
+ read_all $fh, $buf, 4 or goto PARSE_ERROR;
+ my ($icon_size) = unpack('L<', $buf);
+ read_all $fh, $buf, $icon_size or goto PARSE_ERROR;
+ my $uuid = $kdbx->add_custom_icon($buf);
+ push @icons, $uuid;
+ }
+ for (my $i = 0; $i < $num_entries; ++$i) {
+ read_all $fh, $buf, 20 or goto PARSE_ERROR;
+ my ($uuid, $icon_index) = unpack('a16 L<', $buf);
+ next if !$icons[$icon_index];
+ my $entry = $kdbx->entries->grep({uuid => $uuid})->next;
+ $entry->custom_icon_uuid($icons[$icon_index]) if $entry;
+ }
+ for (my $i = 0; $i < $num_groups; ++$i) {
+ read_all $fh, $buf, 8 or goto PARSE_ERROR;
+ my ($group_id, $icon_index) = unpack('L<2', $buf);
+ next if !$icons[$icon_index];
+ my $uuid = _decode_uuid($group_id) // next;
+ my $group = $kdbx->groups->grep({uuid => $uuid})->next;
+ $group->custom_icon_uuid($icons[$icon_index]) if $group;
+ }
+ }
+ else {
+ alert "Ignoring unknown meta stream: $type\n", type => $type;
+ return;
+ }
+
+ return;
+
+ PARSE_ERROR:
+ alert "Ignoring unparsable meta stream: $type\n", type => $type;
+}
+
+sub _convert_keepass_to_kdbx_headers {
+ my $from = shift;
+ my $kdbx = shift;
+
+ my $headers = $kdbx->{headers} //= {};
+ my $meta = $kdbx->{meta} //= {};
+
+ $kdbx->{sig1} = $from->{sig1};
+ $kdbx->{sig2} = $from->{sig2};
+ $kdbx->{version} = $from->{vers};
+
+ my %enc_type = (
+ rijndael => CIPHER_UUID_AES256,
+ aes => CIPHER_UUID_AES256,
+ twofish => CIPHER_UUID_TWOFISH,
+ chacha20 => CIPHER_UUID_CHACHA20,
+ salsa20 => CIPHER_UUID_SALSA20,
+ serpent => CIPHER_UUID_SERPENT,
+ );
+ my $cipher_uuid = $enc_type{$from->{cipher} || ''} // $enc_type{$from->{enc_type} || ''};
+
+ my %protected_stream = (
+ rc4 => STREAM_ID_RC4_VARIANT,
+ salsa20 => STREAM_ID_SALSA20,
+ chacha20 => STREAM_ID_CHACHA20,
+ );
+ my $protected_stream_id = $protected_stream{$from->{protected_stream} || ''} || STREAM_ID_SALSA20;
+
+ $headers->{+HEADER_COMMENT} = $from->{comment};
+ $headers->{+HEADER_CIPHER_ID} = $cipher_uuid if $cipher_uuid;
+ $headers->{+HEADER_MASTER_SEED} = $from->{seed_rand};
+ $headers->{+HEADER_COMPRESSION_FLAGS} = $from->{compression} // 0;
+ $headers->{+HEADER_TRANSFORM_SEED} = $from->{seed_key};
+ $headers->{+HEADER_TRANSFORM_ROUNDS} = $from->{rounds};
+ $headers->{+HEADER_ENCRYPTION_IV} = $from->{enc_iv};
+ $headers->{+HEADER_INNER_RANDOM_STREAM_ID} = $protected_stream_id;
+ $headers->{+HEADER_INNER_RANDOM_STREAM_KEY} = $from->{protected_stream_key};
+ $headers->{+HEADER_STREAM_START_BYTES} = $from->{start_bytes} // '';
+
+ # TODO for KeePass 1 files these are all not available. Leave undefined or set default values?
+ $meta->{memory_protection}{protect_notes} = boolean($from->{protect_notes});
+ $meta->{memory_protection}{protect_password} = boolean($from->{protect_password});
+ $meta->{memory_protection}{protect_username} = boolean($from->{protect_username});
+ $meta->{memory_protection}{protect_url} = boolean($from->{protect_url});
+ $meta->{memory_protection}{protect_title} = boolean($from->{protect_title});
+ $meta->{generator} = $from->{generator} // '';
+ $meta->{header_hash} = $from->{header_hash};
+ $meta->{database_name} = $from->{database_name} // '';
+ $meta->{database_name_changed} = _decode_datetime($from->{database_name_changed});
+ $meta->{database_description} = $from->{database_description} // '';
+ $meta->{database_description_changed} = _decode_datetime($from->{database_description_changed});
+ $meta->{default_username} = $from->{default_user_name} // '';
+ $meta->{default_username_changed} = _decode_datetime($from->{default_user_name_changed});
+ $meta->{maintenance_history_days} = $from->{maintenance_history_days};
+ $meta->{color} = $from->{color};
+ $meta->{master_key_changed} = _decode_datetime($from->{master_key_changed});
+ $meta->{master_key_change_rec} = $from->{master_key_change_rec};
+ $meta->{master_key_change_force} = $from->{master_key_change_force};
+ $meta->{recycle_bin_enabled} = boolean($from->{recycle_bin_enabled});
+ $meta->{recycle_bin_uuid} = $from->{recycle_bin_uuid};
+ $meta->{recycle_bin_changed} = _decode_datetime($from->{recycle_bin_changed});
+ $meta->{entry_templates_group} = $from->{entry_templates_group};
+ $meta->{entry_templates_group_changed} = _decode_datetime($from->{entry_templates_group_changed});
+ $meta->{last_selected_group} = $from->{last_selected_group};
+ $meta->{last_top_visible_group} = $from->{last_top_visible_group};
+ $meta->{history_max_items} = $from->{history_max_items};
+ $meta->{history_max_size} = $from->{history_max_size};
+ $meta->{settings_changed} = _decode_datetime($from->{settings_changed});
+
+ while (my ($key, $value) = each %{$from->{custom_icons} || {}}) {
+ push @{$meta->{custom_icons} //= []}, {uuid => $key, data => $value};
+ }
+ while (my ($key, $value) = each %{$from->{custom_data} || {}}) {
+ $meta->{custom_data}{$key} = {value => $value};
+ }
+
+ return $kdbx;
+}
+
+sub _convert_keepass_to_kdbx_group {
+ my $from = shift;
+ my $to = shift // {};
+ my %args = @_;
+
+ $to->{times}{last_access_time} = _decode_datetime($from->{accessed});
+ $to->{times}{usage_count} = $from->{usage_count} || 0;
+ $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION);
+ $to->{times}{expires} = defined $from->{expires_enabled}
+ ? boolean($from->{expires_enabled})
+ : boolean($to->{times}{expiry_time} <= gmtime);
+ $to->{times}{creation_time} = _decode_datetime($from->{created});
+ $to->{times}{last_modification_time} = _decode_datetime($from->{modified});
+ $to->{times}{location_changed} = _decode_datetime($from->{location_changed});
+ $to->{notes} = $from->{notes} // '';
+ $to->{uuid} = _decode_uuid($from->{id});
+ $to->{is_expanded} = boolean($from->{expanded});
+ $to->{icon_id} = $from->{icon} // ICON_FOLDER;
+ $to->{name} = $from->{title} // '';
+ $to->{default_auto_type_sequence} = $from->{auto_type_default} // '';
+ $to->{enable_auto_type} = _decode_tristate($from->{auto_type_enabled});
+ $to->{enable_searching} = _decode_tristate($from->{enable_searching});
+ $to->{groups} = [];
+ $to->{entries} = [];
+
+ if (!$args{shallow}) {
+ for my $group (@{$from->{groups} || []}) {
+ push @{$to->{groups}}, _convert_keepass_to_kdbx_group($group);
+ }
+ for my $entry (@{$from->{entries} || []}) {
+ push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry);
+ }
+ }
+
+ return $to;
+}
+
+sub _convert_keepass_to_kdbx_entry {
+ my $from = shift;
+ my $to = shift // {};
+ my %args = @_;
+
+ $to->{times}{last_access_time} = _decode_datetime($from->{accessed});
+ $to->{times}{usage_count} = $from->{usage_count} || 0;
+ $to->{times}{expiry_time} = _decode_datetime($from->{expires}, $DEFAULT_EXPIRATION);
+ $to->{times}{expires} = defined $from->{expires_enabled}
+ ? boolean($from->{expires_enabled})
+ : boolean($to->{times}{expiry_time} <= gmtime);
+ $to->{times}{creation_time} = _decode_datetime($from->{created});
+ $to->{times}{last_modification_time} = _decode_datetime($from->{modified});
+ $to->{times}{location_changed} = _decode_datetime($from->{location_changed});
+
+ $to->{auto_type}{data_transfer_obfuscation} = $from->{auto_type_munge} || false;
+ $to->{auto_type}{enabled} = boolean($from->{auto_type_enabled} // 1);
+
+ my $comment = $from->{comment};
+ my @auto_type = is_arrayref($from->{auto_type}) ? @{$from->{auto_type}} : ();
+
+ if (!@auto_type && nonempty $from->{auto_type} && nonempty $from->{auto_type_window}
+ && !is_hashref($from->{auto_type})) {
+ @auto_type = ({window => $from->{auto_type_window}, keys => $from->{auto_type}});
+ }
+ if (nonempty $comment) {
+ my @AT;
+ my %atw = my @atw = $comment =~ m{ ^Auto-Type-Window((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
+ my %atk = my @atk = $comment =~ m{ ^Auto-Type((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
+ $comment =~ s{ ^Auto-Type(?:-Window)?(?:-?\d+)?: .* \n? }{}mxg;
+ while (@atw) {
+ my ($n, $w) = (shift(@atw), shift(@atw));
+ push @AT, {window => $w, keys => exists($atk{$n}) ? $atk{$n} : $atk{''}};
+ }
+ while (@atk) {
+ my ($n, $k) = (shift(@atk), shift(@atk));
+ push @AT, {keys => $k, window => exists($atw{$n}) ? $atw{$n} : $atw{''}};
+ }
+ for (@AT) {
+ $_->{'window'} //= '';
+ $_->{'keys'} //= '';
+ }
+ my %uniq;
+ @AT = grep {!$uniq{"$_->{'window'}\e$_->{'keys'}"}++} @AT;
+ push @auto_type, @AT;
+ }
+ $to->{auto_type}{associations} = [
+ map { +{window => $_->{window}, keystroke_sequence => $_->{keys}} } @auto_type,
+ ];
+
+ $to->{strings}{Notes}{value} = $comment;
+ $to->{strings}{UserName}{value} = $from->{username};
+ $to->{strings}{Password}{value} = $from->{password};
+ $to->{strings}{URL}{value} = $from->{url};
+ $to->{strings}{Title}{value} = $from->{title};
+ $to->{strings}{Notes}{protect} = true if defined $from->{protected}{comment};
+ $to->{strings}{UserName}{protect} = true if defined $from->{protected}{username};
+ $to->{strings}{Password}{protect} = true if $from->{protected}{password} // 1;
+ $to->{strings}{URL}{protect} = true if defined $from->{protected}{url};
+ $to->{strings}{Title}{protect} = true if defined $from->{protected}{title};
+
+ # other strings
+ while (my ($key, $value) = each %{$from->{strings} || {}}) {
+ $to->{strings}{$key} = {
+ value => $value,
+ $from->{protected}{$key} ? (protect => true) : (),
+ };
+ }
+
+ $to->{override_url} = $from->{override_url};
+ $to->{tags} = $from->{tags} // '';
+ $to->{icon_id} = $from->{icon} // ICON_PASSWORD;
+ $to->{uuid} = _decode_uuid($from->{id});
+ $to->{foreground_color} = $from->{foreground_color} // '';
+ $to->{background_color} = $from->{background_color} // '';
+ $to->{custom_icon_uuid} = $from->{custom_icon_uuid};
+ $to->{history} = [];
+
+ local $from->{binary} = {$from->{binary_name} => $from->{binary}}
+ if nonempty $from->{binary} && nonempty $from->{binary_name} && !is_hashref($from->{binary});
+ while (my ($key, $value) = each %{$from->{binary} || {}}) {
+ $to->{binaries}{$key} = {value => $value};
+ }
+
+ if (!$args{shallow}) {
+ for my $entry (@{$from->{history} || []}) {
+ my $new_entry = {};
+ push @{$to->{entries}}, _convert_keepass_to_kdbx_entry($entry, $new_entry);
+ }
+ }
+
+ return $to;
+}
+
+sub _decode_datetime {
+ local $_ = shift // return shift // gmtime;
+ return Time::Piece->strptime($_, '%Y-%m-%d %H:%M:%S');
+}
+
+sub _decode_uuid {
+ local $_ = shift // return;
+ # Group IDs in KDB files are 32-bit integers
+ return sprintf('%016x', $_) if length($_) != 16 && looks_like_number($_);
+ return $_;
+}
+
+sub _decode_tristate {
+ local $_ = shift // return;
+ return boolean($_);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Loader::KDB - Read KDB files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+Read older KDB (KeePass 1) files. This feature requires an additional module to be installed:
+
+=over 4
+
+=item *
+
+L<File::KeePass>
+
+=back
+
+=head1 FUNCTIONS
+
+=head2 convert_keepass_to_kdbx
+
+ $kdbx = convert_keepass_to_kdbx($keepass);
+ $kdbx = convert_keepass_to_kdbx($keepass, $kdbx);
+
+Convert a L<File::KeePass> to a L<File::KDBX>.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Loader::Raw;
+# ABSTRACT: A no-op loader that doesn't do any parsing
+
+use warnings;
+use strict;
+
+use File::KDBX::Util qw(:class);
+use namespace::clean;
+
+extends 'File::KDBX::Loader';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _read {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_read_body($fh);
+}
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_read_inner_body($fh);
+}
+
+sub _read_inner_body {
+ my $self = shift;
+ my $fh = shift;
+
+ my $content = do { local $/; <$fh> };
+ $self->kdbx->raw($content);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Loader::Raw - A no-op loader that doesn't do any parsing
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Loader;
+
+ my $kdbx = File::KDBX::Loader->load_file('file.kdbx', $key, inner_format => 'Raw');
+ print $kdbx->raw;
+
+=head1 DESCRIPTION
+
+A typical KDBX file is made up of an outer section (with headers) and an inner section (with the body). The
+inner section is usually loaded using L<File::KDBX::Loader::XML>, but you can use the
+B<File::KDBX::Loader::Raw> loader to not parse the body at all and just get the raw body content. This can be
+useful for debugging or creating KDBX files with arbitrary content (see L<File::KDBX::Dumper::Raw>).
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Loader::V3;
+# ABSTRACT: Load KDBX3 files
+
+# magic
+# headers
+# body
+# CRYPT(
+# start bytes
+# HASH(
+# COMPRESS(
+# xml
+# )
+# )
+# )
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Encode qw(decode);
+use File::KDBX::Constants qw(:header :compression :kdf);
+use File::KDBX::Error;
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HashBlock;
+use File::KDBX::Util qw(:class :io :load assert_64bit erase_scoped);
+use namespace::clean;
+
+extends 'File::KDBX::Loader';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _read_header {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 3 or throw 'Malformed header field, expected header type and size';
+ my ($type, $size) = unpack('C S<', $buf);
+
+ my $val;
+ if (0 < $size) {
+ read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size;
+ $buf .= $val;
+ }
+
+ $type = to_header_constant($type);
+ if ($type == HEADER_END) {
+ # done
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = decode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = unpack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_TRANSFORM_SEED) {
+ # nothing
+ }
+ elsif ($type == HEADER_TRANSFORM_ROUNDS) {
+ assert_64bit;
+ $val = unpack('Q<', $val);
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_KEY) {
+ # nothing
+ }
+ elsif ($type == HEADER_STREAM_START_BYTES) {
+ # nothing
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = unpack('L<', $val);
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS ||
+ $type == HEADER_PUBLIC_CUSTOM_DATA) {
+ throw "Unexpected KDBX4 header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ return wantarray ? ($type => $val, $buf) : $buf;
+}
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ HEADER_INNER_RANDOM_STREAM_KEY,
+ HEADER_STREAM_START_BYTES,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing $field";
+ }
+
+ $kdbx->kdf_parameters({
+ KDF_PARAM_UUID() => KDF_UUID_AES,
+ KDF_PARAM_AES_ROUNDS() => delete $kdbx->headers->{+HEADER_TRANSFORM_ROUNDS},
+ KDF_PARAM_AES_SEED() => delete $kdbx->headers->{+HEADER_TRANSFORM_SEED},
+ });
+
+ my $master_seed = $kdbx->headers->{+HEADER_MASTER_SEED};
+
+ my @cleanup;
+ $key = $kdbx->composite_key($key);
+
+ my $response = $key->challenge($master_seed);
+ push @cleanup, erase_scoped $response;
+
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ my $final_key = digest_data('SHA256', $master_seed, $response, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
+
+ read_all $fh, my $start_bytes, 32 or throw 'Failed to read starting bytes';
+
+ my $expected_start_bytes = $kdbx->headers->{stream_start_bytes};
+ $start_bytes eq $expected_start_bytes
+ or throw "Invalid credentials or data is corrupt (wrong starting bytes)\n",
+ got => $start_bytes, expected => $expected_start_bytes, headers => $kdbx->headers;
+
+ $kdbx->key($key);
+
+ $fh = File::KDBX::IO::HashBlock->new($fh);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ load_optional('IO::Uncompress::Gunzip');
+ $fh = IO::Uncompress::Gunzip->new($fh)
+ or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError",
+ error => $IO::Uncompress::Gunzip::GunzipError;
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ $self->_read_inner_body($fh);
+ close($fh);
+
+ if (my $header_hash = $kdbx->meta->{header_hash}) {
+ my $got_header_hash = digest_data('SHA256', $header_data);
+ $header_hash eq $got_header_hash
+ or throw 'Header hash does not match', got => $got_header_hash, expected => $header_hash;
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Loader::V3 - Load KDBX3 files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Loader::V4;
+# ABSTRACT: Load KDBX4 files
+
+# magic
+# headers
+# headers checksum
+# headers hmac
+# body
+# HMAC(
+# CRYPT(
+# COMPRESS(
+# xml
+# )
+# )
+# )
+
+use warnings;
+use strict;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::Mac::HMAC qw(hmac);
+use Encode qw(decode);
+use File::KDBX::Constants qw(:header :inner_header :variant_map :compression);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:class :io :load assert_64bit erase_scoped);
+use File::KDBX::IO::Crypt;
+use File::KDBX::IO::HmacBlock;
+use boolean;
+use namespace::clean;
+
+extends 'File::KDBX::Loader';
+
+our $VERSION = '0.800'; # VERSION
+
+sub _read_header {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 5 or throw 'Malformed header field, expected header type and size';
+ my ($type, $size) = unpack('C L<', $buf);
+
+ my $val;
+ if (0 < $size) {
+ read_all $fh, $val, $size or throw 'Expected header value', type => $type, size => $size;
+ $buf .= $val;
+ }
+
+ $type = to_header_constant($type);
+ if ($type == HEADER_END) {
+ # done
+ }
+ elsif ($type == HEADER_COMMENT) {
+ $val = decode('UTF-8', $val);
+ }
+ elsif ($type == HEADER_CIPHER_ID) {
+ $size == 16 or throw 'Invalid cipher UUID length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_COMPRESSION_FLAGS) {
+ $val = unpack('L<', $val);
+ }
+ elsif ($type == HEADER_MASTER_SEED) {
+ $size == 32 or throw 'Invalid master seed length', got => $size, expected => $size;
+ }
+ elsif ($type == HEADER_ENCRYPTION_IV) {
+ # nothing
+ }
+ elsif ($type == HEADER_KDF_PARAMETERS) {
+ open(my $dict_fh, '<', \$val);
+ $val = $self->_read_variant_dictionary($dict_fh);
+ }
+ elsif ($type == HEADER_PUBLIC_CUSTOM_DATA) {
+ open(my $dict_fh, '<', \$val);
+ $val = $self->_read_variant_dictionary($dict_fh);
+ }
+ elsif ($type == HEADER_INNER_RANDOM_STREAM_ID ||
+ $type == HEADER_INNER_RANDOM_STREAM_KEY ||
+ $type == HEADER_TRANSFORM_SEED ||
+ $type == HEADER_TRANSFORM_ROUNDS ||
+ $type == HEADER_STREAM_START_BYTES) {
+ throw "Unexpected KDBX3 header: $type", type => $type;
+ }
+ else {
+ alert "Unknown header: $type", type => $type;
+ }
+
+ return wantarray ? ($type => $val, $buf) : $buf;
+}
+
+sub _read_variant_dictionary {
+ my $self = shift;
+ my $fh = shift;
+
+ read_all $fh, my $buf, 2 or throw 'Failed to read variant dictionary version';
+ my ($version) = unpack('S<', $buf);
+ VMAP_VERSION == ($version & VMAP_VERSION_MAJOR_MASK)
+ or throw 'Unsupported variant dictionary version', version => $version;
+
+ my %dict;
+
+ while (1) {
+ read_all $fh, $buf, 1 or throw 'Failed to read variant type';
+ my ($type) = unpack('C', $buf);
+ last if $type == VMAP_TYPE_END; # terminating null
+
+ read_all $fh, $buf, 4 or throw 'Failed to read variant key size';
+ my ($klen) = unpack('L<', $buf);
+
+ read_all $fh, my $key, $klen or throw 'Failed to read variant key';
+
+ read_all $fh, $buf, 4 or throw 'Failed to read variant size';
+ my ($vlen) = unpack('L<', $buf);
+
+ read_all $fh, my $val, $vlen or throw 'Failed to read variant';
+
+ if ($type == VMAP_TYPE_UINT32) {
+ ($val) = unpack('L<', $val);
+ }
+ elsif ($type == VMAP_TYPE_UINT64) {
+ assert_64bit;
+ ($val) = unpack('Q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_BOOL) {
+ ($val) = unpack('C', $val);
+ $val = boolean($val);
+ }
+ elsif ($type == VMAP_TYPE_INT32) {
+ ($val) = unpack('l<', $val);
+ }
+ elsif ($type == VMAP_TYPE_INT64) {
+ assert_64bit;
+ ($val) = unpack('q<', $val);
+ }
+ elsif ($type == VMAP_TYPE_STRING) {
+ $val = decode('UTF-8', $val);
+ }
+ elsif ($type == VMAP_TYPE_BYTEARRAY) {
+ # nothing
+ }
+ else {
+ throw 'Unknown variant type', type => $type;
+ }
+ $dict{$key} = $val;
+ }
+
+ return \%dict;
+}
+
+sub _read_body {
+ my $self = shift;
+ my $fh = shift;
+ my $key = shift;
+ my $header_data = shift;
+ my $kdbx = $self->kdbx;
+
+ # assert all required headers present
+ for my $field (
+ HEADER_CIPHER_ID,
+ HEADER_ENCRYPTION_IV,
+ HEADER_MASTER_SEED,
+ ) {
+ defined $kdbx->headers->{$field} or throw "Missing $field";
+ }
+
+ my @cleanup;
+
+ # checksum check
+ read_all $fh, my $header_hash, 32 or throw 'Failed to read header hash';
+ my $got_header_hash = digest_data('SHA256', $header_data);
+ $got_header_hash eq $header_hash
+ or throw 'Data is corrupt (header checksum mismatch)',
+ got => $got_header_hash, expected => $header_hash;
+
+ $key = $kdbx->composite_key($key);
+ my $transformed_key = $kdbx->kdf->transform($key);
+ push @cleanup, erase_scoped $transformed_key;
+
+ # authentication check
+ read_all $fh, my $header_hmac, 32 or throw 'Failed to read header HMAC';
+ my $hmac_key = digest_data('SHA512', $kdbx->headers->{master_seed}, $transformed_key, "\x01");
+ push @cleanup, erase_scoped $hmac_key;
+ my $got_header_hmac = hmac('SHA256',
+ digest_data('SHA512', "\xff\xff\xff\xff\xff\xff\xff\xff", $hmac_key),
+ $header_data,
+ );
+ $got_header_hmac eq $header_hmac
+ or throw "Invalid credentials or data is corrupt (header HMAC mismatch)\n",
+ got => $got_header_hmac, expected => $header_hmac;
+
+ $kdbx->key($key);
+
+ $fh = File::KDBX::IO::HmacBlock->new($fh, key => $hmac_key);
+
+ my $final_key = digest_data('SHA256', $kdbx->headers->{master_seed}, $transformed_key);
+ push @cleanup, erase_scoped $final_key;
+
+ my $cipher = $kdbx->cipher(key => $final_key);
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
+
+ my $compress = $kdbx->headers->{+HEADER_COMPRESSION_FLAGS};
+ if ($compress == COMPRESSION_GZIP) {
+ load_optional('IO::Uncompress::Gunzip');
+ $fh = IO::Uncompress::Gunzip->new($fh)
+ or throw "Failed to initialize compression library: $IO::Uncompress::Gunzip::GunzipError",
+ error => $IO::Uncompress::Gunzip::GunzipError;
+ }
+ elsif ($compress != COMPRESSION_NONE) {
+ throw "Unsupported compression ($compress)\n", compression_flags => $compress;
+ }
+
+ $self->_read_inner_headers($fh);
+ $self->_read_inner_body($fh);
+}
+
+sub _read_inner_headers {
+ my $self = shift;
+ my $fh = shift;
+
+ while (my ($type, $val) = $self->_read_inner_header($fh)) {
+ last if $type == INNER_HEADER_END;
+ }
+}
+
+sub _read_inner_header {
+ my $self = shift;
+ my $fh = shift;
+ my $kdbx = $self->kdbx;
+
+ read_all $fh, my $buf, 5 or throw 'Expected inner header type and size';
+ my ($type, $size) = unpack('C L<', $buf);
+
+ my $val;
+ if (0 < $size) {
+ read_all $fh, $val, $size or throw 'Expected inner header value', type => $type, size => $size;
+ }
+
+ $type = to_inner_header_constant($type) // $type;
+ if ($type == INNER_HEADER_END) {
+ # nothing
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_ID) {
+ $val = unpack('L<', $val);
+ $kdbx->inner_headers->{$type} = $val;
+ }
+ elsif ($type == INNER_HEADER_INNER_RANDOM_STREAM_KEY) {
+ $kdbx->inner_headers->{$type} = $val;
+ }
+ elsif ($type == INNER_HEADER_BINARY) {
+ my $msize = $size - 1;
+ my ($flags, $data) = unpack("C a$msize", $val);
+ my $id = scalar keys %{$kdbx->binaries};
+ $kdbx->binaries->{$id} = {
+ value => $data,
+ $flags & INNER_HEADER_BINARY_FLAG_PROTECT ? (protect => true) : (),
+ };
+ }
+ else {
+ alert "Ignoring unknown inner header type ($type)", type => $type, size => $size, value => $val;
+ return wantarray ? ($type => $val) : $type;
+ }
+
+ return wantarray ? ($type => $val) : $type;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Loader::V4 - Load KDBX4 files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Loader::XML;
+# ABSTRACT: Load unencrypted XML KeePass files
+
+use warnings;
+use strict;
+
+use Crypt::Misc 0.029 qw(decode_b64);
+use Encode qw(decode);
+use File::KDBX::Constants qw(:version :time);
+use File::KDBX::Error;
+use File::KDBX::Safe;
+use File::KDBX::Util qw(:class :text assert_64bit gunzip erase_scoped);
+use Scalar::Util qw(looks_like_number);
+use Time::Piece;
+use XML::LibXML::Reader;
+use boolean;
+use namespace::clean;
+
+extends 'File::KDBX::Loader';
+
+our $VERSION = '0.800'; # VERSION
+
+has '_reader', is => 'ro';
+has '_safe', is => 'ro', default => sub { File::KDBX::Safe->new(cipher => $_[0]->kdbx->random_stream) };
+
+sub _read {
+ my $self = shift;
+ my $fh = shift;
+
+ $self->_read_inner_body($fh);
+}
+
+sub _read_inner_body {
+ my $self = shift;
+ my $fh = shift;
+
+ my $reader = $self->{_reader} = XML::LibXML::Reader->new(IO => $fh);
+
+ delete $self->{_safe};
+ my $root_done;
+
+ my $pattern = XML::LibXML::Pattern->new('/KeePassFile/Meta|/KeePassFile/Root');
+ while ($reader->nextPatternMatch($pattern) == 1) {
+ next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
+ my $name = $reader->localName;
+ if ($name eq 'Meta') {
+ $self->_read_xml_meta;
+ }
+ elsif ($name eq 'Root') {
+ if ($root_done) {
+ alert 'Ignoring extra Root element in KeePass XML file', line => $reader->lineNumber;
+ next;
+ }
+ $self->_read_xml_root;
+ $root_done = 1;
+ }
+ }
+
+ if ($reader->readState == XML_READER_ERROR) {
+ throw 'Failed to parse KeePass XML';
+ }
+
+ $self->kdbx->_safe($self->_safe) if $self->{_safe};
+
+ $self->_resolve_binary_refs;
+}
+
+sub _read_xml_meta {
+ my $self = shift;
+
+ $self->_read_xml_element($self->kdbx->meta,
+ Generator => 'text',
+ HeaderHash => 'binary',
+ DatabaseName => 'text',
+ DatabaseNameChanged => 'datetime',
+ DatabaseDescription => 'text',
+ DatabaseDescriptionChanged => 'datetime',
+ DefaultUserName => 'text',
+ DefaultUserNameChanged => 'datetime',
+ MaintenanceHistoryDays => 'number',
+ Color => 'text',
+ MasterKeyChanged => 'datetime',
+ MasterKeyChangeRec => 'number',
+ MasterKeyChangeForce => 'number',
+ MemoryProtection => \&_read_xml_memory_protection,
+ CustomIcons => \&_read_xml_custom_icons,
+ RecycleBinEnabled => 'bool',
+ RecycleBinUUID => 'uuid',
+ RecycleBinChanged => 'datetime',
+ EntryTemplatesGroup => 'uuid',
+ EntryTemplatesGroupChanged => 'datetime',
+ LastSelectedGroup => 'uuid',
+ LastTopVisibleGroup => 'uuid',
+ HistoryMaxItems => 'number',
+ HistoryMaxSize => 'number',
+ SettingsChanged => 'datetime',
+ Binaries => \&_read_xml_binaries,
+ CustomData => \&_read_xml_custom_data,
+ );
+}
+
+sub _read_xml_memory_protection {
+ my $self = shift;
+ my $meta = shift // $self->kdbx->meta;
+
+ return $self->_read_xml_element(
+ ProtectTitle => 'bool',
+ ProtectUserName => 'bool',
+ ProtectPassword => 'bool',
+ ProtectURL => 'bool',
+ ProtectNotes => 'bool',
+ AutoEnableVisualHiding => 'bool',
+ );
+}
+
+sub _read_xml_binaries {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ my $binaries = $self->_read_xml_element(
+ Binary => sub {
+ my $self = shift;
+ my $id = $self->_read_xml_attribute('ID');
+ my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false);
+ my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
+ my $data = $self->_read_xml_content('binary');
+
+ my $binary = {
+ value => $data,
+ $protected ? (protect => true) : (),
+ };
+
+ if ($protected) {
+ # if compressed, decompress later when the safe is unlocked
+ $self->_safe->add_protected($compressed ? \&gunzip : (), $binary);
+ }
+ elsif ($compressed) {
+ $binary->{value} = gunzip($data);
+ }
+
+ $id => $binary;
+ },
+ );
+
+ $kdbx->binaries({%{$kdbx->binaries}, %$binaries});
+ return (); # do not add to meta
+}
+
+sub _read_xml_custom_data {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Item => sub {
+ my $self = shift;
+ my $item = $self->_read_xml_element(
+ Key => 'text',
+ Value => 'text',
+ LastModificationTime => 'datetime', # KDBX4.1
+ );
+ $item->{key} => $item;
+ },
+ );
+}
+
+sub _read_xml_custom_icons {
+ my $self = shift;
+
+ return $self->_read_xml_element([],
+ Icon => sub {
+ my $self = shift;
+ $self->_read_xml_element(
+ UUID => 'uuid',
+ Data => 'binary',
+ Name => 'text', # KDBX4.1
+ LastModificationTime => 'datetime', # KDBX4.1
+ );
+ },
+ );
+}
+
+sub _read_xml_root {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ my $root = $self->_read_xml_element(
+ Group => \&_read_xml_group,
+ DeletedObjects => \&_read_xml_deleted_objects,
+ );
+
+ $kdbx->deleted_objects($root->{deleted_objects});
+ $kdbx->root($root->{group}) if $root->{group};
+}
+
+sub _read_xml_group {
+ my $self = shift;
+
+ return $self->_read_xml_element({entries => [], groups => []},
+ UUID => 'uuid',
+ Name => 'text',
+ Notes => 'text',
+ Tags => 'text', # KDBX4.1
+ IconID => 'number',
+ CustomIconUUID => 'uuid',
+ Times => \&_read_xml_times,
+ IsExpanded => 'bool',
+ DefaultAutoTypeSequence => 'text',
+ EnableAutoType => 'tristate',
+ EnableSearching => 'tristate',
+ LastTopVisibleEntry => 'uuid',
+ CustomData => \&_read_xml_custom_data, # KDBX4
+ PreviousParentGroup => 'uuid', # KDBX4.1
+ Entry => [entries => \&_read_xml_entry],
+ Group => [groups => \&_read_xml_group],
+ );
+}
+
+sub _read_xml_entry {
+ my $self = shift;
+
+ my $entry = $self->_read_xml_element({strings => [], binaries => []},
+ UUID => 'uuid',
+ IconID => 'number',
+ CustomIconUUID => 'uuid',
+ ForegroundColor => 'text',
+ BackgroundColor => 'text',
+ OverrideURL => 'text',
+ Tags => 'text',
+ Times => \&_read_xml_times,
+ AutoType => \&_read_xml_entry_auto_type,
+ PreviousParentGroup => 'uuid', # KDBX4.1
+ QualityCheck => 'bool', # KDBX4.1
+ String => [strings => \&_read_xml_entry_string],
+ Binary => [binaries => \&_read_xml_entry_binary],
+ CustomData => \&_read_xml_custom_data, # KDBX4
+ History => sub {
+ my $self = shift;
+ return $self->_read_xml_element([],
+ Entry => \&_read_xml_entry,
+ );
+ },
+ );
+
+ my %strings;
+ for my $string (@{$entry->{strings} || []}) {
+ $strings{$string->{key}} = $string->{value};
+ }
+ $entry->{strings} = \%strings;
+
+ my %binaries;
+ for my $binary (@{$entry->{binaries} || []}) {
+ $binaries{$binary->{key}} = $binary->{value};
+ }
+ $entry->{binaries} = \%binaries;
+
+ return $entry;
+}
+
+sub _read_xml_times {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ LastModificationTime => 'datetime',
+ CreationTime => 'datetime',
+ LastAccessTime => 'datetime',
+ ExpiryTime => 'datetime',
+ Expires => 'bool',
+ UsageCount => 'number',
+ LocationChanged => 'datetime',
+ );
+}
+
+sub _read_xml_entry_string {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Key => 'text',
+ Value => sub {
+ my $self = shift;
+
+ my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
+ my $protect_in_memory = $self->_read_xml_attribute('ProtectInMemory', 'bool', false);
+ my $protect = $protected || $protect_in_memory;
+
+ my $val = $self->_read_xml_content($protected ? 'binary' : 'text');
+
+ my $string = {
+ value => $val,
+ $protect ? (protect => true) : (),
+ };
+
+ $self->_safe->add_protected(sub { decode('UTF-8', $_[0]) }, $string) if $protected;
+
+ $string;
+ },
+ );
+}
+
+sub _read_xml_entry_binary {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ Key => 'text',
+ Value => sub {
+ my $self = shift;
+
+ my $ref = $self->_read_xml_attribute('Ref');
+ my $compressed = $self->_read_xml_attribute('Compressed', 'bool', false);
+ my $protected = $self->_read_xml_attribute('Protected', 'bool', false);
+ my $binary = {};
+
+ if (defined $ref) {
+ $binary->{ref} = $ref;
+ }
+ else {
+ $binary->{value} = $self->_read_xml_content('binary');
+ $binary->{protect} = true if $protected;
+
+ if ($protected) {
+ # if compressed, decompress later when the safe is unlocked
+ $self->_safe->add_protected($compressed ? \&gunzip : (), $binary);
+ }
+ elsif ($compressed) {
+ $binary->{value} = gunzip($binary->{value});
+ }
+ }
+
+ $binary;
+ },
+ );
+}
+
+sub _read_xml_entry_auto_type {
+ my $self = shift;
+
+ return $self->_read_xml_element({associations => []},
+ Enabled => 'bool',
+ DataTransferObfuscation => 'number',
+ DefaultSequence => 'text',
+ Association => [associations => sub {
+ my $self = shift;
+ return $self->_read_xml_element(
+ Window => 'text',
+ KeystrokeSequence => 'text',
+ );
+ }],
+ );
+}
+
+sub _read_xml_deleted_objects {
+ my $self = shift;
+
+ return $self->_read_xml_element(
+ DeletedObject => sub {
+ my $self = shift;
+ my $object = $self->_read_xml_element(
+ UUID => 'uuid',
+ DeletionTime => 'datetime',
+ );
+ $object->{uuid} => $object;
+ }
+ );
+}
+
+##############################################################################
+
+sub _resolve_binary_refs {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+
+ my $pool = $kdbx->binaries;
+
+ my $entries = $kdbx->entries(history => 1);
+ while (my $entry = $entries->next) {
+ while (my ($key, $binary) = each %{$entry->binaries}) {
+ my $ref = $binary->{ref} // next;
+ next if defined $binary->{value};
+
+ my $data = $pool->{$ref};
+ if (!defined $data || !defined $data->{value}) {
+ alert "Found a reference to a missing binary: $key", key => $key, ref => $ref;
+ next;
+ }
+ $binary->{value} = $data->{value};
+ $binary->{protect} = true if $data->{protect};
+ delete $binary->{ref};
+ }
+ }
+}
+
+##############################################################################
+
+sub _read_xml_element {
+ my $self = shift;
+ my $args = @_ % 2 == 1 ? shift : {};
+ my %spec = @_;
+
+ my $reader = $self->_reader;
+ my $path = $reader->nodePath;
+ $path =~ s!\Q/text()\E$!!;
+
+ return $args if $reader->isEmptyElement;
+
+ my $store = ref $args eq 'CODE' ? $args
+ : ref $args eq 'HASH' ? sub {
+ my ($key, $val) = @_;
+ if (ref $args->{$key} eq 'HASH') {
+ $args->{$key}{$key} = $val;
+ }
+ elsif (ref $args->{$key} eq 'ARRAY') {
+ push @{$args->{$key}}, $val;
+ }
+ else {
+ exists $args->{$key}
+ and alert 'Overwriting value', node => $reader->nodePath, line => $reader->lineNumber;
+ $args->{$key} = $val;
+ }
+ } : ref $args eq 'ARRAY' ? sub {
+ my ($key, $val) = @_;
+ push @$args, $val;
+ } : sub {};
+
+ my $pattern = XML::LibXML::Pattern->new("${path}|${path}/*");
+ while ($reader->nextPatternMatch($pattern) == 1) {
+ last if $reader->nodePath eq $path && $reader->nodeType == XML_READER_TYPE_END_ELEMENT;
+ next if $reader->nodeType != XML_READER_TYPE_ELEMENT;
+
+ my $name = $reader->localName;
+ my $key = snakify($name);
+ my $type = $spec{$name};
+ ($key, $type) = @$type if ref $type eq 'ARRAY';
+
+ if (!defined $type) {
+ exists $spec{$name} or alert "Ignoring unknown element: $name",
+ node => $reader->nodePath,
+ line => $reader->lineNumber;
+ next;
+ }
+
+ if (ref $type eq 'CODE') {
+ my @result = $self->$type($args, $reader->nodePath);
+ if (@result == 2) {
+ $store->(@result);
+ }
+ elsif (@result == 1) {
+ $store->($key, @result);
+ }
+ }
+ else {
+ $store->($key, $self->_read_xml_content($type));
+ }
+ }
+
+ return $args;
+}
+
+sub _read_xml_attribute {
+ my $self = shift;
+ my $name = shift;
+ my $type = shift // 'text';
+ my $default = shift;
+ my $reader = $self->_reader;
+
+ return $default if !$reader->hasAttributes;
+
+ my $value = trim($reader->getAttribute($name));
+ if (!defined $value) {
+ # try again after reading in all the attributes
+ $reader->moveToFirstAttribute;
+ while ($self->_reader->readAttributeValue == 1) {}
+ $reader->moveToElement;
+
+ $value = trim($reader->getAttribute($name));
+ }
+
+ return $default if !defined $value;
+
+ my $decoded = eval { _decode_primitive($value, $type) };
+ if (my $err = $@) {
+ ref $err and $err->details(attribute => $name, node => $reader->nodePath, line => $reader->lineNumber);
+ throw $err
+ }
+
+ return $decoded;
+}
+
+sub _read_xml_content {
+ my $self = shift;
+ my $type = shift;
+ my $reader = $self->_reader;
+
+ $reader->read if !$reader->isEmptyElement; # step into element
+ return '' if !$reader->hasValue;
+
+ my $content = trim($reader->value);
+
+ my $decoded = eval { _decode_primitive($content, $type) };
+ if (my $err = $@) {
+ ref $err and $err->details(node => $reader->nodePath, line => $reader->lineNumber);
+ throw $err
+ }
+
+ return $decoded;
+}
+
+##############################################################################
+
+sub _decode_primitive { goto &{__PACKAGE__."::_decode_$_[1]"} }
+
+sub _decode_binary {
+ local $_ = shift;
+ return '' if !defined || (ref && !defined $$_);
+ $_ = eval { decode_b64(ref $_ ? $$_ : $_) };
+ my $err = $@;
+ my $cleanup = erase_scoped $_;
+ $err and throw 'Failed to parse binary', error => $err;
+ return $_;
+}
+
+sub _decode_bool {
+ local $_ = shift;
+ return true if /^True$/i;
+ return false if /^False$/i;
+ return false if length($_) == 0;
+ throw 'Expected boolean', text => $_;
+}
+
+sub _decode_datetime {
+ local $_ = shift;
+
+ if (/^[A-Za-z0-9\+\/\=]+$/) {
+ my $binary = eval { decode_b64($_) };
+ if (my $err = $@) {
+ throw 'Failed to parse binary datetime', text => $_, error => $err;
+ }
+ throw $@ if $@;
+ assert_64bit;
+ $binary .= \0 x (8 - length($binary)) if length($binary) < 8;
+ my ($seconds_since_ad1) = unpack('Q<', $binary);
+ my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH;
+ return Time::Piece->new($epoch);
+ }
+
+
+ my $dt = eval { Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%SZ') };
+ if (my $err = $@) {
+ throw 'Failed to parse datetime', text => $_, error => $err;
+ }
+ return $dt;
+}
+
+sub _decode_tristate {
+ local $_ = shift;
+ return undef if /^null$/i;
+ my $tristate = eval { _decode_bool($_) };
+ $@ and throw 'Expected tristate', text => $_, error => $@;
+ return $tristate;
+}
+
+sub _decode_number {
+ local $_ = shift;
+ $_ = _decode_text($_);
+ looks_like_number($_) or throw 'Expected number', text => $_;
+ return $_+0;
+}
+
+sub _decode_text {
+ local $_ = shift;
+ return '' if !defined;
+ return $_;
+}
+
+sub _decode_uuid {
+ local $_ = shift;
+ my $uuid = eval { _decode_binary($_) };
+ $@ and throw 'Expected UUID', text => $_, error => $@;
+ length($uuid) == 16 or throw 'Invalid UUID size', size => length($uuid);
+ return $uuid;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Loader::XML - Load unencrypted XML KeePass files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Object;
+# ABSTRACT: A KDBX database object
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Constants qw(:bool);
+use File::KDBX::Error;
+use File::KDBX::Util qw(:uuid);
+use Hash::Util::FieldHash qw(fieldhashes);
+use List::Util qw(any first);
+use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref);
+use Scalar::Util qw(blessed weaken);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+fieldhashes \my (%KDBX, %PARENT, %TXNS, %REFS, %SIGNALS);
+
+
+sub new {
+ my $class = shift;
+
+ # copy constructor
+ return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class);
+
+ my $data;
+ $data = shift if is_plain_hashref($_[0]);
+
+ my $kdbx;
+ $kdbx = shift if @_ % 2 == 1;
+
+ my %args = @_;
+ $args{kdbx} //= $kdbx if defined $kdbx;
+
+ my $self = bless $data // {}, $class;
+ $self->init(%args);
+ $self->_set_nonlazy_attributes if !$data;
+ return $self;
+}
+
+sub _set_nonlazy_attributes { die 'Not implemented' }
+
+
+sub init {
+ my $self = shift;
+ my %args = @_;
+
+ while (my ($key, $val) = each %args) {
+ if (my $method = $self->can($key)) {
+ $self->$method($val);
+ }
+ }
+
+ return $self;
+}
+
+
+sub wrap {
+ my $class = shift;
+ my $object = shift;
+ return $object if blessed $object && $object->isa($class);
+ return $class->new(@_, @$object) if is_arrayref($object);
+ return $class->new($object, @_);
+}
+
+
+sub label { die 'Not implemented' }
+
+
+my %CLONE = (entries => 1, groups => 1, history => 1);
+sub clone {
+ my $self = shift;
+ my %args = @_;
+
+ local $CLONE{new_uuid} = $args{new_uuid} // $args{parent} // 0;
+ local $CLONE{entries} = $args{entries} // 1;
+ local $CLONE{groups} = $args{groups} // 1;
+ local $CLONE{history} = $args{history} // 1;
+ local $CLONE{reference_password} = $args{reference_password} // 0;
+ local $CLONE{reference_username} = $args{reference_username} // 0;
+
+ require Storable;
+ my $copy = Storable::dclone($self);
+
+ if ($args{relabel} and my $label = $self->label) {
+ $copy->label("$label - Copy");
+ }
+ if ($args{parent} and my $parent = $self->group) {
+ $parent->add_object($copy);
+ }
+
+ return $copy;
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+ my $cloning = shift;
+
+ my $copy = {%$self};
+ delete $copy->{entries} if !$CLONE{entries};
+ delete $copy->{groups} if !$CLONE{groups};
+ delete $copy->{history} if !$CLONE{history};
+
+ return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy;
+}
+
+sub STORABLE_thaw {
+ my $self = shift;
+ my $cloning = shift;
+ my $addr = shift;
+ my $copy = shift;
+
+ @$self{keys %$copy} = values %$copy;
+
+ if ($cloning) {
+ my $kdbx = $KDBX{$addr};
+ $self->kdbx($kdbx) if $kdbx;
+ }
+
+ if (defined $self->{uuid}) {
+ if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) {
+ my $uuid = format_uuid($self->{uuid});
+ my $clone_obj = do {
+ local $CLONE{new_uuid} = 0;
+ local $CLONE{entries} = 1;
+ local $CLONE{groups} = 1;
+ local $CLONE{history} = 1;
+ local $CLONE{reference_password} = 0;
+ local $CLONE{reference_username} = 0;
+ # Clone only the entry's data and manually bless to avoid infinite recursion.
+ bless Storable::dclone({%$copy}), 'File::KDBX::Entry';
+ };
+ my $txn = $self->begin_work(snapshot => $clone_obj);
+ if ($CLONE{reference_password}) {
+ $self->password("{REF:P\@I:$uuid}");
+ }
+ if ($CLONE{reference_username}) {
+ $self->username("{REF:U\@I:$uuid}");
+ }
+ $txn->commit;
+ }
+ $self->uuid(generate_uuid) if $CLONE{new_uuid};
+ }
+
+ # Dualvars aren't cloned as dualvars, so dualify the icon.
+ $self->icon_id($self->{icon_id}) if defined $self->{icon_id};
+}
+
+
+sub kdbx {
+ my $self = shift;
+ $self = $self->new if !ref $self;
+ if (@_) {
+ if (my $kdbx = shift) {
+ $KDBX{$self} = $kdbx;
+ weaken $KDBX{$self};
+ }
+ else {
+ delete $KDBX{$self};
+ }
+ }
+ $KDBX{$self} or throw 'Object is disconnected', object => $self;
+}
+
+
+sub is_connected {
+ my $self = shift;
+ return !!eval { $self->kdbx };
+}
+
+
+sub id { format_uuid(shift->uuid, @_) }
+
+
+sub group {
+ my $self = shift;
+
+ if (my $new_group = shift) {
+ my $old_group = $self->group;
+ return $new_group if Hash::Util::FieldHash::id($old_group) == Hash::Util::FieldHash::id($new_group);
+ # move to a new parent
+ $self->remove(signal => 0) if $old_group;
+ $self->location_changed('now');
+ $new_group->add_object($self);
+ }
+
+ my $id = Hash::Util::FieldHash::id($self);
+ if (my $group = $PARENT{$self}) {
+ my $method = $self->_parent_container;
+ return $group if first { $id == Hash::Util::FieldHash::id($_) } @{$group->$method};
+ delete $PARENT{$self};
+ }
+ # always get lineage from root to leaf because the other way requires parent, so it would be recursive
+ my $lineage = $self->kdbx->_trace_lineage($self) or return;
+ my $group = pop @$lineage or return;
+ $PARENT{$self} = $group; weaken $PARENT{$self};
+ return $group;
+}
+
+sub _set_group {
+ my $self = shift;
+ if (my $parent = shift) {
+ $PARENT{$self} = $parent;
+ weaken $PARENT{$self};
+ }
+ else {
+ delete $PARENT{$self};
+ }
+ return $self;
+}
+
+### Name of the parent attribute expected to contain the object
+sub _parent_container { die 'Not implemented' }
+
+
+sub lineage {
+ my $self = shift;
+ my $base = shift;
+
+ my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0;
+
+ # try leaf to root
+ my @path;
+ my $object = $self;
+ while ($object = $object->group) {
+ unshift @path, $object;
+ last if $base_addr == Hash::Util::FieldHash::id($object);
+ }
+ return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root);
+
+ # try root to leaf
+ return $self->kdbx->_trace_lineage($self, $base);
+}
+
+
+sub remove {
+ my $self = shift;
+ my $parent = $self->group;
+ $parent->remove_object($self, @_) if $parent;
+ $self->_set_group(undef);
+ return $self;
+}
+
+
+sub recycle {
+ my $self = shift;
+ return $self->group($self->kdbx->recycle_bin);
+}
+
+
+sub recycle_or_remove {
+ my $self = shift;
+ my $kdbx = eval { $self->kdbx };
+ if ($kdbx && $kdbx->recycle_bin_enabled && !$self->is_recycled) {
+ $self->recycle;
+ }
+ else {
+ $self->remove;
+ }
+}
+
+
+sub is_recycled {
+ my $self = shift;
+ eval { $self->kdbx } or return FALSE;
+ return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage});
+}
+
+##############################################################################
+
+
+sub tag_list {
+ my $self = shift;
+ return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // '');
+}
+
+
+sub custom_icon {
+ my $self = shift;
+ my $kdbx = $self->kdbx;
+ if (@_) {
+ my $img = shift;
+ my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef;
+ $self->icon_id(0) if $uuid;
+ $self->custom_icon_uuid($uuid);
+ return $img;
+ }
+ return $kdbx->custom_icon_data($self->custom_icon_uuid);
+}
+
+
+sub custom_data {
+ my $self = shift;
+ $self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]);
+ return $self->{custom_data} //= {} if !@_;
+
+ my %args = @_ == 2 ? (key => shift, value => shift)
+ : @_ % 2 == 1 ? (key => shift, @_) : @_;
+
+ if (!$args{key} && !$args{value}) {
+ my %standard = (key => 1, value => 1, last_modification_time => 1);
+ my @other_keys = grep { !$standard{$_} } keys %args;
+ if (@other_keys == 1) {
+ my $key = $args{key} = $other_keys[0];
+ $args{value} = delete $args{$key};
+ }
+ }
+
+ my $key = $args{key} or throw 'Must provide a custom_data key to access';
+
+ return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value});
+
+ while (my ($field, $value) = each %args) {
+ $self->{custom_data}{$key}{$field} = $value;
+ }
+ return $self->{custom_data}{$key};
+}
+
+
+sub custom_data_value {
+ my $self = shift;
+ my $data = $self->custom_data(@_) // return undef;
+ return $data->{value};
+}
+
+##############################################################################
+
+
+sub begin_work {
+ my $self = shift;
+
+ if (defined wantarray) {
+ require File::KDBX::Transaction;
+ return File::KDBX::Transaction->new($self, @_);
+ }
+
+ my %args = @_;
+ my $orig = $args{snapshot} // do {
+ my $c = $self->clone(
+ entries => $args{entries} // 0,
+ groups => $args{groups} // 0,
+ history => $args{history} // 0,
+ );
+ $c->{entries} = $self->{entries} if !$args{entries};
+ $c->{groups} = $self->{groups} if !$args{groups};
+ $c->{history} = $self->{history} if !$args{history};
+ $c;
+ };
+
+ my $id = Hash::Util::FieldHash::id($orig);
+ _save_references($id, $self, $orig);
+
+ $self->_signal_begin_work;
+
+ push @{$self->_txns}, $orig;
+}
+
+
+sub commit {
+ my $self = shift;
+ my $orig = pop @{$self->_txns} or return $self;
+ $self->_commit($orig);
+ my $signals = $self->_signal_commit;
+ $self->_signal_send($signals) if !$self->_in_txn;
+ return $self;
+}
+
+
+sub rollback {
+ my $self = shift;
+
+ my $orig = pop @{$self->_txns} or return $self;
+
+ my $id = Hash::Util::FieldHash::id($orig);
+ _restore_references($id, $orig);
+
+ $self->_signal_rollback;
+
+ return $self;
+}
+
+# Get whether or not there is at least one pending transaction.
+sub _in_txn { scalar @{$_[0]->_txns} }
+
+# Get an array ref of pending transactions.
+sub _txns { $TXNS{$_[0]} //= [] }
+
+# The _commit hook notifies subclasses that a commit has occurred.
+sub _commit { die 'Not implemented' }
+
+# Get a reference to an object that represents an object's committed state. If there is no pending
+# transaction, this is just $self. If there is a transaction, this is the snapshot take before the transaction
+# began. This method is private because it provides direct access to the actual snapshot. It is important that
+# the snapshot not be changed or a rollback would roll back to an altered state.
+# This is used by File::KDBX::Dumper::XML so as to not dump uncommitted changes.
+sub _committed {
+ my $self = shift;
+ my ($orig) = @{$self->_txns};
+ return $orig // $self;
+}
+
+# In addition to cloning an object when beginning work, we also keep track its hashrefs and arrayrefs
+# internally so that we can restore to the very same structures in the case of a rollback.
+sub _save_references {
+ my $id = shift;
+ my $self = shift;
+ my $orig = shift;
+
+ if (is_plain_arrayref($orig)) {
+ for (my $i = 0; $i < @$orig; ++$i) {
+ _save_references($id, $self->[$i], $orig->[$i]);
+ }
+ $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self;
+ }
+ elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) {
+ for my $key (keys %$orig) {
+ _save_references($id, $self->{$key}, $orig->{$key});
+ }
+ $REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self;
+ }
+}
+
+# During a rollback, copy data from the snapshot back into the original internal structures.
+sub _restore_references {
+ my $id = shift;
+ my $orig = shift // return;
+ my $self = delete $REFS{$id}{Hash::Util::FieldHash::id($orig) // ''} // return $orig;
+
+ if (is_plain_arrayref($orig)) {
+ @$self = map { _restore_references($id, $_) } @$orig;
+ }
+ elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) {
+ for my $key (keys %$orig) {
+ # next if is_ref($orig->{$key}) &&
+ # (Hash::Util::FieldHash::id($self->{$key}) // 0) == Hash::Util::FieldHash::id($orig->{$key});
+ $self->{$key} = _restore_references($id, $orig->{$key});
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+sub _signal {
+ my $self = shift;
+ my $type = shift;
+
+ if ($self->_in_txn) {
+ my $stack = $self->_signal_stack;
+ my $queue = $stack->[-1];
+ push @$queue, [$type, @_];
+ }
+
+ $self->_signal_send([[$type, @_]]);
+
+ return $self;
+}
+
+sub _signal_stack { $SIGNALS{$_[0]} //= [] }
+
+sub _signal_begin_work {
+ my $self = shift;
+ push @{$self->_signal_stack}, [];
+}
+
+sub _signal_commit {
+ my $self = shift;
+ my $signals = pop @{$self->_signal_stack};
+ my $previous = $self->_signal_stack->[-1] // [];
+ push @$previous, @$signals;
+ return $previous;
+}
+
+sub _signal_rollback {
+ my $self = shift;
+ pop @{$self->_signal_stack};
+}
+
+sub _signal_send {
+ my $self = shift;
+ my $signals = shift // [];
+
+ my $kdbx = $KDBX{$self} or return;
+
+ # de-duplicate, keeping the most recent signal for each type
+ my %seen;
+ my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals;
+
+ for my $sig (reverse @signals) {
+ $kdbx->_handle_signal($self, @$sig);
+ }
+}
+
+##############################################################################
+
+sub _wrap_group {
+ my $self = shift;
+ my $group = shift;
+ require File::KDBX::Group;
+ return File::KDBX::Group->wrap($group, $KDBX{$self});
+}
+
+sub _wrap_entry {
+ my $self = shift;
+ my $entry = shift;
+ require File::KDBX::Entry;
+ return File::KDBX::Entry->wrap($entry, $KDBX{$self});
+}
+
+sub TO_JSON { +{%{$_[0]}} }
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Object - A KDBX database object
+
+=head1 VERSION
+
+version 0.800
+
+=head1 DESCRIPTION
+
+KDBX is an object database. This abstract class represents an object. You should not use this class directly
+but instead use its subclasses:
+
+=over 4
+
+=item *
+
+L<File::KDBX::Entry>
+
+=item *
+
+L<File::KDBX::Group>
+
+=back
+
+There is some functionality shared by both types of objects, and that's what this class provides.
+
+Each object can be connected with a L<File::KDBX> database or be disconnected. A disconnected object exists in
+memory but will not be persisted when dumping a database. It is also possible for an object to be connected
+with a database but not be part of the object tree (i.e. is not the root group or any subroup or entry).
+A disconnected object or an object not part of the object tree of a database can be added to a database using
+one of:
+
+=over 4
+
+=item *
+
+L<File::KDBX/add_entry>
+
+=item *
+
+L<File::KDBX/add_group>
+
+=item *
+
+L<File::KDBX::Group/add_entry>
+
+=item *
+
+L<File::KDBX::Group/add_group>
+
+=item *
+
+L<File::KDBX::Entry/add_historical_entry>
+
+=back
+
+It is possible to copy or move objects between databases, but B<DO NOT> include the same object in more
+than one database at once or there could be some strange aliasing effects (i.e. changes in one database might
+effect another in unexpected ways). This could lead to difficult-to-debug problems. It is similarly not safe
+or valid to add the same object multiple times to the same database. For example:
+
+ my $entry = File::KDBX::Entry->(title => 'Whatever');
+
+ # DO NOT DO THIS:
+ $kdbx->add_entry($entry);
+ $another_kdbx->add_entry($entry);
+
+ # DO NOT DO THIS:
+ $kdbx->add_entry($entry);
+ $kdbx->add_entry($entry); # again
+
+Instead, do this:
+
+ # Copy an entry to multiple databases:
+ $kdbx->add_entry($entry);
+ $another_kdbx->add_entry($entry->clone);
+
+ # OR move an existing entry from one database to another:
+ $another_kdbx->add_entry($entry->remove);
+
+=head1 ATTRIBUTES
+
+=head2 kdbx
+
+ $kdbx = $object->kdbx;
+ $object->kdbx($kdbx);
+
+Get or set the L<File::KDBX> instance connected with this object.
+
+=head1 METHODS
+
+=head2 new
+
+ $object = File::KDBX::Object->new;
+ $object = File::KDBX::Object->new(%attributes);
+ $object = File::KDBX::Object->new(\%data);
+ $object = File::KDBX::Object->new(\%data, $kdbx);
+
+Construct a new KDBX object.
+
+There is a subtlety to take note of. There is a significant difference between:
+
+ File::KDBX::Entry->new(username => 'iambatman');
+
+and:
+
+ File::KDBX::Entry->new({username => 'iambatman'}); # WRONG
+
+In the first, an empty object is first created and then initialized with whatever I<attributes> are given. In
+the second, a hashref is blessed and essentially becomes the object. The significance is that the hashref
+key-value pairs will remain as-is so the structure is expected to adhere to the shape of a raw B<Object>
+(which varies based on the type of object), whereas with the first the attributes will set the structure in
+the correct way (just like using the object accessors / getters / setters).
+
+The second example isn't I<generally> wrong -- this type of construction is supported for a reason, to allow
+for working with KDBX objects at a low level -- but it is wrong in this specific case only because
+C<< {username => $str} >> isn't a valid raw KDBX entry object. The L</username> attribute is really a proxy
+for the C<UserName> string, so the equivalent raw entry object should be
+C<< {strings => {UserName => {value => $str}}} >>. These are roughly equivalent:
+
+ File::KDBX::Entry->new(username => 'iambatman');
+ File::KDBX::Entry->new({strings => {UserName => {value => 'iambatman'}}});
+
+If this explanation went over your head, that's fine. Just stick with the attributes since they are typically
+easier to use correctly and provide the most convenience. If in the future you think of some kind of KDBX
+object manipulation you want to do that isn't supported by the accessors and methods, just know you I<can>
+access an object's data directly.
+
+=head2 init
+
+ $object = $object->init(%attributes);
+
+Called by the constructor to set attributes. You normally should not call this.
+
+=head2 wrap
+
+ $object = File::KDBX::Object->wrap($object);
+
+Ensure that a KDBX object is blessed.
+
+=head2 label
+
+ $label = $object->label;
+ $object->label($label);
+
+Get or set the object's label, a text string that can act as a non-unique identifier. For an entry, the label
+is its title string. For a group, the label is its name.
+
+=head2 clone
+
+ $object_copy = $object->clone(%options);
+ $object_copy = File::KDBX::Object->new($object);
+
+Make a clone of an object. By default the clone is indeed an exact copy that is connected to the same database
+but not actually included in the object tree (i.e. it has no parent group). Some options are allowed to get
+different effects:
+
+=over 4
+
+=item *
+
+C<new_uuid> - If set, generate a new UUID for the copy (default: false)
+
+=item *
+
+C<parent> - If set, add the copy to the same parent group, if any (default: false)
+
+=item *
+
+C<relabel> - If set, append " - Copy" to the object's title or name (default: false)
+
+=item *
+
+C<entries> - If set, copy child entries, if any (default: true)
+
+=item *
+
+C<groups> - If set, copy child groups, if any (default: true)
+
+=item *
+
+C<history> - If set, copy entry history, if any (default: true)
+
+=item *
+
+C<reference_password> - Toggle whether or not cloned entry's Password string should be set as a field reference to the original entry's Password string (default: false)
+
+=item *
+
+C<reference_username> - Toggle whether or not cloned entry's UserName string should be set as a field reference to the original entry's UserName string (default: false)
+
+=back
+
+=head2 is_connected
+
+ $bool = $object->is_connected;
+
+Determine whether or not an object is connected to a database.
+
+=head2 id
+
+ $string_uuid = $object->id;
+ $string_uuid = $object->id($delimiter);
+
+Get the unique identifier for this object as a B<formatted> UUID string, typically for display purposes. You
+could use this to compare with other identifiers formatted with the same delimiter, but it is more efficient
+to use the raw UUID for that purpose (see L</uuid>).
+
+A delimiter can optionally be provided to break up the UUID string visually. See
+L<File::KDBX::Util/format_uuid>.
+
+=head2 group
+
+ $parent_group = $object->group;
+ $object->group($parent_group);
+
+Get or set the parent group to which an object belongs or C<undef> if it belongs to no group.
+
+=head2 lineage
+
+ \@lineage = $object->lineage;
+ \@lineage = $object->lineage($base_group);
+
+Get the direct line of ancestors from C<$base_group> (default: the root group) to an object. The lineage
+includes the base group but I<not> the target object. Returns C<undef> if the target is not in the database
+structure. Returns an empty arrayref is the object itself is a root group.
+
+=head2 remove
+
+ $object = $object->remove(%options);
+
+Remove an object from its parent. If the object is a group, all contained objects stay with the object and so
+are removed as well. Options:
+
+=over 4
+
+=item *
+
+C<signal> Whether or not to signal the removal to the connected database (default: true)
+
+=back
+
+=head2 recycle
+
+ $object = $object->recycle;
+
+Remove an object from its parent and add it to the connected database's recycle bin group.
+
+=head2 recycle_or_remove
+
+ $object = $object->recycle_or_remove;
+
+Recycle or remove an object, depending on the connected database's L<File::KDBX/recycle_bin_enabled>. If the
+object is not connected to a database or is already in the recycle bin, remove it.
+
+=head2 is_recycled
+
+ $bool = $object->is_recycled;
+
+Get whether or not an object is in a recycle bin.
+
+=head2 tag_list
+
+ @tags = $entry->tag_list;
+
+Get a list of tags, split from L</tag> using delimiters C<,>, C<.>, C<:>, C<;> and whitespace.
+
+=head2 custom_icon
+
+ $image_data = $object->custom_icon;
+ $image_data = $object->custom_icon($image_data, %attributes);
+
+Get or set an icon image. Returns C<undef> if there is no custom icon set. Setting a custom icon will change
+the L</custom_icon_uuid> attribute.
+
+Custom icon attributes (supported in KDBX4.1 and greater):
+
+=over 4
+
+=item *
+
+C<name> - Name of the icon (text)
+
+=item *
+
+C<last_modification_time> - Just what it says (datetime)
+
+=back
+
+=head2 custom_data
+
+ \%all_data = $object->custom_data;
+ $object->custom_data(\%all_data);
+
+ \%data = $object->custom_data($key);
+ $object->custom_data($key => \%data);
+ $object->custom_data(%data);
+ $object->custom_data(key => $value, %data);
+
+Get and set custom data. Custom data is metadata associated with an object.
+
+Each data item can have a few attributes associated with it.
+
+=over 4
+
+=item *
+
+C<key> - A unique text string identifier used to look up the data item (required)
+
+=item *
+
+C<value> - A text string value (required)
+
+=item *
+
+C<last_modification_time> (optional, KDBX4.1+)
+
+=back
+
+=head2 custom_data_value
+
+ $value = $object->custom_data_value($key);
+
+Exactly the same as L</custom_data> except returns just the custom data's value rather than a structure of
+attributes. This is a shortcut for:
+
+ my $data = $object->custom_data($key);
+ my $value = defined $data ? $data->{value} : undef;
+
+=head2 begin_work
+
+ $txn = $object->begin_work(%options);
+ $object->begin_work(%options);
+
+Begin a new transaction. Returns a L<File::KDBX::Transaction> object that can be scoped to ensure a rollback
+occurs if exceptions are thrown. Alternatively, if called in void context, there will be no
+B<File::KDBX::Transaction> and it is instead your responsibility to call L</commit> or L</rollback> as
+appropriate. It is undefined behavior to call these if a B<File::KDBX::Transaction> exists. Recursive
+transactions are allowed.
+
+Signals created during a transaction are delayed until all transactions are resolved. If the outermost
+transaction is committed, then the signals are de-duplicated and delivered. Otherwise the signals are dropped.
+This means that the KDBX database will not fix broken references or mark itself dirty until after the
+transaction is committed.
+
+How it works: With the beginning of a transaction, a snapshot of the object is created. In the event of
+a rollback, the object's data is replaced with data from the snapshot.
+
+By default, the snapshot is shallow (i.e. does not include subroups, entries or historical entries). This
+means that only modifications to the object itself (its data, fields, strings, etc.) are atomic; modifications
+to subroups etc., including adding or removing items, are auto-committed instantly and will persist regardless
+of the result of the pending transaction. You can override this for groups, entries and history independently
+using options:
+
+=over 4
+
+=item *
+
+C<entries> - If set, snapshot entries within a group, deeply (default: false)
+
+=item *
+
+C<groups> - If set, snapshot subroups within a group, deeply (default: false)
+
+=item *
+
+C<history> - If set, snapshot historical entries within an entry (default: false)
+
+=back
+
+For example, if you begin a transaction on a group object using the C<entries> option, like this:
+
+ $group->begin_work(entries => 1);
+
+Then if you modify any of the group's entries OR add new entries OR delete entries, all of that will be undone
+if the transaction is rolled back. With a default-configured transaction, however, changes to entries are kept
+even if the transaction is rolled back.
+
+=head2 commit
+
+ $object->commit;
+
+Commit a transaction, making updates to C<$object> permanent. Returns itself to allow method chaining.
+
+=head2 rollback
+
+ $object->rollback;
+
+Roll back the most recent transaction, throwing away any updates to the L</object> made since the transaction
+began. Returns itself to allow method chaining.
+
+=for Pod::Coverage STORABLE_freeze STORABLE_thaw TO_JSON
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Safe;
+# ABSTRACT: Keep strings encrypted while in memory
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes);
+use Devel::GlobalDestruction;
+use Encode qw(encode decode);
+use File::KDBX::Constants qw(:random_stream);
+use File::KDBX::Error;
+use File::KDBX::Util qw(erase erase_scoped);
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_scalarref);
+use Scalar::Util qw(refaddr);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+
+sub new {
+ my $class = shift;
+ my %args = @_ % 2 == 0 ? @_ : (strings => shift, @_);
+
+ if (!$args{cipher} && $args{key}) {
+ require File::KDBX::Cipher;
+ $args{cipher} = File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => $args{key});
+ }
+
+ my $self = bless \%args, $class;
+ $self->cipher->finish;
+ $self->{counter} = 0;
+
+ my $strings = delete $args{strings};
+ $self->{items} = [];
+ $self->{index} = {};
+ $self->add($strings) if $strings;
+
+ return $self;
+}
+
+sub DESTROY { local ($., $@, $!, $^E, $?); !in_global_destruction and $_[0]->unlock }
+
+
+sub clear {
+ my $self = shift;
+ $self->{items} = [];
+ $self->{index} = {};
+ $self->{counter} = 0;
+ return $self;
+}
+
+
+sub lock { shift->add(@_) }
+
+sub add {
+ my $self = shift;
+ my @strings = map { is_arrayref($_) ? @$_ : $_ } @_;
+
+ @strings or throw 'Must provide strings to lock';
+
+ my $cipher = $self->cipher;
+
+ for my $string (@strings) {
+ my $item = {str => $string, off => $self->{counter}};
+ if (is_scalarref($string)) {
+ next if !defined $$string;
+ $item->{enc} = 'UTF-8' if utf8::is_utf8($$string);
+ if (my $encoding = $item->{enc}) {
+ my $encoded = encode($encoding, $$string);
+ $item->{val} = $cipher->crypt(\$encoded);
+ erase $encoded;
+ }
+ else {
+ $item->{val} = $cipher->crypt($string);
+ }
+ erase $string;
+ }
+ elsif (is_hashref($string)) {
+ next if !defined $string->{value};
+ $item->{enc} = 'UTF-8' if utf8::is_utf8($string->{value});
+ if (my $encoding = $item->{enc}) {
+ my $encoded = encode($encoding, $string->{value});
+ $item->{val} = $cipher->crypt(\$encoded);
+ erase $encoded;
+ }
+ else {
+ $item->{val} = $cipher->crypt(\$string->{value});
+ }
+ erase \$string->{value};
+ }
+ else {
+ throw 'Safe strings must be a hashref or stringref', type => ref $string;
+ }
+ push @{$self->{items}}, $item;
+ $self->{index}{refaddr($string)} = $item;
+ $self->{counter} += length($item->{val});
+ }
+
+ return $self;
+}
+
+
+sub lock_protected { shift->add_protected(@_) }
+
+sub add_protected {
+ my $self = shift;
+ my $filter = is_coderef($_[0]) ? shift : undef;
+ my @strings = map { is_arrayref($_) ? @$_ : $_ } @_;
+
+ @strings or throw 'Must provide strings to lock';
+
+ for my $string (@strings) {
+ my $item = {str => $string};
+ $item->{filter} = $filter if defined $filter;
+ if (is_scalarref($string)) {
+ next if !defined $$string;
+ $item->{val} = $$string;
+ erase $string;
+ }
+ elsif (is_hashref($string)) {
+ next if !defined $string->{value};
+ $item->{val} = $string->{value};
+ erase \$string->{value};
+ }
+ else {
+ throw 'Safe strings must be a hashref or stringref', type => ref $string;
+ }
+ push @{$self->{items}}, $item;
+ $self->{index}{refaddr($string)} = $item;
+ $self->{counter} += length($item->{val});
+ }
+
+ return $self;
+}
+
+
+sub unlock {
+ my $self = shift;
+
+ my $cipher = $self->cipher;
+ $cipher->finish;
+ $self->{counter} = 0;
+
+ for my $item (@{$self->{items}}) {
+ my $string = $item->{str};
+ my $cleanup = erase_scoped \$item->{val};
+ my $str_ref;
+ if (is_scalarref($string)) {
+ $$string = $cipher->crypt(\$item->{val});
+ if (my $encoding = $item->{enc}) {
+ my $decoded = decode($encoding, $string->{value});
+ erase $string;
+ $$string = $decoded;
+ }
+ $str_ref = $string;
+ }
+ elsif (is_hashref($string)) {
+ $string->{value} = $cipher->crypt(\$item->{val});
+ if (my $encoding = $item->{enc}) {
+ my $decoded = decode($encoding, $string->{value});
+ erase \$string->{value};
+ $string->{value} = $decoded;
+ }
+ $str_ref = \$string->{value};
+ }
+ else {
+ die 'Unexpected';
+ }
+ if (my $filter = $item->{filter}) {
+ my $filtered = $filter->($$str_ref);
+ erase $str_ref;
+ $$str_ref = $filtered;
+ }
+ }
+
+ return $self->clear;
+}
+
+
+sub peek {
+ my $self = shift;
+ my $string = shift;
+
+ my $item = $self->{index}{refaddr($string)} // return;
+
+ my $cipher = $self->cipher->dup(offset => $item->{off});
+
+ my $value = $cipher->crypt(\$item->{val});
+ if (my $encoding = $item->{enc}) {
+ my $decoded = decode($encoding, $value);
+ erase $value;
+ return $decoded;
+ }
+ return $value;
+}
+
+
+sub cipher {
+ my $self = shift;
+ $self->{cipher} //= do {
+ require File::KDBX::Cipher;
+ File::KDBX::Cipher->new(stream_id => STREAM_ID_CHACHA20, key => random_bytes(64));
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Safe - Keep strings encrypted while in memory
+
+=head1 VERSION
+
+version 0.800
+
+=head1 SYNOPSIS
+
+ use File::KDBX::Safe;
+
+ $safe = File::KDBX::Safe->new;
+
+ my $msg = 'Secret text';
+ $safe->add(\$msg);
+ # $msg is now undef, the original message no longer in RAM
+
+ my $obj = { value => 'Also secret' };
+ $safe->add($obj);
+ # $obj is now { value => undef }
+
+ say $safe->peek($msg); # Secret text
+
+ $safe->unlock;
+ say $msg; # Secret text
+ say $obj->{value}; # Also secret
+
+=head1 DESCRIPTION
+
+This module provides memory protection functionality. It keeps strings encrypted in memory and decrypts them
+as-needed. Encryption and decryption is done using a L<File::KDBX::Cipher::Stream>.
+
+A safe can protect one or more (possibly many) strings. When a string is added to a safe, it gets added to an
+internal list so it will be decrypted when the entire safe is unlocked.
+
+=head1 ATTRIBUTES
+
+=head2 cipher
+
+ $cipher = $safe->cipher;
+
+Get the L<File::KDBX::Cipher::Stream> protecting a safe.
+
+=head1 METHODS
+
+=head2 new
+
+ $safe = File::KDBX::Safe->new(%attributes);
+ $safe = File::KDBX::Safe->new(\@strings, %attributes);
+
+Create a new safe for storing secret strings encrypted in memory.
+
+If a cipher is passed, its stream will be reset.
+
+=head2 clear
+
+ $safe = $safe->clear;
+
+Clear a safe, removing all store contents permanently. Returns itself to allow method chaining.
+
+=head2 lock
+
+=head2 add
+
+ $safe = $safe->lock(@strings);
+ $safe = $safe->lock(\@strings);
+
+Add one or more strings to the memory protection stream. Returns itself to allow method chaining.
+
+=head2 lock_protected
+
+=head2 add_protected
+
+ $safe = $safe->lock_protected(@strings);
+ $safe = $safe->lock_protected(\@strings);
+
+Add strings that are already encrypted. Returns itself to allow method chaining.
+
+B<WARNING:> The cipher must be the same as was used to originally encrypt the strings. You must add
+already-encrypted strings in the order in which they were original encrypted or they will not decrypt
+correctly. You almost certainly do not want to add both unprotected and protected strings to a safe.
+
+=head2 unlock
+
+ $safe = $safe->unlock;
+
+Decrypt all the strings. Each stored string is set to its original value, potentially overwriting any value
+that might have been set after locking the string (so you probably should avoid modification to strings while
+locked). The safe is implicitly cleared. Returns itself to allow method chaining.
+
+This happens automatically when the safe is garbage-collected.
+
+=head2 peek
+
+ $string_value = $safe->peek($string);
+ ...
+ erase $string_value;
+
+Peek into the safe at a particular string without decrypting the whole safe. A copy of the string is returned,
+and in order to ensure integrity of the memory protection you should erase the copy when you're done.
+
+Returns C<undef> if the given C<$string> is not in memory protection.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Transaction;
+# ABSTRACT: Make multiple database edits atomically
+
+use warnings;
+use strict;
+
+use Devel::GlobalDestruction;
+use File::KDBX::Util qw(:class);
+use namespace::clean;
+
+our $VERSION = '0.800'; # VERSION
+
+
+sub new {
+ my $class = shift;
+ my $object = shift;
+ $object->begin_work(@_);
+ return bless {object => $object}, $class;
+}
+
+sub DESTROY { !in_global_destruction and $_[0]->rollback }
+
+
+has 'object', is => 'ro';
+
+
+sub commit {
+ my $self = shift;
+ return if $self->{done};
+
+ my $obj = $self->object;
+ $obj->commit;
+ $self->{done} = 1;
+ return $obj;
+}
+
+
+sub rollback {
+ my $self = shift;
+ return if $self->{done};
+
+ my $obj = $self->object;
+ $obj->rollback;
+ $self->{done} = 1;
+ return $obj;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Transaction - Make multiple database edits atomically
+
+=head1 VERSION
+
+version 0.800
+
+=head1 ATTRIBUTES
+
+=head2 object
+
+Get the object being transacted on.
+
+=head1 METHODS
+
+=head2 new
+
+ $txn = File::KDBX::Transaction->new($object);
+
+Construct a new database transaction for editing an object atomically.
+
+=head2 commit
+
+ $txn->commit;
+
+Commit the transaction, making updates to the L</object> permanent.
+
+=head2 rollback
+
+ $txn->rollback;
+
+Roll back the transaction, throwing away any updates to the L</object> made since the transaction began. This
+happens automatically when the transaction is released, unless it has already been committed.
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+package File::KDBX::Util;
+# ABSTRACT: Utility functions for working with KDBX files
+
+use warnings;
+use strict;
+
+use Crypt::PRNG qw(random_bytes random_string);
+use Encode qw(decode encode);
+use Exporter qw(import);
+use File::KDBX::Constants qw(:bool);
+use File::KDBX::Error;
+use List::Util 1.33 qw(any all);
+use Module::Load;
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref);
+use Scalar::Util qw(blessed looks_like_number readonly);
+use Time::Piece;
+use boolean;
+use namespace::clean -except => 'import';
+
+our $VERSION = '0.800'; # VERSION
+
+our %EXPORT_TAGS = (
+ assert => [qw(DEBUG assert assert_64bit)],
+ class => [qw(extends has list_attributes)],
+ clone => [qw(clone clone_nomagic)],
+ coercion => [qw(to_bool to_number to_string to_time to_tristate to_uuid)],
+ crypt => [qw(pad_pkcs7)],
+ debug => [qw(DEBUG dumper)],
+ fork => [qw(can_fork)],
+ function => [qw(memoize recurse_limit)],
+ empty => [qw(empty nonempty)],
+ erase => [qw(erase erase_scoped)],
+ gzip => [qw(gzip gunzip)],
+ io => [qw(is_readable is_writable read_all)],
+ load => [qw(load_optional load_xs try_load_optional)],
+ search => [qw(query query_any search simple_expression_query)],
+ text => [qw(snakify trim)],
+ uuid => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)],
+ uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)],
+);
+
+$EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS];
+our @EXPORT_OK = @{$EXPORT_TAGS{all}};
+
+BEGIN {
+ my $debug = $ENV{DEBUG};
+ $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0);
+ *DEBUG = $debug == 1 ? sub() { 1 } :
+ $debug == 2 ? sub() { 2 } :
+ $debug == 3 ? sub() { 3 } :
+ $debug == 4 ? sub() { 4 } : sub() { 0 };
+}
+
+my %OPS = (
+ 'eq' => 2, # binary
+ 'ne' => 2,
+ 'lt' => 2,
+ 'gt' => 2,
+ 'le' => 2,
+ 'ge' => 2,
+ '==' => 2,
+ '!=' => 2,
+ '<' => 2,
+ '>' => 2,
+ '<=' => 2,
+ '>=' => 2,
+ '=~' => 2,
+ '!~' => 2,
+ '!' => 1, # unary
+ '!!' => 1,
+ '-not' => 1, # special
+ '-false' => 1,
+ '-true' => 1,
+ '-defined' => 1,
+ '-undef' => 1,
+ '-empty' => 1,
+ '-nonempty' => 1,
+ '-or' => -1,
+ '-and' => -1,
+);
+my %OP_NEG = (
+ 'eq' => 'ne',
+ 'ne' => 'eq',
+ 'lt' => 'ge',
+ 'gt' => 'le',
+ 'le' => 'gt',
+ 'ge' => 'lt',
+ '==' => '!=',
+ '!=' => '==',
+ '<' => '>=',
+ '>' => '<=',
+ '<=' => '>',
+ '>=' => '<',
+ '=~' => '!~',
+ '!~' => '=~',
+);
+my %ATTRIBUTES;
+
+
+my $XS_LOADED;
+sub load_xs {
+ my $version = shift;
+
+ goto IS_LOADED if defined $XS_LOADED;
+
+ if ($ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS})) {
+ return $XS_LOADED = FALSE;
+ }
+
+ $XS_LOADED = !!eval { require File::KDBX::XS; 1 };
+
+ IS_LOADED:
+ {
+ local $@;
+ return $XS_LOADED if !$version;
+ return !!eval { File::KDBX::XS->VERSION($version); 1 };
+ }
+}
+
+
+sub assert(&) { ## no critic (ProhibitSubroutinePrototypes)
+ return if !DEBUG;
+ my $code = shift;
+ return if $code->();
+
+ (undef, my $file, my $line) = caller;
+ $file =~ s!([^/\\]+)$!$1!;
+ my $assertion = '';
+ if (try_load_optional('B::Deparse')) {
+ my $deparse = B::Deparse->new(qw{-P -x9});
+ $assertion = $deparse->coderef2text($code);
+ $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s;
+ $assertion =~ s/\s+/ /gs;
+ $assertion = ": $assertion";
+ }
+ die "$0: $file:$line: Assertion failed$assertion\n";
+}
+
+
+sub assert_64bit() {
+ require Config;
+ $Config::Config{ivsize} < 8
+ and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize};
+}
+
+
+sub can_fork {
+ require Config;
+ return 1 if $Config::Config{d_fork};
+ return 0 if $^O ne 'MSWin32' && $^O ne 'NetWare';
+ return 0 if !$Config::Config{useithreads};
+ return 0 if $Config::Config{ccflags} !~ /-DPERL_IMPLICIT_SYS/;
+ return 0 if $] < 5.008001;
+ if ($] == 5.010000 && $Config::Config{ccname} eq 'gcc' && $Config::Config{gccversion}) {
+ return 0 if $Config::Config{gccversion} !~ m/^(\d+)\.(\d+)/;
+ my @parts = split(/[\.\s]+/, $Config::Config{gccversion});
+ return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
+ }
+ return 0 if $INC{'Devel/Cover.pm'};
+ return 1;
+}
+
+
+sub clone {
+ require Storable;
+ goto &Storable::dclone;
+}
+
+
+sub clone_nomagic {
+ my $thing = shift;
+ if (is_arrayref($thing)) {
+ my @arr = map { clone_nomagic($_) } @$thing;
+ return \@arr;
+ }
+ elsif (is_hashref($thing)) {
+ my %hash;
+ $hash{$_} = clone_nomagic($thing->{$_}) for keys %$thing;
+ return \%hash;
+ }
+ elsif (is_ref($thing)) {
+ return clone($thing);
+ }
+ return $thing;
+}
+
+
+sub dumper {
+ require Data::Dumper;
+ # avoid "once" warnings
+ local $Data::Dumper::Deepcopy = $Data::Dumper::Deepcopy = 1;
+ local $Data::Dumper::Deparse = $Data::Dumper::Deparse = 1;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Trailingcomma = 1;
+ local $Data::Dumper::Useqq = 1;
+
+ my @dumps;
+ for my $struct (@_) {
+ my $str = Data::Dumper::Dumper($struct);
+
+ # boolean
+ $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
+ # Time::Piece
+ $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/
+ "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges;
+
+ print STDERR $str if !defined wantarray;
+ push @dumps, $str;
+ return $str;
+ }
+ return join("\n", @dumps);
+}
+
+
+sub empty { _empty(@_) }
+sub nonempty { !_empty(@_) }
+
+sub _empty {
+ return 1 if @_ == 0;
+ local $_ = shift;
+ return !defined $_
+ || $_ eq ''
+ || (is_arrayref($_) && @$_ == 0)
+ || (is_hashref($_) && keys %$_ == 0)
+ || (is_scalarref($_) && (!defined $$_ || $$_ eq ''))
+ || (is_refref($_) && _empty($$_));
+}
+
+
+BEGIN {
+ if (load_xs) {
+ *_CowREFCNT = \&File::KDBX::XS::CowREFCNT;
+ }
+ elsif (eval { require B::COW; 1 }) {
+ *_CowREFCNT = \&B::COW::cowrefcnt;
+ }
+ else {
+ *_CowREFCNT = sub { undef };
+ }
+}
+
+sub erase {
+ # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
+ # creating a copy and erasing the copy.
+ # TODO - Is this worth doing? Need some benchmarking.
+ for (@_) {
+ if (!is_ref($_)) {
+ next if !defined $_ || readonly $_;
+ my $cowrefcnt = _CowREFCNT($_);
+ goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt;
+ # if (__PACKAGE__->can('erase_xs')) {
+ # erase_xs($_);
+ # }
+ # else {
+ substr($_, 0, length($_), "\0" x length($_));
+ # }
+ FREE_NONREF: {
+ no warnings 'uninitialized';
+ undef $_;
+ }
+ }
+ elsif (is_scalarref($_)) {
+ next if !defined $$_ || readonly $$_;
+ my $cowrefcnt = _CowREFCNT($$_);
+ goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt;
+ # if (__PACKAGE__->can('erase_xs')) {
+ # erase_xs($$_);
+ # }
+ # else {
+ substr($$_, 0, length($$_), "\0" x length($$_));
+ # }
+ FREE_REF: {
+ no warnings 'uninitialized';
+ undef $$_;
+ }
+ }
+ elsif (is_arrayref($_)) {
+ erase(@$_);
+ @$_ = ();
+ }
+ elsif (is_hashref($_)) {
+ erase(values %$_);
+ %$_ = ();
+ }
+ else {
+ throw 'Cannot erase this type of scalar', type => ref $_, what => $_;
+ }
+ }
+}
+
+
+sub erase_scoped {
+ throw 'Programmer error: Cannot call erase_scoped in void context' if !defined wantarray;
+ my @args;
+ for (@_) {
+ !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
+ or throw 'Cannot erase this type of scalar', type => ref $_, what => $_;
+ push @args, is_ref($_) ? $_ : \$_;
+ }
+ require Scope::Guard;
+ return Scope::Guard->new(sub { erase(@args) });
+}
+
+
+sub extends {
+ my $parent = shift;
+ my $caller = caller;
+ load $parent;
+ no strict 'refs'; ## no critic (ProhibitNoStrict)
+ @{"${caller}::ISA"} = $parent;
+}
+
+
+sub has {
+ my $name = shift;
+ my %args = @_ % 2 == 1 ? (default => shift, @_) : @_;
+
+ my ($package, $file, $line) = caller;
+
+ my $d = $args{default};
+ my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d;
+ my $coerce = $args{coerce};
+ my $is = $args{is} || 'rw';
+
+ my $store = $args{store};
+ ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
+
+ my @path = split(/\./, $args{path} || '');
+ my $last = pop @path;
+ my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}}
+ : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}};
+ my $member = qq{\$_[0]$path};
+
+
+ my $default_code = is_coderef $default ? q{scalar $default->($_[0])}
+ : defined $default ? q{$default}
+ : q{undef};
+ my $get = qq{$member //= $default_code;};
+
+ my $set = '';
+ if ($is eq 'rw') {
+ $set = is_coderef $coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;}
+ : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \$#_;}
+ : qq{$member = \$_[1] if \$#_;};
+ }
+
+ push @{$ATTRIBUTES{$package} //= []}, $name;
+ $line -= 4;
+ my $code = <<END;
+# line $line "$file"
+sub ${package}::${name} {
+ return $default_code if !Scalar::Util::blessed(\$_[0]);
+ $set
+ $get
+}
+END
+ eval $code; ## no critic (ProhibitStringyEval)
+}
+
+
+sub format_uuid {
+ local $_ = shift // "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ my $delim = shift // '';
+ length($_) == 16 or throw 'Must provide a 16-bytes UUID', size => length($_), str => $_;
+ return uc(join($delim, unpack('H8 H4 H4 H4 H12', $_)));
+}
+
+
+sub generate_uuid {
+ my $set = @_ % 2 == 1 ? shift : undef;
+ my %args = @_;
+ my $test = $set //= $args{test};
+ $test = sub { !$set->{$_} } if is_hashref($test);
+ $test //= sub { 1 };
+ my $printable = $args{printable} // $args{print};
+ local $_ = '';
+ do {
+ $_ = $printable ? random_string(16) : random_bytes(16);
+ } while (!$test->($_));
+ return $_;
+}
+
+
+sub gunzip {
+ load_optional('Compress::Raw::Zlib');
+ local $_ = shift;
+ my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to initialize compression library', status => $status;
+ $status = $i->inflate($_, my $out);
+ $status == Compress::Raw::Zlib::Z_STREAM_END()
+ or throw 'Failed to decompress data', status => $status;
+ return $out;
+}
+
+
+sub gzip {
+ load_optional('Compress::Raw::Zlib');
+ local $_ = shift;
+ my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to initialize compression library', status => $status;
+ $status = $d->deflate($_, my $out);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to compress data', status => $status;
+ $status = $d->flush($out);
+ $status == Compress::Raw::Zlib::Z_OK()
+ or throw 'Failed to compress data', status => $status;
+ return $out;
+}
+
+
+sub is_readable { $_[0] !~ /^[aw]b?$/ }
+sub is_writable { $_[0] !~ /^rb?$/ }
+
+
+sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
+
+
+sub list_attributes {
+ my $package = shift;
+ return @{$ATTRIBUTES{$package} // []};
+}
+
+
+sub load_optional {
+ for my $module (@_) {
+ eval { load $module };
+ if (my $err = $@) {
+ throw "Missing dependency: Please install $module to use this feature.\n",
+ module => $module,
+ error => $err;
+ }
+ }
+ return wantarray ? @_ : $_[0];
+}
+
+
+sub memoize {
+ my $func = shift;
+ my @args = @_;
+ my %cache;
+ return sub { $cache{join("\0", grep { defined } @_)} //= $func->(@args, @_) };
+}
+
+
+sub pad_pkcs7 {
+ my $data = shift // throw 'Must provide a string to pad';
+ my $size = shift or throw 'Must provide block size';
+
+ 0 <= $size && $size < 256
+ or throw 'Cannot add PKCS7 padding to a large block size', size => $size;
+
+ my $pad_len = $size - length($data) % $size;
+ $data .= chr($pad_len) x $pad_len;
+}
+
+
+sub query { _query(undef, '-or', \@_) }
+
+
+sub query_any {
+ my $code = shift;
+
+ if (is_coderef($code) || overload::Method($code, '&{}')) {
+ return $code;
+ }
+ elsif (is_scalarref($code)) {
+ return simple_expression_query($$code, @_);
+ }
+ else {
+ return query($code, @_);
+ }
+}
+
+
+sub read_all($$$;$) { ## no critic (ProhibitSubroutinePrototypes)
+ my $result = @_ == 3 ? read($_[0], $_[1], $_[2])
+ : read($_[0], $_[1], $_[2], $_[3]);
+ return if !defined $result;
+ return if $result != $_[2];
+ return $result;
+}
+
+
+sub recurse_limit {
+ my $func = shift;
+ my $max_depth = shift // 200;
+ my $error = shift // sub {};
+ my $depth = 0;
+ return sub { return $error->(@_) if $max_depth < ++$depth; $func->(@_) };
+};
+
+
+sub search {
+ my $list = shift;
+ my $query = query_any(@_);
+
+ my @match;
+ for my $item (@$list) {
+ push @match, $item if $query->($item);
+ }
+ return \@match;
+}
+
+
+sub simple_expression_query {
+ my $expr = shift;
+ my $op = @_ && ($OPS{$_[0] || ''} || 0) == 2 ? shift : '=~';
+
+ my $neg_op = $OP_NEG{$op};
+ my $is_re = $op eq '=~' || $op eq '!~';
+
+ require Text::ParseWords;
+ my @terms = Text::ParseWords::shellwords($expr);
+
+ my @query = qw(-and);
+
+ for my $term (@terms) {
+ my @subquery = qw(-or);
+
+ my $neg = $term =~ s/^-//;
+ my $condition = [($neg ? $neg_op : $op) => ($is_re ? qr/\Q$term\E/i : $term)];
+
+ for my $field (@_) {
+ push @subquery, $field => $condition;
+ }
+
+ push @query, \@subquery;
+ }
+
+ return query(\@query);
+}
+
+
+sub snakify {
+ local $_ = shift;
+ s/UserName/Username/g;
+ s/([a-z])([A-Z0-9])/${1}_${2}/g;
+ s/([A-Z0-9]+)([A-Z0-9])(?![A-Z0-9]|$)/${1}_${2}/g;
+ return lc($_);
+}
+
+
+sub split_url {
+ local $_ = shift;
+ my ($scheme, $auth, $host, $port, $path, $query, $hash) =~ m!
+ ^([^:/\?\#]+) ://
+ (?:([^\@]+)\@)
+ ([^:/\?\#]*)
+ (?::(\d+))?
+ ([^\?\#]*)
+ (\?[^\#]*)?
+ (\#(.*))?
+ !x;
+
+ $scheme = lc($scheme);
+
+ $host ||= 'localhost';
+ $host = lc($host);
+
+ $path = "/$path" if $path !~ m!^/!;
+
+ $port ||= $scheme eq 'http' ? 80 : $scheme eq 'https' ? 433 : undef;
+
+ my ($username, $password) = split($auth, ':', 2);
+
+ return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
+}
+
+
+sub to_bool { $_[0] // return; boolean($_[0]) }
+sub to_number { $_[0] // return; 0+$_[0] }
+sub to_string { $_[0] // return; "$_[0]" }
+sub to_time {
+ $_[0] // return;
+ return scalar gmtime($_[0]) if looks_like_number($_[0]);
+ return scalar gmtime if $_[0] eq 'now';
+ return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0];
+ return $_[0];
+}
+sub to_tristate { $_[0] // return; boolean($_[0]) }
+sub to_uuid {
+ my $str = to_string(@_) // return;
+ return sprintf('%016s', $str) if length($str) < 16;
+ return substr($str, 0, 16) if 16 < length($str);
+ return $str;
+}
+
+
+sub trim($) { ## no critic (ProhibitSubroutinePrototypes)
+ local $_ = shift // return;
+ s/^\s*//;
+ s/\s*$//;
+ return $_;
+}
+
+
+sub try_load_optional {
+ for my $module (@_) {
+ eval { load $module };
+ if (my $err = $@) {
+ warn $err if 3 <= DEBUG;
+ return;
+ }
+ }
+ return @_;
+}
+
+
+my %ESC = map { chr($_) => sprintf('%%%02X', $_) } 0..255;
+sub uri_escape_utf8 {
+ local $_ = shift // return;
+ $_ = encode('UTF-8', $_);
+ # RFC 3986 section 2.3 unreserved characters
+ s/([^A-Za-z0-9\-\._~])/$ESC{$1}/ge;
+ return $_;
+}
+
+
+sub uri_unescape_utf8 {
+ local $_ = shift // return;
+ s/\%([A-Fa-f0-9]{2})/chr(hex($1))/;
+ return decode('UTF-8', $_);
+}
+
+
+sub uuid {
+ local $_ = shift // return "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ s/-//g;
+ /^[A-Fa-f0-9]{32}$/ or throw 'Must provide a formatted 128-bit UUID';
+ return pack('H32', $_);
+
+}
+
+
+sub UUID_NULL() { "\0" x 16 }
+
+### --------------------------------------------------------------------------
+
+# Determine if an array looks like keypairs from a hash.
+sub _looks_like_keypairs {
+ my $arr = shift;
+ return 0 if @$arr % 2 == 1;
+ for (my $i = 0; $i < @$arr; $i += 2) {
+ return 0 if is_ref($arr->[$i]);
+ }
+ return 1;
+}
+
+sub _is_operand_plain {
+ local $_ = shift;
+ return !(is_hashref($_) || is_arrayref($_));
+}
+
+sub _query {
+ # dumper \@_;
+ my $subject = shift;
+ my $op = shift // throw 'Must specify a query operator';
+ my $operand = shift;
+
+ return _query_simple($op, $subject) if defined $subject && !is_ref($op) && ($OPS{$subject} || 2) < 2;
+ return _query_simple($subject, $op, $operand) if _is_operand_plain($operand);
+ return _query_inverse(_query($subject, '-or', $operand)) if $op eq '-not' || $op eq '-false';
+ return _query($subject, '-and', [%$operand]) if is_hashref($operand);
+
+ my @queries;
+
+ my @atoms = @$operand;
+ while (@atoms) {
+ if (_looks_like_keypairs(\@atoms)) {
+ my ($atom, $operand) = splice @atoms, 0, 2;
+ if (my $op_type = $OPS{$atom}) {
+ if ($op_type == 1 && _is_operand_plain($operand)) { # unary
+ push @queries, _query_simple($operand, $atom);
+ }
+ else {
+ push @queries, _query($subject, $atom, $operand);
+ }
+ }
+ elsif (!is_ref($atom)) {
+ push @queries, _query($atom, 'eq', $operand);
+ }
+ }
+ else {
+ my $atom = shift @atoms;
+ if ($OPS{$atom}) { # apply new operator over the rest
+ push @queries, _query($subject, $atom, \@atoms);
+ last;
+ }
+ else { # apply original operator over this one
+ push @queries, _query($subject, $op, $atom);
+ }
+ }
+ }
+
+ if (@queries == 1) {
+ return $queries[0];
+ }
+ elsif ($op eq '-and') {
+ return _query_all(@queries);
+ }
+ elsif ($op eq '-or') {
+ return _query_any(@queries);
+ }
+ throw 'Malformed query';
+}
+
+sub _query_simple {
+ my $subject = shift;
+ my $op = shift // 'eq';
+ my $operand = shift;
+
+ # these special operators can also act as simple operators
+ $op = '!!' if $op eq '-true';
+ $op = '!' if $op eq '-false';
+ $op = '!' if $op eq '-not';
+
+ defined $subject or throw 'Subject is not set in query';
+ $OPS{$op} >= 0 or throw 'Cannot use a non-simple operator in a simple query';
+ if (empty($operand)) {
+ if ($OPS{$op} < 2) {
+ # no operand needed
+ }
+ # Allow field => undef and field => {'ne' => undef} to do the (arguably) right thing.
+ elsif ($op eq 'eq' || $op eq '==') {
+ $op = '-empty';
+ }
+ elsif ($op eq 'ne' || $op eq '!=') {
+ $op = '-nonempty';
+ }
+ else {
+ throw 'Operand is required';
+ }
+ }
+
+ my $field = sub { blessed $_[0] && $_[0]->can($subject) ? $_[0]->$subject : $_[0]->{$subject} };
+
+ my %map = (
+ 'eq' => sub { local $_ = $field->(@_); defined && $_ eq $operand },
+ 'ne' => sub { local $_ = $field->(@_); defined && $_ ne $operand },
+ 'lt' => sub { local $_ = $field->(@_); defined && $_ lt $operand },
+ 'gt' => sub { local $_ = $field->(@_); defined && $_ gt $operand },
+ 'le' => sub { local $_ = $field->(@_); defined && $_ le $operand },
+ 'ge' => sub { local $_ = $field->(@_); defined && $_ ge $operand },
+ '==' => sub { local $_ = $field->(@_); defined && $_ == $operand },
+ '!=' => sub { local $_ = $field->(@_); defined && $_ != $operand },
+ '<' => sub { local $_ = $field->(@_); defined && $_ < $operand },
+ '>' => sub { local $_ = $field->(@_); defined && $_ > $operand },
+ '<=' => sub { local $_ = $field->(@_); defined && $_ <= $operand },
+ '>=' => sub { local $_ = $field->(@_); defined && $_ >= $operand },
+ '=~' => sub { local $_ = $field->(@_); defined && $_ =~ $operand },
+ '!~' => sub { local $_ = $field->(@_); defined && $_ !~ $operand },
+ '!' => sub { local $_ = $field->(@_); ! $_ },
+ '!!' => sub { local $_ = $field->(@_); !!$_ },
+ '-defined' => sub { local $_ = $field->(@_); defined $_ },
+ '-undef' => sub { local $_ = $field->(@_); !defined $_ },
+ '-nonempty' => sub { local $_ = $field->(@_); nonempty $_ },
+ '-empty' => sub { local $_ = $field->(@_); empty $_ },
+ );
+
+ return $map{$op} // throw "Unexpected operator in query: $op",
+ subject => $subject,
+ operator => $op,
+ operand => $operand;
+}
+
+sub _query_inverse {
+ my $query = shift;
+ return sub { !$query->(@_) };
+}
+
+sub _query_all {
+ my @queries = @_;
+ return sub {
+ my $val = shift;
+ all { $_->($val) } @queries;
+ };
+}
+
+sub _query_any {
+ my @queries = @_;
+ return sub {
+ my $val = shift;
+ any { $_->($val) } @queries;
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::KDBX::Util - Utility functions for working with KDBX files
+
+=head1 VERSION
+
+version 0.800
+
+=head1 FUNCTIONS
+
+=head2 load_xs
+
+ $bool = load_xs();
+ $bool = load_xs($version);
+
+Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> is loaded. If C<$version> is given, it will check
+that at least the given version is loaded.
+
+=head2 assert
+
+ assert { ... };
+
+Write an executable comment. Only executed if C<DEBUG> is set in the environment.
+
+=head2 assert_64bit
+
+ assert_64bit();
+
+Throw if perl doesn't support 64-bit IVs.
+
+=head2 can_fork
+
+ $bool = can_fork;
+
+Determine if perl can fork, with logic lifted from L<Test2::Util/CAN_FORK>.
+
+=head2 clone
+
+ $clone = clone($thing);
+
+Clone deeply. This is an unadorned alias to L<Storable> C<dclone>.
+
+=head2 clone_nomagic
+
+ $clone = clone_nomagic($thing);
+
+Clone deeply without keeping [most of] the magic.
+
+B<WARNING:> At the moment the implementation is naïve and won't respond well to nontrivial data or recursive
+structures.
+
+=head2 DEBUG
+
+Constant number indicating the level of debuggingness.
+
+=head2 dumper
+
+ $str = dumper $thing;
+ dumper $thing; # in void context, prints to STDERR
+
+Like L<Data::Dumper> but slightly terser in some cases relevent to L<File::KDBX>.
+
+=head2 empty
+
+=head2 nonempty
+
+ $bool = empty $thing;
+
+ $bool = nonempty $thing;
+
+Test whether a thing is empty (or nonempty). An empty thing is one of these:
+
+=over 4
+
+=item *
+
+nonexistent
+
+=item *
+
+C<undef>
+
+=item *
+
+zero-length string
+
+=item *
+
+zero-length array
+
+=item *
+
+hash with zero keys
+
+=item *
+
+reference to an empty thing (recursive)
+
+=back
+
+Note in particular that zero C<0> is not considered empty because it is an actual value.
+
+=head2 erase
+
+ erase($string, ...);
+ erase(\$string, ...);
+
+Overwrite the memory used by one or more string.
+
+=head2 erase_scoped
+
+ $scope_guard = erase_scoped($string, ...);
+ $scope_guard = erase_scoped(\$string, ...);
+ undef $scope_guard; # erase happens here
+
+Get a scope guard that will cause scalars to be erased later (i.e. when the scope ends). This is useful if you
+want to make sure a string gets erased after you're done with it, even if the scope ends abnormally.
+
+See L</erase>.
+
+=head2 extends
+
+ extends $class;
+
+Set up the current module to inheret from another module.
+
+=head2 has
+
+ has $name => %options;
+
+Create an attribute getter/setter. Possible options:
+
+=over 4
+
+=item *
+
+C<is> - Either "rw" (default) or "ro"
+
+=item *
+
+C<default> - Default value
+
+=item *
+
+C<coerce> - Coercive function
+
+=back
+
+=head2 format_uuid
+
+ $string_uuid = format_uuid($raw_uuid);
+ $string_uuid = format_uuid($raw_uuid, $delimiter);
+
+Format a 128-bit UUID (given as a string of 16 octets) into a hexidecimal string, optionally with a delimiter
+to break up the UUID visually into five parts. Examples:
+
+ my $uuid = uuid('01234567-89AB-CDEF-0123-456789ABCDEF');
+ say format_uuid($uuid); # -> 0123456789ABCDEF0123456789ABCDEF
+ say format_uuid($uuid, '-'); # -> 01234567-89AB-CDEF-0123-456789ABCDEF
+
+This is the inverse of L</uuid>.
+
+=head2 generate_uuid
+
+ $uuid = generate_uuid;
+ $uuid = generate_uuid(\%set);
+ $uuid = generate_uuid(\&test_uuid);
+
+Generate a new random UUID. It's pretty unlikely that this will generate a repeat, but if you're worried about
+that you can provide either a set of existing UUIDs (as a hashref where the keys are the elements of a set) or
+a function to check for existing UUIDs, and this will be sure to not return a UUID already in provided set.
+Perhaps an example will make it clear:
+
+ my %uuid_set = (
+ uuid('12345678-9ABC-DEFG-1234-56789ABCDEFG') => 'whatever',
+ );
+ $uuid = generate_uuid(\%uuid_set);
+ # OR
+ $uuid = generate_uuid(sub { !$uuid_set{$_} });
+
+Here, C<$uuid> can't be "12345678-9ABC-DEFG-1234-56789ABCDEFG". This example uses L</uuid> to easily pack
+a 16-byte UUID from a literal, but it otherwise is not a consequential part of the example.
+
+=head2 gunzip
+
+ $unzipped = gunzip($string);
+
+Decompress an octet stream.
+
+=head2 gzip
+
+ $zipped = gzip($string);
+
+Compress an octet stream.
+
+=head2 is_readable
+
+=head2 is_writable
+
+ $bool = is_readable($mode);
+ $bool = is_writable($mode);
+
+Determine of an C<fopen>-style mode is readable, writable or both.
+
+=head2 is_uuid
+
+ $bool = is_uuid($thing);
+
+Check if a thing is a UUID (i.e. scalar string of length 16).
+
+=head2 list_attributes
+
+ @attributes = list_attributes($package);
+
+Get a list of attributes for a class.
+
+=head2 load_optional
+
+ $package = load_optional($package);
+
+Load a module that isn't required but can provide extra functionality. Throw if the module is not available.
+
+=head2 memoize
+
+ \&memoized_code = memoize(\&code, ...);
+
+Memoize a function. Extra arguments are passed through to C<&code> when it is called.
+
+=head2 pad_pkcs7
+
+ $padded_string = pad_pkcs7($string, $block_size),
+
+Pad a block using the PKCS#7 method.
+
+=head2 query
+
+ $query = query(@where);
+ $query->(\%data);
+
+Generate a function that will run a series of tests on a passed hashref and return true or false depending on
+if the data record in the hash matched the specified logic.
+
+The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES"> which was the inspiration
+for this function, but this code is distinct, supporting an overlapping but not identical feature set and
+having its own bugs.
+
+See L<File::KDBX/QUERY> for examples.
+
+=head2 query_any
+
+Get either a L</query> or L</simple_expression_query>, depending on the arguments.
+
+=head2 read_all
+
+ $size = read_all($fh, my $buffer, $size);
+ $size = read_all($fh, my $buffer, $size, $offset);
+
+Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
+distinguishable from other errors by C<$!> not being set.
+
+=head2 recurse_limit
+
+ \&limited_code = recurse_limit(\&code);
+ \&limited_code = recurse_limit(\&code, $max_depth);
+ \&limited_code = recurse_limit(\&code, $max_depth, \&error_handler);
+
+Wrap a function with a guard to prevent deep recursion.
+
+=head2 search
+
+ # Generate a query on-the-fly:
+ \@matches = search(\@records, @where);
+
+ # Use a pre-compiled query:
+ $query = query(@where);
+ \@matches = search(\@records, $query);
+
+ # Use a simple expression:
+ \@matches = search(\@records, \'query terms', @fields);
+ \@matches = search(\@records, \'query terms', $operator, @fields);
+
+ # Use your own subroutine:
+ \@matches = search(\@records, \&query);
+ \@matches = search(\@records, sub { $record = shift; ... });
+
+Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
+
+=head2 simple_expression_query
+
+ $query = simple_expression_query($expression, @fields);
+ $query = simple_expression_query($expression, $operator, @fields);
+
+Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
+L<described here|https://keepass.info/help/base/search.html#mode_se>.
+
+An expression is a string with one or more space-separated terms. Terms with spaces can be enclosed in double
+quotes. Terms are negated if they are prefixed with a minus sign. A record must match every term on at least
+one of the given fields.
+
+=head2 snakify
+
+ $string = snakify($string);
+
+Turn a CamelCase string into snake_case.
+
+=head2 split_url
+
+ ($scheme, $auth, $host, $port, $path, $query, $hash, $usename, $password) = split_url($url);
+
+Split a URL into its parts.
+
+For example, C<http://user:pass@localhost:4000/path?query#hash> gets split like:
+
+=over 4
+
+=item *
+
+C<http>
+
+=item *
+
+C<user:pass>
+
+=item *
+
+C<host>
+
+=item *
+
+C<4000>
+
+=item *
+
+C</path>
+
+=item *
+
+C<?query>
+
+=item *
+
+C<#hash>
+
+=item *
+
+C<user>
+
+=item *
+
+C<pass>
+
+=back
+
+=head2 to_bool
+
+=head2 to_number
+
+=head2 to_string
+
+=head2 to_time
+
+=head2 to_tristate
+
+=head2 to_uuid
+
+Various typecasting / coercive functions.
+
+=head2 trim
+
+ $string = trim($string);
+
+The ubiquitous C<trim> function. Removes all whitespace from both ends of a string.
+
+=head2 try_load_optional
+
+ $package = try_load_optional($package);
+
+Try to load a module that isn't required but can provide extra functionality, and return true if successful.
+
+=head2 uri_escape_utf8
+
+ $string = uri_escape_utf8($string);
+
+Percent-encode arbitrary text strings, like for a URI.
+
+=head2 uri_unescape_utf8
+
+ $string = uri_unescape_utf8($string);
+
+Inverse of L</uri_escape_utf8>.
+
+=head2 uuid
+
+ $raw_uuid = uuid($string_uuid);
+
+Pack a 128-bit UUID (given as a hexidecimal string with optional C<->'s, like
+C<12345678-9ABC-DEFG-1234-56789ABCDEFG>) into a string of exactly 16 octets.
+
+This is the inverse of L</format_uuid>.
+
+=head2 UUID_NULL
+
+Get the null UUID (i.e. string of 16 null bytes).
+
+=head1 BUGS
+
+Please report any bugs or feature requests on the bugtracker website
+L<https://github.com/chazmcgarvey/File-KDBX/issues>
+
+When submitting a bug or request, please include a test-file or a
+patch to an existing test-file that illustrates the bug or desired
+feature.
+
+=head1 AUTHOR
+
+Charles McGarvey <ccm@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2022 by Charles McGarvey.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
--- /dev/null
+# We don't really do much using the return value for error-checking. I think
+# in this codebase bugs would more likely be in the form if unintentionally
+# returning empty list in list context.
+[-Subroutines::ProhibitExplicitReturnUndef]
--- /dev/null
+use 5.006;
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058
+
+use Test::More;
+
+plan tests => 38 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
+
+my @module_files = (
+ 'File/KDBX.pm',
+ 'File/KDBX/Cipher.pm',
+ 'File/KDBX/Cipher/CBC.pm',
+ 'File/KDBX/Cipher/Stream.pm',
+ 'File/KDBX/Constants.pm',
+ 'File/KDBX/Dumper.pm',
+ 'File/KDBX/Dumper/KDB.pm',
+ 'File/KDBX/Dumper/Raw.pm',
+ 'File/KDBX/Dumper/V3.pm',
+ 'File/KDBX/Dumper/V4.pm',
+ 'File/KDBX/Dumper/XML.pm',
+ 'File/KDBX/Entry.pm',
+ 'File/KDBX/Error.pm',
+ 'File/KDBX/Group.pm',
+ 'File/KDBX/IO.pm',
+ 'File/KDBX/IO/Crypt.pm',
+ 'File/KDBX/IO/HashBlock.pm',
+ 'File/KDBX/IO/HmacBlock.pm',
+ 'File/KDBX/Iterator.pm',
+ 'File/KDBX/KDF.pm',
+ 'File/KDBX/KDF/AES.pm',
+ 'File/KDBX/KDF/Argon2.pm',
+ 'File/KDBX/Key.pm',
+ 'File/KDBX/Key/ChallengeResponse.pm',
+ 'File/KDBX/Key/Composite.pm',
+ 'File/KDBX/Key/File.pm',
+ 'File/KDBX/Key/Password.pm',
+ 'File/KDBX/Key/YubiKey.pm',
+ 'File/KDBX/Loader.pm',
+ 'File/KDBX/Loader/KDB.pm',
+ 'File/KDBX/Loader/Raw.pm',
+ 'File/KDBX/Loader/V3.pm',
+ 'File/KDBX/Loader/V4.pm',
+ 'File/KDBX/Loader/XML.pm',
+ 'File/KDBX/Object.pm',
+ 'File/KDBX/Safe.pm',
+ 'File/KDBX/Transaction.pm',
+ 'File/KDBX/Util.pm'
+);
+
+
+
+# no fake home requested
+
+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<perlfaq8/How can I capture STDERR from an external command?>
+ 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) ) if $ENV{AUTHOR_TESTING};
+
+
--- /dev/null
+do { my $x = {
+ 'configure' => {
+ 'requires' => {
+ 'ExtUtils::MakeMaker' => '0'
+ }
+ },
+ 'develop' => {
+ 'requires' => {
+ 'Compress::Raw::Zlib' => '0',
+ 'Dist::Zilla' => '5',
+ 'Dist::Zilla::Plugin::Encoding' => '0',
+ 'Dist::Zilla::Plugin::OptionalFeature' => '0',
+ 'Dist::Zilla::Plugin::Prereqs' => '0',
+ 'Dist::Zilla::Plugin::Prereqs::Soften' => '0',
+ 'Dist::Zilla::PluginBundle::Author::CCM' => '0',
+ 'File::KDBX::XS' => '0',
+ 'IO::Compress::Gzip' => '0',
+ 'IO::Uncompress::Gunzip' => '0',
+ 'Pass::OTP' => '0',
+ 'Pod::Coverage::TrustPod' => '0',
+ 'Software::License::Perl_5' => '0',
+ 'Test::CPAN::Changes' => '0.19',
+ 'Test::CPAN::Meta' => '0',
+ 'Test::CleanNamespaces' => '0.15',
+ 'Test::EOL' => '0',
+ 'Test::MinimumVersion' => '0',
+ 'Test::More' => '0.96',
+ 'Test::NoTabs' => '0',
+ 'Test::Perl::Critic' => '0',
+ 'Test::Pod' => '1.41',
+ 'Test::Pod::Coverage' => '1.08',
+ 'Test::Pod::No404s' => '0',
+ 'Test::Portability::Files' => '0'
+ }
+ },
+ 'runtime' => {
+ 'recommends' => {
+ 'Compress::Raw::Zlib' => '0',
+ 'File::KDBX::XS' => '0',
+ 'File::Spec' => '0',
+ 'IO::Compress::Gzip' => '0',
+ 'IO::Uncompress::Gunzip' => '0',
+ 'Pass::OTP' => '0'
+ },
+ 'requires' => {
+ 'Carp' => '0',
+ 'Crypt::Argon2' => '0',
+ 'Crypt::Cipher' => '0',
+ 'Crypt::Digest' => '0',
+ 'Crypt::Mac::HMAC' => '0',
+ 'Crypt::Misc' => '0.029',
+ 'Crypt::Mode::CBC' => '0',
+ 'Crypt::PRNG' => '0',
+ 'Data::Dumper' => '0',
+ 'Devel::GlobalDestruction' => '0',
+ 'Encode' => '0',
+ 'Exporter' => '0',
+ 'File::Temp' => '0',
+ 'Hash::Util::FieldHash' => '0',
+ 'IO::Handle' => '0',
+ 'IPC::Cmd' => '0.52',
+ 'Iterator::Simple' => '0',
+ 'Iterator::Simple::Iterator' => '0',
+ 'List::Util' => '1.33',
+ 'Module::Load' => '0',
+ 'Module::Loaded' => '0',
+ 'POSIX' => '0',
+ 'Ref::Util' => '0',
+ 'Scalar::Util' => '0',
+ 'Scope::Guard' => '0',
+ 'Storable' => '0',
+ 'Symbol' => '0',
+ 'Text::ParseWords' => '0',
+ 'Time::Piece' => '0',
+ 'XML::LibXML' => '0',
+ 'XML::LibXML::Reader' => '0',
+ 'boolean' => '0',
+ 'namespace::clean' => '0',
+ 'overload' => '0',
+ 'strict' => '0',
+ 'warnings' => '0'
+ }
+ },
+ 'test' => {
+ 'recommends' => {
+ 'CPAN::Meta' => '2.120900',
+ 'Pass::OTP' => '0'
+ },
+ 'requires' => {
+ 'ExtUtils::MakeMaker' => '0',
+ 'File::Spec' => '0',
+ 'FindBin' => '0',
+ 'Getopt::Std' => '0',
+ 'IO::Handle' => '0',
+ 'IPC::Open3' => '0',
+ 'Test::Deep' => '0',
+ 'Test::Fatal' => '0',
+ 'Test::More' => '0',
+ 'Test::Warnings' => '0',
+ 'lib' => '0',
+ 'perl' => '5.006',
+ 'utf8' => '0'
+ },
+ 'suggests' => {
+ 'POSIX::1003' => '0'
+ }
+ }
+ };
+ $x;
+ }
\ No newline at end of file
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.028
+
+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(
+
+);
+
+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('Reported prereqs');
+
+# vim: ts=4 sts=4 sw=4 et:
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use File::KDBX::Cipher;
+use File::KDBX::Constants qw(CIPHER_UUID_AES256);
+use File::KDBX::IO::Crypt;
+use IO::Handle;
+use Test::More;
+
+subtest 'Round-trip block stream' => sub {
+ plan tests => 3;
+ my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16);
+ test_roundtrip($block_cipher,
+ 'Smell the pretty flowers.',
+ decode_b64('pB10mV+mhTuh7bKg0KEUl5H1ajFMaP4uPnTZNcDgq6s='),
+ );
+};
+
+subtest 'Round-trip cipher stream' => sub {
+ plan tests => 3;
+ my $cipher_stream = File::KDBX::Cipher->new(stream_id => 2, key => 0x01 x 16);
+ test_roundtrip($cipher_stream,
+ 'Smell the pretty flowers.',
+ decode_b64('gNj2Ud9tWtFDy+xDN/U01RxmCoI6MAlTKQ=='),
+ );
+};
+
+subtest 'Error handling' => sub {
+ plan tests => 4;
+
+ my $block_cipher = File::KDBX::Cipher->new(uuid => CIPHER_UUID_AES256, key => 0x01 x 32, iv => 0x01 x 16);
+ pipe(my $read, my $write) or die "pipe failed: $!";
+ $read = File::KDBX::IO::Crypt->new($read, cipher => $block_cipher);
+
+ print $write "blah blah blah!\1";
+ close($write) or die "close failed: $!";
+
+ is $read->error, '', 'Read handle starts out fine';
+ my $plaintext = do { local $/; <$read> };
+ is $plaintext, '', 'Read can fail';
+ is $read->error, 1, 'Read handle can enter an error state';
+
+ like $File::KDBX::IO::Crypt::ERROR, qr/fatal/i,
+ 'Error object is available';
+};
+
+done_testing;
+exit;
+
+sub test_roundtrip {
+ my $cipher = shift;
+ my $expected_plaintext = shift;
+ my $expected_ciphertext = shift;
+
+ pipe(my $read, my $write) or die "pipe failed: $!";
+ $write = File::KDBX::IO::Crypt->new($write, cipher => $cipher);
+
+ print $write $expected_plaintext;
+ close($write) or die "close failed: $!";
+
+ my $ciphertext = do { local $/; <$read> };
+ close($read);
+ is $ciphertext, $expected_ciphertext, 'Encrypted a string'
+ or diag encode_b64($ciphertext);
+
+ my $ciphertext2 = $cipher->encrypt_finish($expected_plaintext);
+ is $ciphertext, $ciphertext2, 'Same result';
+
+ open(my $fh, '<', \$ciphertext) or die "open failed: $!\n";
+ $fh = File::KDBX::IO::Crypt->new($fh, cipher => $cipher);
+
+ my $plaintext = do { local $/; <$fh> };
+ close($fh);
+ is $plaintext, $expected_plaintext, 'Decrypted a string'
+ or diag encode_b64($plaintext);
+}
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use FindBin qw($Bin);
+use lib "$Bin/lib";
+use TestCommon;
+
+use File::KDBX;
+use Test::Deep;
+use Test::More;
+use Time::Piece;
+
+subtest 'Create a new database' => sub {
+ my $kdbx = File::KDBX->new;
+
+ $kdbx->add_group(name => 'Meh');
+ ok $kdbx->_has_implicit_root, 'Database starts off with implicit root';
+
+ my $entry = $kdbx->add_entry({
+ username => 'hello',
+ password => {value => 'This is a secret!!!!!', protect => 1},
+ });
+
+ ok !$kdbx->_has_implicit_root, 'Adding an entry to the root group makes it explicit';
+
+ $entry->remove;
+ ok $kdbx->_has_implicit_root, 'Removing group makes the root group implicit again';
+};
+
+subtest 'Clone' => sub {
+ my $kdbx = File::KDBX->new;
+ $kdbx->add_group(name => 'Passwords')->add_entry(title => 'My Entry');
+
+ my $copy = $kdbx->clone;
+ cmp_deeply $copy, $kdbx, 'Clone keeps the same structure and data' or dumper $copy;
+
+ isnt $kdbx, $copy, 'Clone is a different object';
+ isnt $kdbx->root, $copy->root,
+ 'Clone root group is a different object';
+ isnt $kdbx->root->groups->[0], $copy->root->groups->[0],
+ 'Clone group is a different object';
+ isnt $kdbx->root->groups->[0]->entries->[0], $copy->root->groups->[0]->entries->[0],
+ 'Clone entry is a different object';
+
+ my @objects = $copy->objects->each;
+ subtest 'Cloned objects refer to the cloned database' => sub {
+ plan tests => scalar @_;
+ for my $object (@objects) {
+ my $object_kdbx = eval { $object->kdbx };
+ is $object_kdbx, $copy, 'Object: ' . $object->label;
+ }
+ }, @objects;
+};
+
+subtest 'Iteration algorithm' => sub {
+ # Database
+ # - Root
+ # - Group1
+ # - EntryA
+ # - Group2
+ # - EntryB
+ # - Group3
+ # - EntryC
+ my $kdbx = File::KDBX->new;
+ my $group1 = $kdbx->add_group(label => 'Group1');
+ my $group2 = $group1->add_group(label => 'Group2');
+ my $group3 = $kdbx->add_group(label => 'Group3');
+ my $entry1 = $group1->add_entry(label => 'EntryA');
+ my $entry2 = $group2->add_entry(label => 'EntryB');
+ my $entry3 = $group3->add_entry(label => 'EntryC');
+
+ cmp_deeply $kdbx->groups->map(sub { $_->label })->to_array,
+ [qw(Root Group1 Group2 Group3)], 'Default group order';
+ cmp_deeply $kdbx->entries->map(sub { $_->label })->to_array,
+ [qw(EntryA EntryB EntryC)], 'Default entry order';
+ cmp_deeply $kdbx->objects->map(sub { $_->label })->to_array,
+ [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'Default object order';
+
+ cmp_deeply $kdbx->groups(algorithm => 'ids')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 Group2 Group3)], 'IDS group order';
+ cmp_deeply $kdbx->entries(algorithm => 'ids')->map(sub { $_->label })->to_array,
+ [qw(EntryA EntryB EntryC)], 'IDS entry order';
+ cmp_deeply $kdbx->objects(algorithm => 'ids')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 EntryA Group2 EntryB Group3 EntryC)], 'IDS object order';
+
+ cmp_deeply $kdbx->groups(algorithm => 'dfs')->map(sub { $_->label })->to_array,
+ [qw(Group2 Group1 Group3 Root)], 'DFS group order';
+ cmp_deeply $kdbx->entries(algorithm => 'dfs')->map(sub { $_->label })->to_array,
+ [qw(EntryB EntryA EntryC)], 'DFS entry order';
+ cmp_deeply $kdbx->objects(algorithm => 'dfs')->map(sub { $_->label })->to_array,
+ [qw(Group2 EntryB Group1 EntryA Group3 EntryC Root)], 'DFS object order';
+
+ cmp_deeply $kdbx->groups(algorithm => 'bfs')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 Group3 Group2)], 'BFS group order';
+ cmp_deeply $kdbx->entries(algorithm => 'bfs')->map(sub { $_->label })->to_array,
+ [qw(EntryA EntryC EntryB)], 'BFS entry order';
+ cmp_deeply $kdbx->objects(algorithm => 'bfs')->map(sub { $_->label })->to_array,
+ [qw(Root Group1 EntryA Group3 EntryC Group2 EntryB)], 'BFS object order';
+};
+
+subtest 'Recycle bin' => sub {
+ my $kdbx = File::KDBX->new;
+ my $entry = $kdbx->add_entry(label => 'Meh');
+
+ my $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
+ ok !$bin, 'New database has no recycle bin';
+
+ is $kdbx->recycle_bin_enabled, 1, 'Recycle bin is enabled';
+ $kdbx->recycle_bin_enabled(0);
+
+ $entry->recycle_or_remove;
+ cmp_ok $entry->is_recycled, '==', 0, 'Entry is not recycle if recycle bin is disabled';
+
+ $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
+ ok !$bin, 'Recycle bin not autovivified if recycle bin is disabled';
+ is $kdbx->entries->size, 0, 'Database is empty after removing entry';
+
+ $kdbx->recycle_bin_enabled(1);
+
+ $entry = $kdbx->add_entry(label => 'Another one');
+ $entry->recycle_or_remove;
+ cmp_ok $entry->is_recycled, '==', 1, 'Entry is recycled';
+
+ $bin = $kdbx->groups->grep(name => 'Recycle Bin')->next;
+ ok $bin, 'Recycle bin group autovivifies';
+ cmp_ok $bin->icon_id, '==', 43, 'Recycle bin has the trash icon';
+ cmp_ok $bin->enable_auto_type, '==', 0, 'Recycle bin has auto type disabled';
+ cmp_ok $bin->enable_searching, '==', 0, 'Recycle bin has searching disabled';
+
+ is $kdbx->entries->size, 1, 'Database is not empty';
+ is $kdbx->entries(searching => 1)->size, 0, 'Database has no entries if searching';
+ cmp_ok $bin->entries_deeply->size, '==', 1, 'Recycle bin has an entry';
+
+ $entry->recycle_or_remove;
+ is $kdbx->entries->size, 0, 'Remove entry if it is already in the recycle bin';
+};
+
+subtest 'Maintenance' => sub {
+ my $kdbx = File::KDBX->new;
+ $kdbx->add_group;
+ $kdbx->add_group->add_group;
+ my $entry = $kdbx->add_group->add_entry;
+
+ cmp_ok $kdbx->remove_empty_groups, '==', 3, 'Remove two empty groups';
+ cmp_ok $kdbx->groups->count, '==', 2, 'Two groups remain';
+
+ $entry->begin_work;
+ $entry->commit;
+ cmp_ok $kdbx->prune_history(max_age => 5), '==', 0, 'Do not remove new historical entries';
+
+ $entry->begin_work;
+ $entry->commit;
+ $entry->history->[0]->last_modification_time(scalar gmtime - 86400 * 10);
+ cmp_ok $kdbx->prune_history(max_age => 5), '==', 1, 'Remove a historical entry';
+ cmp_ok scalar @{$entry->history}, '==', 1, 'One historical entry remains';
+
+ cmp_ok $kdbx->remove_unused_icons, '==', 0, 'No icons to remove';
+ $kdbx->add_custom_icon('fake image 1');
+ $kdbx->add_custom_icon('fake image 2');
+ $entry->custom_icon('fake image 3');
+ cmp_ok $kdbx->remove_unused_icons, '==', 2, 'Remove unused icons';
+ cmp_ok scalar @{$kdbx->custom_icons}, '==', 1, 'Only one icon remains';
+
+ my $icon_uuid = $kdbx->add_custom_icon('fake image');
+ $entry->custom_icon('fake image');
+ cmp_ok $kdbx->remove_duplicate_icons, '==', 1, 'Remove duplicate icons';
+ is $entry->custom_icon_uuid, $icon_uuid, 'Uses of removed icon change';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use File::KDBX;
+use Test::Deep;
+use Test::More;
+
+subtest 'Construction' => sub {
+ my $entry = File::KDBX::Entry->new(my $data = {username => 'foo'});
+ is $entry, $data, 'Provided data structure becomes the object';
+ isa_ok $data, 'File::KDBX::Entry', 'Data structure is blessed';
+ is $entry->{username}, 'foo', 'username is in the object still';
+ is $entry->username, '', 'username is not the UserName string';
+
+ like exception { $entry->kdbx }, qr/disconnected/, 'Dies if disconnected';
+ $entry->kdbx(my $kdbx = File::KDBX->new);
+ is $entry->kdbx, $kdbx, 'Set a database after instantiation';
+
+ is_deeply $entry, {username => 'foo', strings => {UserName => {value => ''}}},
+ 'Entry data contains what was provided to the constructor plus vivified username';
+
+ $entry = File::KDBX::Entry->new(username => 'bar');
+ is $entry->{username}, undef, 'username is not set on the data';
+ is $entry->username, 'bar', 'username is set correctly as the UserName string';
+
+ cmp_deeply $entry, noclass({
+ auto_type => {
+ associations => [],
+ data_transfer_obfuscation => 0,
+ default_sequence => "{USERNAME}{TAB}{PASSWORD}{ENTER}",
+ enabled => bool(1),
+ },
+ background_color => "",
+ binaries => {},
+ custom_data => {},
+ custom_icon_uuid => undef,
+ foreground_color => "",
+ history => [],
+ icon_id => "Password",
+ override_url => "",
+ previous_parent_group => undef,
+ quality_check => bool(1),
+ strings => {
+ Notes => {
+ value => "",
+ },
+ Password => {
+ protect => bool(1),
+ value => "",
+ },
+ Title => {
+ value => "",
+ },
+ URL => {
+ value => "",
+ },
+ UserName => {
+ value => "bar",
+ },
+ },
+ tags => "",
+ times => {
+ last_modification_time => isa('Time::Piece'),
+ creation_time => isa('Time::Piece'),
+ last_access_time => isa('Time::Piece'),
+ expiry_time => isa('Time::Piece'),
+ expires => bool(0),
+ usage_count => 0,
+ location_changed => isa('Time::Piece'),
+ },
+ uuid => re('^(?s:.){16}$'),
+ }), 'Entry data contains UserName string and the rest default attributes';
+};
+
+subtest 'Accessors' => sub {
+ my $entry = File::KDBX::Entry->new;
+
+ $entry->creation_time('2022-02-02 12:34:56');
+ cmp_ok $entry->creation_time, '==', 1643805296, 'Creation time coerced into a Time::Piece (epoch)';
+ is $entry->creation_time->datetime, '2022-02-02T12:34:56', 'Creation time coerced into a Time::Piece';
+};
+
+subtest 'Custom icons' => sub {
+ plan tests => 10;
+ my $gif = pack('H*', '4749463839610100010000ff002c00000000010001000002003b');
+
+ my $entry = File::KDBX::Entry->new(my $kdbx = File::KDBX->new, icon_id => 42);
+ is $entry->custom_icon_uuid, undef, 'UUID is undef if no custom icon is set';
+ is $entry->custom_icon, undef, 'Icon is undef if no custom icon is set';
+ is $entry->icon_id, 'KCMMemory', 'Default icon is set to something';
+
+ is $entry->custom_icon($gif), $gif, 'Setting a custom icon returns icon';
+ is $entry->custom_icon, $gif, 'Henceforth the icon is set';
+ is $entry->icon_id, 'Password', 'Default icon got changed to first icon';
+ my $uuid = $entry->custom_icon_uuid;
+ isnt $uuid, undef, 'UUID is now set';
+
+ my $found = $entry->kdbx->custom_icon_data($uuid);
+ is $entry->custom_icon, $found, 'Custom icon on entry matches the database';
+
+ is $entry->custom_icon(undef), undef, 'Unsetting a custom icon returns undefined';
+ $found = $entry->kdbx->custom_icon_data($uuid);
+ is $found, $gif, 'Custom icon still exists in the database';
+};
+
+subtest 'History' => sub {
+ my $kdbx = File::KDBX->new;
+ my $entry = $kdbx->add_entry(label => 'Foo');
+ is scalar @{$entry->history}, 0, 'New entry starts with no history';
+ is $entry->current_entry, $entry, 'Current new entry is itself';
+ ok $entry->is_current, 'New entry is current';
+
+ my $txn = $entry->begin_work;
+ $entry->notes('Hello!');
+ $txn->commit;
+ is scalar @{$entry->history}, 1, 'Committing creates a historical entry';
+ ok $entry->is_current, 'New entry is still current';
+ ok $entry->history->[0]->is_historical, 'Historical entry is not current';
+ is $entry->notes, 'Hello!', 'New entry is modified after commit';
+ is $entry->history->[0]->notes, '', 'Historical entry is saved without modification';
+};
+
+subtest 'Update UUID' => sub {
+ my $kdbx = File::KDBX->new;
+
+ my $entry1 = $kdbx->add_entry(label => 'Foo');
+ my $entry2 = $kdbx->add_entry(label => 'Bar');
+
+ $entry2->url(sprintf('{REF:T@I:%s} {REF:T@I:%s}', $entry1->id, lc($entry1->id)));
+ is $entry2->expand_url, 'Foo Foo', 'Field reference expands'
+ or diag explain $entry2->url;
+
+ $entry1->uuid("\1" x 16);
+
+ is $entry2->url, '{REF:T@I:01010101010101010101010101010101} {REF:T@I:01010101010101010101010101010101}',
+ 'Replace field references when an entry UUID is changed';
+ is $entry2->expand_url, 'Foo Foo', 'Field reference expands after UUID is changed'
+ or diag explain $entry2->url;
+};
+
+subtest 'Auto-type' => sub {
+ my $kdbx = File::KDBX->new;
+
+ my $entry = $kdbx->add_entry(title => 'Meh');
+ $entry->add_auto_type_association({
+ window => 'Boring Store',
+ keystroke_sequence => 'yeesh',
+ });
+ $entry->add_auto_type_association({
+ window => 'Friendly Bank',
+ keystroke_sequence => 'blah',
+ });
+
+ my $window_title = 'Friendly';
+ my $entries = $kdbx->entries(auto_type => 1)
+ ->filter(sub {
+ my ($ata) = grep { $_->{window} =~ /\Q$window_title\E/i } @{$_->auto_type_associations};
+ return [$_, $ata->{keystroke_sequence} || $_->auto_type_default_sequence] if $ata;
+ });
+ cmp_ok $entries->count, '==', 1, 'Find auto-type window association';
+
+ (undef, my $keys) = @{$entries->next};
+ is $keys, 'blah', 'Select the correct association';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Util qw(:erase);
+use Test::More;
+
+my $data1 = 'hello';
+my $data2 = 'hello';
+my $hash1 = {foo => 'secret'};
+my $array1 = [qw(bar baz)];
+
+erase $data1, \$data2, $hash1, $array1;
+is $data1, undef, 'Erase by alias';
+is $data2, undef, 'Erase by reference';
+is scalar keys %$hash1, 0, 'Erase by hashref';
+is scalar @$array1, 0, 'Erase by arrayref';
+
+{
+ my $data3 = 'hello';
+ my $cleanup = erase_scoped $data3;
+ is $data3, 'hello', 'Data not yet erased';
+ undef $cleanup;
+ is $data3, undef, 'Scoped erased';
+}
+
+sub get_secret {
+ my $secret = 'conspiracy';
+ my $cleanup = erase_scoped \$secret;
+ return $secret;
+}
+
+my $another;
+{
+ my $thing = get_secret();
+ $another = $thing;
+ is $thing, 'conspiracy', 'Data not yet erased';
+ undef $thing;
+ is $thing, undef, 'Scope erased';
+}
+is $another, 'conspiracy', 'Data not erased in the other scalar';
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+BEGIN { delete $ENV{DEBUG} }
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Error;
+use File::KDBX;
+use Test::More;
+
+subtest 'Errors' => sub {
+ my $error = exception {
+ local $! = 1;
+ $@ = 'last exception';
+ throw 'uh oh', foo => 'bar';
+ };
+ like $error, qr/uh oh/, 'Errors can be thrown using the "throw" function';
+
+ $error = exception { $error->throw };
+ like $error, qr/uh oh/, 'Errors can be rethrown';
+
+ is $error->details->{foo}, 'bar', 'Errors can have details';
+ is $error->errno+0, 1, 'Errors record copy of errno when thrown';
+ is $error->previous, 'last exception', 'Warnings record copy of the last exception';
+
+ my $trace = $error->trace;
+ ok 0 < @$trace, 'Errors record a stacktrace';
+ like $trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+
+ $error = exception { File::KDBX::Error->throw('uh oh') };
+ like $error, qr/uh oh/, 'Errors can be thrown using the "throw" constructor';
+ like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+
+ $error = File::KDBX::Error->new('uh oh');
+ $error = exception { $error->throw };
+ like $error, qr/uh oh/, 'Errors can be thrown using the "throw" method';
+ like $error->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+};
+
+subtest 'Warnings' => sub {
+ my $warning = warning {
+ local $! = 1;
+ $@ = 'last exception';
+ alert 'uh oh', foo => 'bar';
+ };
+ like $warning, qr/uh oh/, 'Warnings are enabled by default' or diag 'Warnings: ', explain $warning;
+
+ SKIP: {
+ skip 'Warning object requires Perl 5.14 or later' if $] < 5.014;
+ is $warning->details->{foo}, 'bar', 'Warnings can have details';
+ is $warning->errno+0, 1, 'Warnings record copy of errno when logged';
+ is $warning->previous, 'last exception', 'Warnings record copy of the last exception';
+ like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+ };
+
+ $warning = warning { File::KDBX::Error->warn('uh oh') };
+ like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" constructor';
+ SKIP: {
+ skip 'Warning object requires Perl 5.14 or later' if $] < 5.014;
+ like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+ };
+
+ my $error = File::KDBX::Error->new('uh oh');
+ $warning = warning { $error->alert };
+ like $warning, qr/uh oh/, 'Warnings can be logged using the "alert" method';
+ SKIP: {
+ skip 'Warning object requires Perl 5.14 or later' if $] < 5.014;
+ like $warning->trace->[0], qr!^uh oh at \H+error\.t line \d+$!, 'Stacktrace is correct';
+ };
+
+ {
+ local $File::KDBX::WARNINGS = 0;
+ my @warnings = warnings { alert 'uh oh' };
+ is @warnings, 0, 'Warnings can be disabled locally'
+ or diag 'Warnings: ', explain(\@warnings);
+ }
+
+ SKIP: {
+ skip 'warnings::warnif_at_level is required', 1 if !warnings->can('warnif_at_level');
+ no warnings 'File::KDBX';
+ my @warnings = warnings { alert 'uh oh' };
+ is @warnings, 0, 'Warnings can be disabled lexically'
+ or diag 'Warnings: ', explain(\@warnings);
+ }
+
+ SKIP: {
+ skip 'warnings::fatal_enabled_at_level is required', 1 if !warnings->can('fatal_enabled_at_level');
+ use warnings FATAL => 'File::KDBX';
+ my $exception = exception { alert 'uh oh' };
+ like $exception, qr/uh oh/, 'Warnings can be fatal';
+ }
+
+ {
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = shift };
+ alert 'uh oh';
+ like $warning, qr/uh oh/, 'Warnings can be caught';
+ }
+};
+
+done_testing;
--- /dev/null
+\ 1\ 2\ 3\ 4\ 5\ 6\a\b \10\11\12\13\14\15\16\17\18\19 !"#$%&'()012
\ No newline at end of file
--- /dev/null
+0123456789abcdeffedcba98765432100123456789abcdeffedcba9876543210
\ No newline at end of file
--- /dev/null
+#!/usr/bin/env perl
+
+# This is a fake ykchalresp program that provides canned responses, for testing.
+
+use warnings;
+use strict;
+
+use Getopt::Std;
+
+my %opts;
+getopts('12HNn:i:', \%opts);
+
+my ($device, $hmac, $nonblocking, $in) = @opts{qw(n H N i)};
+
+if (!$hmac) {
+ print STDERR "HMAC-SHA1 not requested\n";
+ exit 3;
+}
+elsif (!defined($in) || $in ne '-') {
+ $in //= '(none)';
+ print STDERR "Unexpected input file: $in\n";
+ exit 3;
+}
+
+my $challenge = <STDIN>;
+
+my $mock = $ENV{YKCHALRESP_MOCK} || '';
+if ($mock eq 'block') {
+ if ($nonblocking) {
+ print STDERR "Yubikey core error: operation would block\n";
+ exit 1;
+ }
+ sleep 2;
+ succeed();
+}
+elsif ($mock eq 'error') {
+ my $resp = $ENV{YKCHALRESP_ERROR} || 'not yet implemented';
+ print STDERR "Yubikey core error: $resp\n";
+ exit 1;
+}
+elsif ($mock eq 'usberror') {
+ print STDERR "USB error: something happened\n";
+ exit 1;
+}
+else { # OK
+ succeed();
+}
+
+sub succeed {
+ my $resp = $ENV{YKCHALRESP_RESPONSE} || 'f000000000000000000000000000000000000000';
+ print "$resp\n";
+ exit 0;
+}
+
+exit 2;
--- /dev/null
+#!/usr/bin/env perl
+
+# This is a fake ykinfo program that provides canned responses, for testing.
+
+use warnings;
+use strict;
+
+use Getopt::Std;
+
+our ($opt_a, $opt_n);
+getopts('an:');
+
+my $device = $opt_n // -1;
+
+if ($device == 0) {
+ print q{serial: 123
+version: 2.0.0
+touch_level: 0
+vendor_id: 1050
+product_id: 113
+};
+ exit 0;
+}
+elsif ($device == 1) {
+ print q{serial: 456
+version: 3.0.1
+touch_level: 10
+vendor_id: 1050
+product_id: 401
+};
+ exit 0;
+}
+else {
+ print STDERR "Yubikey core error: no yubikey present\n";
+ exit 1;
+}
+
--- /dev/null
+BY\ 3Ææ\e\fðé\rwJ×\8eô\13\ 5A/à \ 4} ¼ð=\97\13d\14I
\ No newline at end of file
--- /dev/null
+We are all Satoshi.
--- /dev/null
+425903c6e61b0cf0e90d774ad78ef41305412fe009047da0bcf03d9713641449
\ No newline at end of file
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<KeyFile>
+ <Meta>
+ <Version>1.0</Version>
+ </Meta>
+ <Key>
+ <Data>
+ OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=
+ </Data>
+ </Key>
+</KeyFile>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<KeyFile>
+ <Meta>
+ <Version>2.0</Version>
+ </Meta>
+ <Key>
+ <Data Hash="984A141E">
+ 385F6D8F EB5FC30D 641CD590 68995958
+ 89417684 D55CE6B3 3FC83FBD 92BB35C2
+ </Data>
+ </Key>
+</KeyFile>
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Group;
+use File::KDBX;
+use Test::More;
+
+subtest 'Path' => sub {
+ my $kdbx = File::KDBX->new;
+ my $group_a = $kdbx->add_group(name => 'Group A');
+ my $group_b = $group_a->add_group(name => 'Group B');
+ is $kdbx->root->path, 'Root', 'Root group has path';
+ is $group_a->path, 'Group A', 'Layer 1 group has path';
+ is $group_b->path, 'Group A.Group B', 'Layer 2 group has path';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon qw(:no_warnings_test);
+
+use File::KDBX::Util qw(can_fork);
+use IO::Handle;
+use File::KDBX::IO::HashBlock;
+use Test::More;
+
+{
+ my $expected_plaintext = 'Tiny food from Spain!';
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ $write = File::KDBX::IO::HashBlock->new($write, block_size => 3);
+ print $write $expected_plaintext;
+ close($write) or die "close failed: $!";
+
+ $read = File::KDBX::IO::HashBlock->new($read);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ is $plaintext, $expected_plaintext, 'Hash-block just a little bit';
+}
+
+SKIP: {
+ skip 'fork required to test long data streams' if !can_fork;
+
+ my $expected_plaintext = "\x64" x (1024*1024*12 - 57);
+
+ local $SIG{CHLD} = 'IGNORE';
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if ($pid == 0) {
+ $write = File::KDBX::IO::HashBlock->new($write);
+ print $write $expected_plaintext;
+ close($write) or die "close failed: $!";
+ # exit;
+ require POSIX;
+ POSIX::_exit(0);
+ }
+
+ $read = File::KDBX::IO::HashBlock->new($read);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ is $plaintext, $expected_plaintext, 'Hash-block a lot';
+}
+
+subtest 'Error handling' => sub {
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ $read = File::KDBX::IO::HashBlock->new($read);
+
+ print $write 'blah blah blah';
+ close($write) or die "close failed: $!";
+
+ is $read->error, '', 'Read handle starts out fine';
+ my $data = do { local $/; <$read> };
+ is $read->error, 1, 'Read handle can enter an error state';
+
+ like $File::KDBX::IO::HashBlock::ERROR, qr/invalid block index/i, 'Error object is available';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon qw(:no_warnings_test);
+
+use File::KDBX::IO::HmacBlock;
+use File::KDBX::Util qw(can_fork);
+use IO::Handle;
+use Test::More;
+
+my $KEY = "\x01" x 64;
+
+{
+ my $expected_plaintext = 'Tiny food from Spain!';
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ $write = File::KDBX::IO::HmacBlock->new($write, block_size => 3, key => $KEY);
+ print $write $expected_plaintext;
+ close($write) or die "close failed: $!";
+
+ $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ is $plaintext, $expected_plaintext, 'HMAC-block just a little bit';
+
+ is $File::KDBX::IO::HmacBlock::ERROR, undef, 'No error when successful';
+}
+
+SKIP: {
+ skip 'fork required to test long data streams' if !can_fork;
+
+ my $expected_plaintext = "\x64" x (1024*1024*12 - 57);
+
+ local $SIG{CHLD} = 'IGNORE';
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if ($pid == 0) {
+ $write = File::KDBX::IO::HmacBlock->new($write, key => $KEY);
+ print $write $expected_plaintext;
+ close($write) or die "close failed: $!";
+ # exit;
+ require POSIX;
+ POSIX::_exit(0);
+ }
+
+ $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY);
+ my $plaintext = do { local $/; <$read> };
+ close($read);
+
+ is $plaintext, $expected_plaintext, 'HMAC-block a lot';
+}
+
+subtest 'Error handling' => sub {
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ $read = File::KDBX::IO::HmacBlock->new($read, key => $KEY);
+
+ print $write 'blah blah blah';
+ close($write) or die "close failed: $!";
+
+ is $read->error, '', 'Read handle starts out fine';
+ my $data = do { local $/; <$read> };
+ is $read->error, 1, 'Read handle can enter an error state';
+
+ like $File::KDBX::IO::HmacBlock::ERROR, qr/failed to read HMAC/i, 'Error object is available';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Iterator;
+use File::KDBX::Entry;
+use File::KDBX::Util qw(:load);
+use Iterator::Simple qw(:all);
+use Test::More;
+
+subtest 'Basic' => sub {
+ my $it = File::KDBX::Iterator->new(1..10);
+
+ is $it->(), 1, 'Get next item (1)';
+ is $it->(), 2, 'Get next item (2)';
+ $it->unget(-5);
+ is $it->(), -5, 'Unget';
+ is $it->peek, 3, 'Peek at next';
+ is $it->(), 3, 'Get next item (3)';
+ is $it->count, 7, 'Get current size';
+
+ my $limited = $it->limit(3);
+ is $limited->count, 3, 'Get current size';
+ my $enum = ienumerate $limited;
+ is_deeply $enum->to_array, [[0, 4], [1, 5], [2, 6]], 'Use Iterator::Simple functions';
+
+ is $it->(), 7, 'Original iterator is drained by composing iterator';
+
+ is $it->next(sub { $_ == 9 }), 9, 'Find next matching item';
+ is $it->next, 10, 'Item got skipped while finding next match';
+ is $it->peek, undef, 'No more items (peek)';
+ is $it->next, undef, 'No more items (next)';
+
+ $it->(qw{10 20 30});
+ is_deeply [$it->each], [qw{10 20 30}], 'Fill buffer and get each item (list)';
+ is $it->(), undef, 'Empty';
+
+ $it->(my $buffer = [qw{a b c}]);
+ my @each;
+ $it->each(sub { push @each, $_ });
+ is_deeply \@each, [qw{a b c}], 'Fill buffer and get each item (function)';
+ is_deeply $buffer, [], 'Buffer is empty';
+};
+
+subtest 'Sorting' => sub {
+ my $new_it = sub {
+ File::KDBX::Iterator->new(
+ File::KDBX::Entry->new(label => 'foo', icon_id => 1),
+ File::KDBX::Entry->new(label => 'bar', icon_id => 5),
+ File::KDBX::Entry->new(label => 'BaZ', icon_id => 3),
+ File::KDBX::Entry->new(label => 'qux', icon_id => 2),
+ File::KDBX::Entry->new(label => 'Muf', icon_id => 4),
+ );
+ };
+
+ my @sort = (label => collate => 0);
+
+ my $it = $new_it->();
+ is_deeply $it->sort_by(@sort)->map(sub { $_->label })->to_array,
+ [qw{BaZ Muf bar foo qux}], 'Sort text ascending';
+
+ $it = $new_it->();
+ is_deeply $it->sort_by(@sort, case => 0)->map(sub { $_->label })->to_array,
+ [qw{bar BaZ foo Muf qux}], 'Sort text ascending, ignore-case';
+
+ $it = $new_it->();
+ is_deeply $it->sort_by(@sort, ascending => 0)->map(sub { $_->label })->to_array,
+ [qw{qux foo bar Muf BaZ}], 'Sort text descending';
+
+ $it = $new_it->();
+ is_deeply $it->sort_by(@sort, ascending => 0, case => 0)->map(sub { $_->label })->to_array,
+ [qw{qux Muf foo BaZ bar}], 'Sort text descending, ignore-case';
+
+ SKIP: {
+ plan skip_all => 'Unicode::Collate required to test collation sorting'
+ if !try_load_optional('Unicode::Collate');
+
+ # FIXME I'm missing something....
+ # $it = $new_it->();
+ # is_deeply $it->sort_by('label')->map(sub { $_->label })->to_array,
+ # [qw{BaZ Muf bar foo qux}], 'Sort text ascending using Unicode::Collate';
+
+ $it = $new_it->();
+ is_deeply $it->sort_by('label', case => 0)->map(sub { $_->label })->to_array,
+ [qw{bar BaZ foo Muf qux}], 'Sort text ascending, ignore-case using Unicode::Collate';
+ }
+
+ $it = $new_it->();
+ is_deeply $it->nsort_by('icon_id')->map(sub { $_->label })->to_array,
+ [qw{foo qux BaZ Muf bar}], 'Sort text numerically, ascending';
+
+ $it = $new_it->();
+ is_deeply $it->nsort_by('icon_id', ascending => 0)->map(sub { $_->label })->to_array,
+ [qw{bar Muf BaZ qux foo}], 'Sort text numerically, descending';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Encode qw(decode);
+use File::KDBX;
+use Test::Deep;
+use Test::More;
+
+eval { require File::KeePass; require File::KeePass::KDBX }
+ or plan skip_all => 'File::KeePass and File::KeePass::KDBX required to test KDB files';
+
+my $kdbx = File::KDBX->load(testfile('basic.kdb'), 'masterpw');
+
+sub test_basic {
+ my $kdbx = shift;
+
+ cmp_deeply $kdbx->headers, superhashof({
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ encryption_iv => "\250\354q\362\13\247\353\247\222!\232\364Lj\315w",
+ master_seed => "\212z\356\256\340+\n\243ms2\364'!7\216",
+ transform_rounds => 713,
+ transform_seed => "\227\264\n^\230\2\301:!f\364\336\251\277\241[\3`\314RG\343\16U\333\305eT3:\240\257",
+ }), 'Get expected headers from KDB file' or diag explain $kdbx->headers;
+
+ is keys %{$kdbx->deleted_objects}, 0, 'There are no deleted objects' or dumper $kdbx->deleted_objects;
+ is scalar @{$kdbx->root->groups}, 2, 'Root group has two children';
+
+ my $group1 = $kdbx->root->groups->[0];
+ isnt $group1->uuid, undef, 'Group 1 has a UUID';
+ is $group1->name, 'Internet', 'Group 1 has a name';
+ is scalar @{$group1->groups}, 2, 'Group 1 has subgroups';
+ is scalar @{$group1->entries}, 2, 'Group 1 has entries';
+ is $group1->icon_id, 1, 'Group 1 has an icon';
+
+ my ($entry11, $entry12, @other) = @{$group1->entries};
+
+ isnt $entry11->uuid, undef, 'Entry has a UUID';
+ is $entry11->title, 'Test entry', 'Entry has a title';
+ is $entry11->icon_id, 1, 'Entry has an icon';
+ is $entry11->username, 'I', 'Entry has a username';
+ is $entry11->url, 'http://example.com/', 'Entry has a URL';
+ is $entry11->password, 'secretpassword', 'Entry has a password';
+ is $entry11->notes, "Lorem ipsum\ndolor sit amet", 'Entry has notes';
+ ok $entry11->expires, 'Entry is expired';
+ is $entry11->expiry_time, 'Wed May 9 10:32:00 2012', 'Entry has an expiration time';
+ is scalar keys %{$entry11->binaries}, 1, 'Entry has a binary';
+ is $entry11->binary_value('attachment.txt'), "hello world\n", 'Entry has a binary';
+
+ is $entry12->title, '', 'Entry 2 has an empty title';
+ is $entry12->icon_id, 0, 'Entry 2 has an icon';
+ is $entry12->username, '', 'Entry 2 has an empty username';
+ is $entry12->url, '', 'Entry 2 has an empty URL';
+ is $entry12->password, '', 'Entry 2 has an empty password';
+ is $entry12->notes, '', 'Entry 2 has empty notes';
+ ok !$entry12->expires, 'Entry 2 is not expired';
+ is scalar keys %{$entry12->binaries}, 0, 'Entry has no binaries';
+
+ my $group11 = $group1->groups->[0];
+ is $group11->label, 'Subgroup 1', 'Group has subgroup';
+ is scalar @{$group11->groups}, 1, 'Subgroup has subgroup';
+
+ my $group111 = $group11->groups->[0];
+ is $group111->label, 'Unexpanded', 'Has unexpanded group';
+ is scalar @{$group111->groups}, 1, 'Subgroup has subgroup';
+
+ my $group1111 = $group111->groups->[0];
+ is $group1111->label, 'abc', 'Group has subsubsubroup';
+ is scalar @{$group1111->groups}, 0, 'No more subgroups';
+
+ my $group12 = $group1->groups->[1];
+ is $group12->label, 'Subgroup 2', 'Group has another subgroup';
+ is scalar @{$group12->groups}, 0, 'No more subgroups';
+
+ my $group2 = $kdbx->root->groups->[1];
+ is $group2->label, 'eMail', 'Root has another subgroup';
+ is scalar @{$group2->entries}, 1, 'eMail group has an entry';
+ is $group2->icon_id, 19, 'Group has a standard icon';
+}
+for my $test (
+ ['Basic' => $kdbx],
+ ['Basic after dump & load roundtrip'
+ => File::KDBX->load_string($kdbx->dump_string('a', randomize_seeds => 0), 'a')],
+) {
+ my ($name, $kdbx) = @$test;
+ subtest $name, \&test_basic, $kdbx;
+}
+
+sub test_custom_icons {
+ my $kdbx = shift;
+ $kdbx = $kdbx->() if ref $kdbx eq 'CODE';
+
+ my ($icon, @other) = @{$kdbx->custom_icons};
+ ok $icon, 'Database has a custom icon';
+ is scalar @other, 0, 'Database has no other icons';
+
+ like $icon->{data}, qr/^\x89PNG\r\n/, 'Custom icon is a PNG';
+}
+for my $test (
+ ['Custom icons' => $kdbx],
+ ['Custom icons after dump & load roundtrip' => sub {
+ File::KDBX->load_string($kdbx->dump_string('a', allow_upgrade => 0, randomize_seeds => 0), 'a');
+ }],
+) {
+ my ($name, $kdbx) = @$test;
+ subtest $name, \&test_custom_icons, $kdbx;
+}
+
+subtest 'Group expansion' => sub {
+ is $kdbx->root->groups->[0]->is_expanded, 1, 'Group is expanded';
+ is $kdbx->root->groups->[0]->groups->[0]->is_expanded, 1, 'Subgroup is expanded';
+ is $kdbx->root->groups->[0]->groups->[0]->groups->[0]->is_expanded, 0, 'Subsubgroup is not expanded';
+};
+
+subtest 'Autotype' => sub {
+ my $group = $kdbx->root->groups->[0]->groups->[0];
+ is scalar @{$group->entries}, 2, 'Group has two entries';
+
+ my ($entry1, $entry2) = @{$group->entries};
+
+ is $entry1->notes, "\nlast line", 'First entry has a note';
+ TODO: {
+ local $TODO = 'File::KeePass fails to parse out the default key sequence';
+ is $entry1->auto_type->{default_sequence}, '{USERNAME}{ENTER}', 'First entry has a default sequence';
+ };
+ cmp_deeply $entry1->auto_type->{associations}, set(
+ {
+ keystroke_sequence => "{USERNAME}{ENTER}",
+ window => "a window",
+ },
+ {
+ keystroke_sequence => "{USERNAME}{ENTER}",
+ window => "a second window",
+ },
+ {
+ keystroke_sequence => "{PASSWORD}{ENTER}",
+ window => "Window Nr 1a",
+ },
+ {
+ keystroke_sequence => "{PASSWORD}{ENTER}",
+ window => "Window Nr 1b",
+ },
+ {
+ keystroke_sequence => "{USERNAME}{ENTER}",
+ window => "Window 2",
+ },
+ ), 'First entry has auto-type window associations';
+
+ is $entry2->notes, "start line\nend line", 'Second entry has notes';
+ TODO: {
+ local $TODO = 'File::KeePass fails to parse out the default key sequence';
+ is $entry2->auto_type->{default_sequence}, '', 'Second entry has no default sequence';
+ cmp_deeply $entry2->auto_type->{associations}, set(
+ {
+ keystroke_sequence => "",
+ window => "Main Window",
+ },
+ {
+ keystroke_sequence => "",
+ window => "Test Window",
+ },
+ ), 'Second entry has auto-type window associations' or diag explain $entry2->auto_type->{associations};
+ };
+};
+
+subtest 'KDB file keys' => sub {
+ while (@_) {
+ my ($name, $key) = splice @_, 0, 2;
+ my $kdb_filepath = testfile("$name.kdb");
+ my $kdbx = File::KDBX->load($kdb_filepath, $key);
+
+ is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
+ }
+}, (
+ FileKeyBinary => {file => testfile('FileKeyBinary.key')},
+ FileKeyHex => {file => testfile('FileKeyHex.key')},
+ FileKeyHashed => {file => testfile('FileKeyHashed.key')},
+ CompositeKey => ['mypassword', {file => testfile('FileKeyHex.key')}],
+);
+
+subtest 'Twofish' => sub {
+ plan skip_all => 'File::KeePass does not implement the Twofish cipher';
+ my $name = 'Twofish';
+ my $kdbx = File::KDBX->load(testfile("$name.kdb"), 'masterpw');
+ is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
+};
+
+subtest 'CP-1252 password' => sub {
+ my $name = 'CP-1252';
+ my $kdbx = File::KDBX->load(testfile("$name.kdb"),
+ decode('UTF-8', "\xe2\x80\x9e\x70\x61\x73\x73\x77\x6f\x72\x64\xe2\x80\x9d"));
+ is $kdbx->root->name, $name, "Loaded KDB database with root group is named $name";
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use File::KDBX::Constants qw(:version :kdf);
+use Test::Deep;
+use Test::More;
+
+my $kdbx = File::KDBX->load(testfile('Format200.kdbx'), 'a');
+
+verify_kdbx2($kdbx, KDBX_VERSION_2_0);
+is $kdbx->kdf->uuid, KDF_UUID_AES, 'KDBX2 file has a usable KDF configured';
+
+my $dump;
+like warning { $dump = $kdbx->dump_string('a', randomize_seeds => 0) }, qr/upgrading database/i,
+ 'There is a warning about a change in file version when writing';
+
+my $kdbx_from_dump = File::KDBX->load_string($dump, 'a');
+verify_kdbx2($kdbx_from_dump, KDBX_VERSION_3_1);
+is $kdbx->kdf->uuid, KDF_UUID_AES, 'New KDBX3 file has the same KDF';
+
+sub verify_kdbx2 {
+ my $kdbx = shift;
+ my $vers = shift;
+
+ ok_magic $kdbx, $vers, 'Get the correct KDBX2 file magic';
+
+ cmp_deeply $kdbx->headers, superhashof({
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "D+VZ\277\274>\226K\225\3237\255\231\35\4",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "\214\aW\253\362\177<\346n`\263l\245\353T\25\261BnFp\177\357\335\36(b\372z\231b\355",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "S\202\207A\3475\265\177\220\331\263[\334\326\365\324B\\\2222zb-f\263m\220\333S\361L\332",
+ },
+ master_seed => "\253!\2\241\r*|{\227\0276Lx\215\32\\\17\372d\254\255*\21r\376\251\313+gMI\343",
+ stream_start_bytes => "\24W\24\3262oU\t>\242B\2666:\231\377\36\3\353 \217M\330U\35\367|'\230\367\221^",
+ }), 'Get expected headers from KDBX2 file' or diag explain $kdbx->headers;
+
+ cmp_deeply $kdbx->meta, superhashof({
+ custom_data => {},
+ database_description => "",
+ database_description_changed => obj_isa('Time::Piece'),
+ database_name => "",
+ database_name_changed => obj_isa('Time::Piece'),
+ default_username => "",
+ default_username_changed => obj_isa('Time::Piece'),
+ entry_templates_group => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
+ entry_templates_group_changed => obj_isa('Time::Piece'),
+ generator => ignore(),
+ last_selected_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221",
+ last_top_visible_group => "\226Y\251\22\356zB\@\214\222ns\273a\263\221",
+ maintenance_history_days => 365,
+ memory_protection => superhashof({
+ protect_notes => bool(0),
+ protect_password => bool(0),
+ protect_title => bool(0),
+ protect_url => bool(1),
+ protect_username => bool(1),
+ }),
+ recycle_bin_changed => obj_isa('Time::Piece'),
+ recycle_bin_enabled => bool(1),
+ recycle_bin_uuid => "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0",
+ }), 'Get expected metadata from KDBX2 file' or diag explain $kdbx->meta;
+
+ $kdbx->unlock;
+
+ is scalar @{$kdbx->root->entries}, 1, 'Get one entry in root';
+
+ my $entry = $kdbx->root->entries->[0];
+ is $entry->title, 'Sample Entry', 'Get the correct title';
+ is $entry->username, 'User Name', 'Get the correct username';
+
+ cmp_deeply $entry->binaries, {
+ "myattach.txt" => {
+ value => "abcdefghijk",
+ },
+ "test.txt" => {
+ value => "this is a test",
+ },
+ }, 'Get two attachments from the entry' or diag explain $entry->binaries;
+
+ my @history = @{$entry->history};
+ is scalar @history, 2, 'Get two historical entries';
+ is scalar keys %{$history[0]->binaries}, 0, 'First historical entry has no attachments';
+ is scalar keys %{$history[1]->binaries}, 1, 'Second historical entry has one attachment';
+ cmp_deeply $history[1]->binary('myattach.txt'), {
+ value => 'abcdefghijk',
+ }, 'The attachment has the correct content';
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use File::KDBX::Constants qw(:version);
+use Test::Deep;
+use Test::More;
+
+subtest 'Verify Format300' => sub {
+ my $kdbx = File::KDBX->load(testfile('Format300.kdbx'), 'a');
+
+ ok_magic $kdbx, KDBX_VERSION_3_0, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "\214\306\310\0322\a9P\230\306\253\326\17\214\344\255",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "\346\n8\2\322\264i\5\5\274\22\377+\16tB\353\210\1\2m\2U%\326\347\355\313\313\340A\305",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "\340\377\235\255\222o\1(\226m\373\tC{K\352\f\332M\302|~P\e\346J\@\275A\227\236\366",
+ },
+ master_seed => "Z\230\355\353\2303\361\237-p\345\27nM\22<E\252\314k\20\257\302\343p\"y\5sfw ",
+ stream_start_bytes => "\276\277jI1_\325\a\375\22\3\366\2V\"\316\370\316E\250B\317\232\232\207K\345.P\256b/",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Test Database Format 0x00030000', 'Extract database name from meta';
+ is $kdbx->root->name, 'Format300', 'Extract name of root group';
+};
+
+subtest 'Verify NonAscii' => sub {
+ my $kdbx = File::KDBX->load(testfile('NonAscii.kdbx'), 'Δöض');
+
+ ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 0,
+ encryption_iv => "\264\256\210m\311\312s\274U\206\t^\202\323\365]",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "Z\244]\373\13`\2108=>\r\224\351\373\316\276\253\6\317z\356\302\36\fW\1776Q\366\32\34,",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "l\254\250\255\240U\313\364\336\316#\254\306\231\f%U\207J\235\275\34\b\25036\26\241\a\300\26\332",
+ },
+ master_seed => "\13\350\370\214{\0276\17dv\31W[H\26\272\4\335\377\356\275N\"\2A1\364\213\226\237\303M",
+ stream_start_bytes => "\220Ph\27\"h\233^\263mf\3339\262U\313\236zF\f\23\b9\323\346=\272\305})\240T",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'NonAsciiTest', 'Extract database name from meta';
+};
+
+subtest 'Verify Compressed' => sub {
+ my $kdbx = File::KDBX->load(testfile('Compressed.kdbx'), '');
+
+ ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "Z(\313\342\212x\f\326\322\342\313\320\352\354:S",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "+\232\222\302\20\333\254\342YD\371\34\373,\302:\303\247\t\26\$\a\370g\314\32J\240\371;U\234",
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "\3!\230hx\363\220nV\23\340\316\262\210\26Z\al?\343\240\260\325\262\31i\223y\b\306\344V",
+ },
+ master_seed => "\0206\244\265\203m14\257T\372o\16\271\306\347\215\365\376\304\20\356\344\3713\3\303\363\a\5\205\325",
+ stream_start_bytes => "i%Ln\30\r\261\212Q\266\b\201\et\342\203\203\374\374E\303\332\277\320\13\304a\223\215#~\266",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Compressed', 'Extract database name from meta';
+};
+
+subtest 'Verify ProtectedStrings' => sub {
+ my $kdbx = File::KDBX->load(testfile('ProtectedStrings.kdbx'), 'masterpw');
+
+ ok_magic $kdbx, KDBX_VERSION_3_1, 'Get the correct KDBX3 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "1\301\362\346\277qCP\276X\5!j\374Z\377",
+ compression_flags => 1,
+ encryption_iv => "\0177y\356&\217\215\244\341\312\317Z\246m\363\251",
+ inner_random_stream_id => 2,
+ inner_random_stream_key => "%M\333Z\345\22T\363\257\27\364\206\352\334\r\3\361\250\360\314\213\253\237\23B\252h\306\243(7\13",
+ kdf_parameters => ignore(),
+ kdf_parameters => {
+ "\$UUID" => "\311\331\363\232b\212D`\277t\r\b\301\212O\352",
+ R => 6000,
+ S => "y\251\327\312mW8B\351\273\364#T#m:\370k1\240v\360E\245\304\325\265\313\337\245\211E",
+ },
+ master_seed => "\355\32<1\311\320\315\24\204\325\250\35+\2525\321\224x?\361\355\310V\322\20\331\324\"\372\334\210\233",
+ stream_start_bytes => "D#\337\260,\340.\276\312\302N\336y\233\275\360\250|\272\346*.\360\256\232\220\263>\303\aQ\371",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Protected Strings Test', 'Extract database name from meta';
+
+ $kdbx->unlock;
+
+ my $entry = $kdbx->entries->next;
+ is $entry->title, 'Sample Entry', 'Get entry title';
+ is $entry->username, 'Protected User Name', 'Get protected username from entry';
+ is $entry->password, 'ProtectedPassword', 'Get protected password from entry';
+ is $entry->string_value('TestProtected'), 'ABC', 'Get ABC string from entry';
+ is $entry->string_value('TestUnprotected'), 'DEF', 'Get DEF string from entry';
+
+ ok $kdbx->meta->{memory_protection}{protect_password}, 'Memory protection is ON for passwords';
+ ok $entry->string('TestProtected')->{protect}, 'Protection is ON for TestProtected';
+ ok !$entry->string('TestUnprotected')->{protect}, 'Protection is OFF for TestUnprotected';
+};
+
+subtest 'Verify BrokenHeaderHash' => sub {
+ like exception { File::KDBX->load(testfile('BrokenHeaderHash.kdbx'), '') },
+ qr/header hash does not match/i, 'Fail to load a database with a corrupted header hash';
+};
+
+subtest 'Dump and load' => sub {
+ my $kdbx = File::KDBX->new;
+ my $dump = $kdbx->dump_string('foo');
+ ok $dump;
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use File::KDBX::Constants qw(:version :kdf);
+use Test::Deep;
+use Test::More;
+use boolean qw(:all);
+
+subtest 'Verify Format400' => sub {
+ my $kdbx = File::KDBX->load(testfile('Format400.kdbx'), 't');
+ $kdbx->unlock;
+
+ ok_magic $kdbx, KDBX_VERSION_4_0, 'Get the correct KDBX4 file magic';
+
+ cmp_deeply $kdbx->headers, {
+ cipher_id => "\326\3\212+\213oL\265\245\$3\2321\333\265\232",
+ compression_flags => 1,
+ encryption_iv => "3?\207P\233or\220\215h\2240",
+ kdf_parameters => {
+ "\$UUID" => "\357cm\337\214)DK\221\367\251\244\3\343\n\f",
+ I => 2,
+ M => 1048576,
+ P => 2,
+ S => "V\254\6m-\206*\260\305\f\0\366\24:4\235\364A\362\346\221\13)}\250\217P\303\303\2\331\245",
+ V => 19,
+ },
+ master_seed => ";\372y\300yS%\3331\177\231\364u\265Y\361\225\3273h\332R,\22\240a\240\302\271\357\313\23",
+ }, 'Extract headers' or diag explain $kdbx->headers;
+
+ is $kdbx->meta->{database_name}, 'Format400', 'Extract database name from meta';
+ is $kdbx->root->name, 'Format400', 'Extract name of root group';
+
+ my ($entry, @other) = $kdbx->entries->grep(\'400', 'title')->each;
+ is scalar @other, 0, 'Database has one entry';
+
+ is $entry->title, 'Format400', 'Entry is titled';
+ is $entry->username, 'Format400', 'Entry has a username set';
+ is keys %{$entry->strings}, 6, 'Entry has six strings';
+ is $entry->string_value('Format400'), 'Format400', 'Entry has a custom string';
+ is keys %{$entry->binaries}, 1, 'Entry has one binary';
+ is $entry->binary_value('Format400'), "Format400\n", 'Entry has a binary string';
+};
+
+subtest 'KDBX4 upgrade' => sub {
+ my $kdbx = File::KDBX->new;
+
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES_CHALLENGE_RESPONSE;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'AES challenge-response KDF requires upgrade';
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2D;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2D KDF requires upgrade';
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_ARGON2ID;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Argon2ID KDF requires upgrade';
+ $kdbx->kdf_parameters->{+KDF_PARAM_UUID} = KDF_UUID_AES;
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $kdbx->public_custom_data->{foo} = 42;
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Public custom data requires upgrade';
+ delete $kdbx->public_custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ my $entry = $kdbx->add_entry;
+ $entry->custom_data(foo => 'bar');
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Entry custom data requires upgrade';
+ delete $entry->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ my $group = $kdbx->add_group;
+ $group->custom_data(foo => 'bar');
+ is $kdbx->minimum_version, KDBX_VERSION_4_0, 'Group custom data requires upgrade';
+ delete $group->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+};
+
+subtest 'KDBX4.1 upgrade' => sub {
+ my $kdbx = File::KDBX->new;
+
+ my $group1 = $kdbx->add_group(label => 'One');
+ my $group2 = $kdbx->add_group(label => 'Two');
+ my $entry1 = $kdbx->add_entry(label => 'Meh');
+
+ $group1->tags('hi');
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Groups with tags requires upgrade';
+ $group1->tags('');
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $entry1->quality_check(0);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Disable entry quality check requires upgrade';
+ $entry1->quality_check(1);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $group1->previous_parent_group($group2->uuid);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on group requires upgrade';
+ $group1->previous_parent_group(undef);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $entry1->previous_parent_group($group2->uuid);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Previous parent group on entry requires upgrade';
+ $entry1->previous_parent_group(undef);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $kdbx->add_custom_icon('data');
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Icon with no metadata requires no upgrade';
+ my $icon_uuid = $kdbx->add_custom_icon('data2', name => 'icon name');
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with name requires upgrade';
+ $kdbx->remove_custom_icon($icon_uuid);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+ $icon_uuid = $kdbx->add_custom_icon('data2', last_modification_time => gmtime);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Icon with modtime requires upgrade';
+ $kdbx->remove_custom_icon($icon_uuid);
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $entry1->custom_data(foo => 'bar', last_modification_time => scalar gmtime);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Entry custom data modtime requires upgrade';
+ delete $entry1->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+
+ $group1->custom_data(foo => 'bar', last_modification_time => scalar gmtime);
+ is $kdbx->minimum_version, KDBX_VERSION_4_1, 'Group custom data modtime requires upgrade';
+ delete $group1->custom_data->{foo};
+ is $kdbx->minimum_version, KDBX_VERSION_3_1, 'Reset upgrade requirement';
+};
+
+sub test_upgrade_master_key_integrity {
+ my ($modifier, $expected_version) = @_;
+ plan tests => $expected_version >= KDBX_VERSION_4_0 ? 6 : 5;
+
+ my $kdbx = File::KDBX->new;
+ $kdbx->kdf_parameters(fast_kdf);
+
+ is $kdbx->kdf->uuid, KDF_UUID_AES, 'Default KDF is AES';
+
+ {
+ local $_ = $kdbx;
+ $modifier->($kdbx);
+ }
+ is $kdbx->minimum_version, $expected_version,
+ sprintf('Got expected minimum version after modification: %x', $kdbx->minimum_version);
+
+ my $master_key = ['fffqcvq4rc', \'this is a keyfile', sub { 'chalresp 523rf2' }];
+ my $dump;
+ warnings { $kdbx->dump_string(\$dump, $master_key) };
+ ok $dump, 'Can dump the database' or diag explain $dump;
+
+ like exception { File::KDBX->load_string($dump, 'wrong key') },
+ qr/invalid credentials/i, 'Cannot load a KDBX with the wrong key';
+
+ # print STDERR "DUMP: [$dump]\n";
+
+ my $kdbx2 = File::KDBX->load_string($dump, $master_key);
+
+ is $kdbx2->version, $expected_version, sprintf('Got expected version: %x', $kdbx2->version);
+ isnt $kdbx2->kdf->uuid, KDF_UUID_AES, 'No unexpected KDF' if $kdbx2->version >= KDBX_VERSION_4_0;
+
+ # diag explain(File::KDBX->load_string($dump, $master_key, inner_format => 'Raw')->raw);
+}
+for my $test (
+ [KDBX_VERSION_3_1, 'nothing', sub {}],
+ [KDBX_VERSION_3_1, 'AES KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_AES)) }],
+ [KDBX_VERSION_4_0, 'Argon2D KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2D)) }],
+ [KDBX_VERSION_4_0, 'Argon2ID KDF', sub { $_->kdf_parameters(fast_kdf(KDF_UUID_ARGON2ID)) }],
+ [KDBX_VERSION_4_0, 'public custom data', sub { $_->public_custom_data->{foo} = 'bar' }],
+ [KDBX_VERSION_3_1, 'custom data', sub { $_->custom_data(foo => 'bar') }],
+ [KDBX_VERSION_4_0, 'root group custom data', sub { $_->root->custom_data(baz => 'qux') }],
+ [KDBX_VERSION_4_0, 'group custom data', sub { $_->add_group->custom_data(baz => 'qux') }],
+ [KDBX_VERSION_4_0, 'entry custom data', sub { $_->add_entry->custom_data(baz => 'qux') }],
+) {
+ my ($expected_version, $name, $modifier) = @$test;
+ subtest "Master key integrity: $name" => \&test_upgrade_master_key_integrity,
+ $modifier, $expected_version;
+}
+
+subtest 'Custom data' => sub {
+ my $kdbx = File::KDBX->new;
+ $kdbx->kdf_parameters(fast_kdf(KDF_UUID_AES));
+ $kdbx->version(KDBX_VERSION_4_0);
+
+ $kdbx->public_custom_data->{str} = '你好';
+ $kdbx->public_custom_data->{num} = 42;
+ $kdbx->public_custom_data->{bool} = true;
+ $kdbx->public_custom_data->{bytes} = "\1\2\3\4";
+
+ my $group = $kdbx->add_group(label => 'Group');
+ $group->custom_data(str => '你好');
+ $group->custom_data(num => 42);
+ $group->custom_data(bool => true);
+
+ my $entry = $kdbx->add_entry(label => 'Entry');
+ $entry->custom_data(str => '你好');
+ $entry->custom_data(num => 42);
+ $entry->custom_data(bool => false);
+
+ my $dump = $kdbx->dump_string('a');
+ my $kdbx2 = File::KDBX->load_string($dump, 'a');
+
+ is $kdbx2->public_custom_data->{str}, '你好', 'Store a string in public custom data';
+ cmp_ok $kdbx2->public_custom_data->{num}, '==', 42, 'Store a number in public custom data';
+ is $kdbx2->public_custom_data->{bool}, true, 'Store a boolean in public custom data';
+ ok isBoolean($kdbx2->public_custom_data->{bool}), 'Boolean is indeed a boolean';
+ is $kdbx2->public_custom_data->{bytes}, "\1\2\3\4", 'Store some bytes in public custom data';
+
+ my $group2 = $kdbx2->groups->grep(label => 'Group')->next;
+ is_deeply $group2->custom_data_value('str'), '你好', 'Store a string in group custom data';
+ is_deeply $group2->custom_data_value('num'), '42', 'Store a number in group custom data';
+ is_deeply $group2->custom_data_value('bool'), '1', 'Store a boolean in group custom data';
+
+ my $entry2 = $kdbx2->entries->grep(label => 'Entry')->next;
+ is_deeply $entry2->custom_data_value('str'), '你好', 'Store a string in entry custom data';
+ is_deeply $entry2->custom_data_value('num'), '42', 'Store a number in entry custom data';
+ is_deeply $entry2->custom_data_value('bool'), '0', 'Store a boolean in entry custom data';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+BEGIN { $ENV{PERL_FILE_KDBX_XS} = 0 }
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::KDF;
+
+use File::KDBX::Constants qw(:kdf);
+use Test::More;
+
+my $kdf = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10);
+
+ok !File::KDBX::XS->can('kdf_aes_transform_half'), 'XS can be avoided';
+
+my $r = $kdf->transform("\2" x 32);
+is $r, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222",
+ 'AES KDF works without XS';
+
+like exception { $kdf->transform("\2" x 33) }, qr/raw key must be 32 bytes/i,
+ 'Transformation requires valid arguments';
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Constants qw(:kdf);
+use File::KDBX::KDF;
+use Test::More;
+
+subtest 'AES KDF' => sub {
+ my $kdf1 = File::KDBX::KDF->new(uuid => KDF_UUID_AES, seed => "\1" x 32, rounds => 10);
+ my $result1 = $kdf1->transform("\2" x 32);
+ is $result1, "\342\234cp\375\\p\253]\213\f\246\345\230\266\260\r\222j\332Z\204:\322 p\224mhm\360\222",
+ 'AES KDF basically works';
+
+ like exception { $kdf1->transform("\2" x 33) }, qr/raw key must be 32 bytes/i,
+ 'Transformation requires valid arguments';
+};
+
+subtest 'Argon2 KDF' => sub {
+ my $kdf1 = File::KDBX::KDF->new(
+ uuid => KDF_UUID_ARGON2D,
+ salt => "\2" x 32,
+ iterations => 2,
+ parallelism => 2,
+ );
+ my $r1 = $kdf1->transform("\2" x 32);
+ is $r1, "\352\333\247\347+x#\"C\340\224\30\316\350\3068E\246\347H\263\214V\310\5\375\16N.K\320\255",
+ 'Argon2D KDF works';
+
+ my $kdf2 = File::KDBX::KDF->new(
+ uuid => KDF_UUID_ARGON2ID,
+ salt => "\2" x 32,
+ iterations => 2,
+ parallelism => 3,
+ );
+ my $r2 = $kdf2->transform("\2" x 32);
+ is $r2, "S\304\304u\316\311\202^\214JW{\312=\236\307P\345\253\323\313\23\215\247\210O!#F\16\1x",
+ 'Argon2ID KDF works';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Crypt::Misc 0.029 qw(decode_b64 encode_b64);
+use File::KDBX::Constants qw(:key_file);
+use File::KDBX::Key;
+use File::Temp qw(tempfile);
+use Test::More;
+
+subtest 'Primitives' => sub {
+ my $pkey = File::KDBX::Key->new('password');
+ isa_ok $pkey, 'File::KDBX::Key::Password';
+ is $pkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='),
+ 'Can calculate raw key from password' or diag encode_b64($pkey->raw_key);
+
+ my $fkey = File::KDBX::Key->new(\'password');
+ isa_ok $fkey, 'File::KDBX::Key::File';
+ is $fkey->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='),
+ 'Can calculate raw key from file' or diag encode_b64($fkey->raw_key);
+
+ my $ckey = File::KDBX::Key->new([
+ $pkey,
+ $fkey,
+ 'another password',
+ File::KDBX::Key::File->new(testfile(qw{keys hashed.key})),
+ ]);
+ isa_ok $ckey, 'File::KDBX::Key::Composite';
+ is $ckey->raw_key, decode_b64('FLV8/zOT9mEL8QKkzizq7mJflnb25ITblIPq608MGrk='),
+ 'Can calculate raw key from composite' or diag encode_b64($ckey->raw_key);
+};
+
+for my $test (
+ [KEY_FILE_TYPE_XML, 'xmlv1.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '1.0'],
+ [KEY_FILE_TYPE_XML, 'xmlv2.key', 'OF9tj+tfww1kHNWQaJlZWIlBdoTVXOazP8g/vZK7NcI=', '2.0'],
+ [KEY_FILE_TYPE_BINARY, 'binary.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='],
+ [KEY_FILE_TYPE_HEX, 'hex.key', 'QlkDxuYbDPDpDXdK1470EwVBL+AJBH2gvPA9lxNkFEk='],
+ [KEY_FILE_TYPE_HASHED, 'hashed.key', '8vAO4mrMeq6iCa1FHeWm/Mj5al8HIv2ajqsqsSeUC6U='],
+) {
+ my ($type) = @$test;
+ subtest "Load $type key file" => sub {
+ my ($type, $filename, $expected_key, $version) = @_;
+
+ my $key = File::KDBX::Key::File->new(testfile('keys', $filename));
+ is $key->raw_key, decode_b64($expected_key),
+ "Can calculate raw key from $type file" or diag encode_b64($key->raw_key);
+ is $key->type, $type, "File type is detected as $type";
+ is $key->version, $version, "File version is detected as $version" if defined $version;
+ }, @$test;
+
+ subtest "Save $type key file" => sub {
+ my ($type, $filename, $expected_key, $version) = @_;
+
+ my ($fh, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key');
+ note $filepath;
+ my $key = File::KDBX::Key::File->new(
+ filepath => $filepath,
+ type => $type,
+ version => $version,
+ raw_key => decode_b64($expected_key),
+ );
+
+ my $e = exception { $key->save };
+ close($fh);
+
+ if ($type == KEY_FILE_TYPE_HASHED) {
+ like $e, qr/invalid type/i, "Cannot save $type file";
+ return;
+ }
+ is $e, undef, "Save $type file";
+
+ my $key2 = File::KDBX::Key::File->new($filepath);
+ is $key2->type, $key->type, 'Loaded key file has the same type';
+ is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key';
+ }, @$test;
+}
+
+subtest 'IO handle key files' => sub {
+ my $buf = 'password';
+ open(my $fh, '<', \$buf) or die "open failed: $!\n";
+
+ my $key = File::KDBX::Key::File->new($fh);
+ is $key->raw_key, decode_b64('XohImNooBHFR0OVvjcYpJ3NgPQ1qq73WKhHvch0VQtg='),
+ 'Can calculate raw key from file handle' or diag encode_b64($key->raw_key);
+ is $key->type, 'hashed', 'file type is detected as hashed';
+
+ my ($fh_save, $filepath) = tempfile('keyfile-XXXXXX', TMPDIR => 1, UNLINK => 1, SUFFIX => '.key');
+ is exception { $key->save(fh => $fh_save, type => KEY_FILE_TYPE_XML) }, undef,
+ 'Save key file using IO handle';
+ close($fh_save);
+
+ my $key2 = File::KDBX::Key::File->new($filepath);
+ is $key2->type, KEY_FILE_TYPE_XML, 'Loaded key file has the same type';
+ is $key2->filepath, $filepath, 'Loaded key remembers the filepath';
+ is $key2->raw_key, $key->raw_key, 'Loaded key file has the same raw key';
+ $key2->reload;
+ is $key2->raw_key, $key->raw_key, 'Raw key is the same when reloaded same file';
+
+ my $easy_raw_key = "\1" x 32;
+ $key->init(\$easy_raw_key);
+ $key->save(filepath => $filepath);
+
+ $key2->reload;
+ is $key2->raw_key, "\1" x 32, 'Raw key is changed after reload';
+};
+
+subtest 'Key file error handling' => sub {
+ is exception { File::KDBX::Key::File->new }, undef, 'Cannot instantiate uninitialized';
+
+ like exception { File::KDBX::Key::File->init },
+ qr/^Missing key primitive/, 'Throw if no primitive is provided';
+
+ like exception { File::KDBX::Key::File->new(testfile(qw{keys nonexistent})) },
+ qr/^Failed to open key file/, 'Throw if file is missing';
+
+ like exception { File::KDBX::Key::File->new({}) },
+ qr/^Unexpected primitive type/, 'Throw if primitive is the wrong type';
+};
+
+done_testing;
--- /dev/null
+package TestCommon;
+
+use warnings;
+use strict;
+
+use Data::Dumper;
+use File::KDBX::Constants qw(:magic :kdf);
+use File::KDBX::Util qw(can_fork dumper);
+use File::Spec;
+use FindBin qw($Bin);
+use Test::Fatal;
+use Test::Deep;
+
+BEGIN {
+ $Data::Dumper::Deepcopy = 1;
+ $Data::Dumper::Deparse = 1;
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Quotekeys = 0;
+ $Data::Dumper::Sortkeys = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Trailingcomma = 1;
+ $Data::Dumper::Useqq = 1;
+}
+
+sub import {
+ my $self = shift;
+ my @args = @_;
+
+ my $caller = caller;
+
+ require Test::Warnings;
+ my @warnings_flags;
+ push @warnings_flags, ':no_end_test' if !$ENV{AUTHOR_TESTING} || grep { $_ eq ':no_warnings_test' } @args;
+ Test::Warnings->import(@warnings_flags);
+
+ # Just export a random assortment of things useful for testing.
+ no strict 'refs';
+ *{"${caller}::dumper"} = \&File::KDBX::Util::dumper;
+
+ *{"${caller}::exception"} = \&Test::Fatal::exception;
+ *{"${caller}::warning"} = \&Test::Warnings::warning;
+ *{"${caller}::warnings"} = \&Test::Warnings::warnings;
+
+ *{"${caller}::dump_test_deep_template"} = \&dump_test_deep_template;
+ *{"${caller}::ok_magic"} = \&ok_magic;
+ *{"${caller}::fast_kdf"} = \&fast_kdf;
+ *{"${caller}::can_fork"} = \&can_fork;
+ *{"${caller}::testfile"} = \&testfile;
+}
+
+sub testfile {
+ return File::Spec->catfile($Bin, 'files', @_);
+}
+
+sub dump_test_deep_template {
+ my $struct = shift;
+
+ my $str = Dumper $struct;
+ # booleans: bless( do{\(my $o = 1)}, 'boolean' )
+ $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/bool($1)/gs;
+ # objects
+ $str =~ s/bless\(.+?'([^']+)' \)/obj_isa('$1')/gs;
+ # convert two to four space indentation
+ $str =~ s/^( +)/' ' x (length($1) * 2)/gme;
+
+ open(my $fh, '>>', 'TEST-DEEP-TEMPLATES.pl') or die "open failed: $!";
+ print $fh $str, "\n";
+}
+
+sub ok_magic {
+ my $kdbx = shift;
+ my $vers = shift;
+ my $note = shift;
+
+ my $magic = [$kdbx->sig1, $kdbx->sig2, $kdbx->version];
+ cmp_deeply $magic, [
+ KDBX_SIG1,
+ KDBX_SIG2_2,
+ $vers,
+ ], $note // 'KDBX magic numbers are correct';
+}
+
+sub fast_kdf {
+ my $uuid = shift // KDF_UUID_AES;
+ my $params = {
+ KDF_PARAM_UUID() => $uuid,
+ };
+ if ($uuid eq KDF_UUID_AES || $uuid eq KDF_UUID_AES_CHALLENGE_RESPONSE) {
+ $params->{+KDF_PARAM_AES_ROUNDS} = 17;
+ $params->{+KDF_PARAM_AES_SEED} = "\1" x 32;
+ }
+ else { # Argon2
+ $params->{+KDF_PARAM_ARGON2_SALT} = "\1" x 32;
+ $params->{+KDF_PARAM_ARGON2_PARALLELISM} = 1;
+ $params->{+KDF_PARAM_ARGON2_MEMORY} = 1 << 13;
+ $params->{+KDF_PARAM_ARGON2_ITERATIONS} = 2;
+ $params->{+KDF_PARAM_ARGON2_VERSION} = 0x13;
+ }
+ return $params;
+}
+1;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Crypt::Digest qw(digest_data);
+use Crypt::PRNG qw(random_bytes);
+use Crypt::Misc qw(decode_b64);
+use File::KDBX::Key;
+use File::KDBX::Util qw(:erase :load);
+use File::KDBX;
+use IO::Handle;
+use List::Util qw(max);
+use POSIX ();
+use Scalar::Util qw(looks_like_number);
+use Scope::Guard;
+use Test::More;
+
+BEGIN {
+ if (!$ENV{AUTHOR_TESTING}) {
+ plan skip_all => 'AUTHOR_TESTING required to test memory protection';
+ exit;
+ }
+ if (!can_fork || !try_load_optional('POSIX::1003')) {
+ plan skip_all => 'fork and POSIX::1003 required to test memory protection';
+ exit;
+ }
+ POSIX::1003->import(':rlimit');
+}
+
+my $BLOCK_SIZE = 8196;
+
+-e 'core' && die "Remove or move the core dump!\n";
+my $cleanup = Scope::Guard->new(sub { unlink('core') });
+
+my ($cur, $max, $success) = getrlimit('RLIMIT_CORE');
+$success or die "getrlimit failed: $!\n";
+if ($cur < 1<<16) {
+ setrlimit('RLIMIT_CORE', RLIM_INFINITY, RLIM_INFINITY) or die "setrlimit failed: $!\n";
+}
+
+my $SECRET = 'c3VwZXJjYWxpZnJhZ2lsaXN0aWM=';
+my $SECRET_SHA256 = 'y1cOWidI80n5EZQx24NrOiP9tlca/uNMBDLYciDyQxs=';
+
+for my $test (
+ {
+ test => 'secret in scope',
+ run => sub {
+ my $secret = decode_b64($SECRET);
+ dump_core();
+ },
+ strings => [
+ $SECRET => 1,
+ ],
+ },
+ {
+ test => 'erased secret',
+ run => sub {
+ my $secret = decode_b64($SECRET);
+ erase $secret;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ ],
+ },
+ {
+ test => 'Key password',
+ run => sub {
+ my $password = decode_b64($SECRET);
+ my $key = File::KDBX::Key->new($password);
+ erase $password;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ ],
+ },
+ {
+ test => 'Key password, raw key shown',
+ run => sub {
+ my $password = decode_b64($SECRET);
+ my $key = File::KDBX::Key->new($password);
+ erase $password;
+ $key->show;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ $SECRET_SHA256 => 1,
+ ],
+ },
+ {
+ test => 'Key password, raw key hidden',
+ run => sub {
+ my $password = decode_b64($SECRET);
+ my $key = File::KDBX::Key->new($password);
+ erase $password;
+ $key->show->hide for 0..500;
+ dump_core();
+ },
+ strings => [
+ $SECRET => 0,
+ $SECRET_SHA256 => 0,
+ ],
+ },
+ {
+ test => 'protected strings and keys',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ dump_core();
+ },
+ strings => [
+ 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password
+ 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0,
+ # Secret A:
+ 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B
+ 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
+ 'SlHA3Eyhomr/UQ6vznWMRZtxlrqIm/tM3qVZv7G31DU=' => 0, # Final key
+ 'LuVqNfGluvLPcg2W699/Q6WGxIztX7Jvw0ONwQEi/Jc=' => 0, # Transformed key
+ # HMAC key:
+ 'kDEMVEcGR32UXTwG8j3SxsfdF+l124Ni6iHeogCWGd2z0KSG5PosDTloxC0zg7Ucn2CNR6f2wpgzcVGKmDNFCA==' => 0,
+ # Inner random stream key:
+ 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => 1,
+ 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 1, # Random stream key (actual)
+ ],
+ },
+ {
+ test => 'inner random stream key replaced',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ $kdbx->inner_random_stream_key("\1" x 64);
+ dump_core();
+ },
+ strings => [
+ # Inner random stream key:
+ # FIXME - there is second copy of this key somewhere... in another SvPV?
+ 'SwJSukmQdZKpHm8PywqLu1EHfUzS/gyJsg61Cm74YeRJeOpDlFblbVd5d4p+lU2/7Q28Vk4j/E2RRMC81DXdUw==' => undef,
+ ],
+ },
+ {
+ test => 'protected strings revealed',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ $kdbx->unlock;
+ dump_core();
+ },
+ strings => [
+ 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 1, # Password
+ # Secret A:
+ 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 1,
+ 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 1, # Secret B
+ 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
+ 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual)
+ ],
+ },
+ {
+ test => 'protected strings previously-revealed',
+ run => sub {
+ my $kdbx = File::KDBX->load(testfile('MemoryProtection.kdbx'), 'masterpw');
+ $kdbx->unlock;
+ $kdbx->lock;
+ dump_core();
+ },
+ strings => [
+ 'TXkgcGFzc3dvcmQgaXMgYSBzZWNyZXQgdG8gZXZlcnlvbmUu' => 0, # Password
+ # Secret A:
+ 'QSB0cmVhc3VyZSBtYXAgaXMgb24gdGhlIGJhY2sgb2YgdGhlIERlY2xhcmF0aW9uIG9mIEluZGVwZW5kZW5jZS4=' => 0,
+ 'SmVmZnJleSBFcHN0ZWluIGRpZG4ndCBraWxsIGhpbXNlbGYu' => 0, # Secret B
+ 'c3VwZXJjYWxpZnJhZ2lsaXN0aWNleHBpYWxpZG9jaW91cw==' => 1, # Nonsecret
+ 'RREzJd4fKHtFkjRIi+xucGPW2q+mov+LRWL4RkPql7Y=' => 0, # Random stream key (actual)
+ ],
+ },
+) {
+ my ($description, $run, $strings) = @$test{qw(test run strings)};
+
+ subtest "Dump core with $description" => sub {
+ my @strings = @_;
+ my $num_strings = @strings / 2;
+ plan tests => 2 + $num_strings * 2;
+
+ my (@encoded_strings, @expected);
+ while (@strings) {
+ my ($string, $expected) = splice @strings, 0, 2;
+ push @encoded_strings, $string;
+ push @expected, $expected;
+ }
+
+ my ($dumped, $has_core, @matches) = run_test($run, @encoded_strings);
+
+ ok $dumped, 'Test process signaled that it core-dumped';
+ ok $has_core, 'Found core dump' or return;
+
+ note sprintf('core dump is %.1f MiB', (-s 'core')/1048576);
+
+ for (my $i = 1; $i <= $num_strings; ++$i) {
+ my $count = $matches[$i - 1];
+ my $string = $encoded_strings[$i - 1];
+ my $expected = $expected[$i - 1];
+
+ ok defined $count, "[#$i] Got result from test environment";
+
+ TODO: {
+ local $TODO = 'Unprotected memory!' if !defined $expected;
+ if ($expected) {
+ ok 0 < $count, "[#$i] String FOUND"
+ or diag "Found $count copies of string #$i\nString: $string";
+ }
+ else {
+ is $count, 0, "[#$i] String MISSING"
+ or diag "Found $count copies of string #$i\nString: $string";
+ }
+ }
+ }
+ }, @$strings;
+}
+
+done_testing;
+exit;
+
+##############################################################################
+
+sub dump_core { kill 'QUIT', $$ }
+
+sub file_grep {
+ my $filepath = shift;
+ my @strings = @_;
+
+ my $counter = 0;
+ my %counts = map { $_ => $counter++ } @strings;
+ my @counts = map { 0 } @strings;
+
+ my $pattern = join('|', map { quotemeta($_) } @strings);
+
+ my $overlap = (max map { length } @strings) - 1;
+
+ open(my $fh, '<:raw', $filepath) or die "open failed: $!\n";
+
+ my $previous;
+ while (read $fh, my $block, $BLOCK_SIZE) {
+ substr($block, 0, 0, substr($previous, -$overlap)) if defined $previous;
+
+ while ($block =~ /($pattern)/gs) {
+ ++$counts[$counts{$1}];
+ }
+ $previous = substr($block, $overlap);
+ }
+ die "read error: $!" if $fh->error;
+
+ return @counts;
+}
+
+sub run_test {
+ my $code = shift;
+ my @strings = @_;
+
+ my $seed = random_bytes(32);
+
+ pipe(my $read, my $write) or die "pipe failed: $!\n";
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if (!$pid) { # child
+ close($read);
+
+ my $exit_status = run_doomed_child($code, $seed);
+ my $dumped = $exit_status & 127 && $exit_status & 128;
+
+ my @decoded_strings = map { decode_b64($_) } @strings;
+
+ my @matches = file_grep('core', @decoded_strings);
+ print $write join('|', $dumped, -f 'core' ? 1 : 0, @matches);
+ close($write);
+
+ POSIX::_exit(0);
+ }
+
+ close($write);
+ my $results = do { local $/; <$read> };
+
+ waitpid($pid, 0);
+ my $exit_status = $? >> 8;
+ $exit_status == 0 or die "test environment exited non-zero: $exit_status\n";
+
+ return split(/\|/, $results);
+}
+
+sub run_doomed_child {
+ my $code = shift;
+ my $seed = shift;
+
+ unlink('core') or die "unlink failed: $!\n" if -f 'core';
+
+ defined(my $pid = fork) or die "fork failed: $!\n";
+ if (!$pid) { # child
+ $code->();
+ dump_core(); # doomed
+ POSIX::_exit(1); # paranoid
+ }
+
+ waitpid($pid, 0);
+ return $?;
+}
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use File::KDBX::Util qw(:uuid);
+use File::KDBX;
+use Test::Deep;
+use Test::More;
+
+subtest 'Cloning' => sub {
+ my $kdbx = File::KDBX->new;
+ my $entry = File::KDBX::Entry->new;
+
+ my $copy = $entry->clone;
+ like exception { $copy->kdbx }, qr/disconnected/, 'Disconnected entry copy is also disconnectedisconnected';
+ cmp_deeply $copy, $entry, 'Disconnected entry and its clone are identical';
+
+ $entry->kdbx($kdbx);
+ $copy = $entry->clone;
+ is $entry->kdbx, $copy->kdbx, 'Connected entry copy is also connected';
+ cmp_deeply $copy, $entry, 'Connected entry and its clone are identical';
+
+ my $txn = $entry->begin_work;
+ $entry->title('foo');
+ $entry->username('bar');
+ $entry->password('baz');
+ $txn->commit;
+
+ $copy = $entry->clone;
+ is @{$copy->history}, 1, 'Copy has a historical entry' or dumper $copy->history;
+ cmp_deeply $copy, $entry, 'Entry with history and its clone are identical';
+
+ $copy = $entry->clone(history => 0);
+ is @{$copy->history}, 0, 'Copy excluding history has no history';
+
+ $copy = $entry->clone(new_uuid => 1);
+ isnt $copy->uuid, $entry->uuid, 'Entry copy with new UUID has a different UUID';
+
+ $copy = $entry->clone(reference_username => 1);
+ my $ref = sprintf('{REF:U@I:%s}', format_uuid($entry->uuid));
+ is $copy->username, $ref, 'Copy has username reference';
+ is $copy->expand_username, $ref, 'Entry copy does not expand username because entry is not in database';
+
+ my $group = $kdbx->add_group(label => 'Passwords');
+ $group->add_entry($entry);
+ is $copy->expand_username, $entry->username,
+ 'Entry in database and its copy with username ref have same expanded username';
+
+ $copy = $entry->clone;
+ is $kdbx->entries->size, 1, 'Still only one entry after cloning';
+
+ $copy = $entry->clone(parent => 1);
+ is $kdbx->entries->size, 2, 'New copy added to database if clone with parent option';
+ my ($e1, $e2) = $kdbx->entries->each;
+ isnt $e1, $e2, 'Entry and its copy in the database are different objects';
+ is $e1->title, $e2->title, 'Entry copy has the same title as the original entry';
+
+ $copy = $entry->clone(parent => 1, relabel => 1);
+ is $kdbx->entries->size, 3, 'New copy added to database if clone with parent option';
+ my $e3 = $kdbx->entries->skip(2)->next;
+ is $e3, $copy, 'New copy and new entry in the database match';
+ is $e3->title, 'foo - Copy', 'New copy has a modified title';
+
+ $copy = $group->clone;
+ cmp_deeply $copy, $group, 'Group and its clone are identical';
+ is @{$copy->entries}, 3, 'Group copy has as many entries as the original';
+ is @{$copy->entries->[0]->history}, 1, 'Entry in group copy has history';
+
+ $copy = $group->clone(history => 0);
+ is @{$copy->entries}, 3, 'Group copy without history has as many entries as the original';
+ is @{$copy->entries->[0]->history}, 0, 'Entry in group copy has no history';
+
+ $copy = $group->clone(entries => 0);
+ is @{$copy->entries}, 0, 'Group copy without entries has no entries';
+ is $copy->name, 'Passwords', 'Group copy label is the same as the original';
+
+ $copy = $group->clone(relabel => 1);
+ is $copy->name, 'Passwords - Copy', 'Group copy relabeled from the original title';
+ is $kdbx->entries->size, 3, 'No new entries were added to the database';
+
+ $copy = $group->clone(relabel => 1, parent => 1);
+ is $kdbx->entries->size, 6, 'Copy a group within parent doubles the number of entries in the database';
+ isnt $group->entries->[0]->uuid, $copy->entries->[0]->uuid,
+ 'First entry in group and its copy are different';
+};
+
+subtest 'Transactions' => sub {
+ my $kdbx = File::KDBX->new;
+
+ my $root = $kdbx->root;
+ my $entry = $kdbx->add_entry(
+ label => 'One',
+ last_modification_time => Time::Piece->strptime('2022-04-20', '%Y-%m-%d'),
+ username => 'Fred',
+ );
+
+ my $txn = $root->begin_work;
+ $root->label('Toor');
+ $root->notes('');
+ $txn->commit;
+ is $root->label, 'Toor', 'Retain change to root label after commit';
+
+ $root->begin_work;
+ $root->label('Root');
+ $entry->label('Zap');
+ $root->rollback;
+ is $root->label, 'Toor', 'Undo change to root label after rollback';
+ is $entry->label, 'Zap', 'Retain change to entry after rollback';
+
+ $txn = $root->begin_work(entries => 1);
+ $root->label('Root');
+ $entry->label('Zippy');
+ undef $txn; # implicit rollback
+ is $root->label, 'Toor', 'Undo change to root label after implicit rollback';
+ is $entry->label, 'Zap', 'Undo change to entry after rollback with deep transaction';
+
+ $txn = $entry->begin_work;
+ my $mtime = $entry->last_modification_time;
+ my $username = $entry->string('UserName');
+ $username->{meh} = 'hi';
+ $entry->username('jinx');
+ $txn->rollback;
+ is $entry->string('UserName'), $username, 'Rollback keeps original references';
+ is $entry->last_modification_time, $mtime, 'No last modification time change after rollback';
+
+ $txn = $entry->begin_work;
+ $entry->username('jinx');
+ $txn->commit;
+ isnt $entry->last_modification_time, $mtime, 'Last modification time changes after commit';
+
+ {
+ my $txn1 = $root->begin_work;
+ $root->label('alien');
+ {
+ my $txn2 = $root->begin_work;
+ $root->label('truth');
+ $txn2->commit;
+ }
+ }
+ is $root->label, 'Toor', 'Changes thrown away after rolling back outer transaction';
+
+ {
+ my $txn1 = $root->begin_work;
+ $root->label('alien');
+ {
+ my $txn2 = $root->begin_work;
+ $root->label('truth');
+ }
+ $txn1->commit;
+ }
+ is $root->label, 'alien', 'Keep committed change after rolling back inner transaction';
+
+ {
+ my $txn1 = $root->begin_work;
+ $root->label('alien');
+ {
+ my $txn2 = $root->begin_work;
+ $root->label('truth');
+ $txn2->commit;
+ }
+ $txn1->commit;
+ }
+ is $root->label, 'truth', 'Keep committed change from inner transaction';
+
+ $txn = $root->begin_work;
+ $root->label('Lalala');
+ my $dump = $kdbx->dump_string('a');
+ $txn->commit;
+ is $root->label, 'Lalala', 'Keep committed label change after dump';
+ my $load = File::KDBX->load_string($dump, 'a');
+ is $load->root->label, 'truth', 'Object dumped before committing matches the pre-transaction state';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use Test::More;
+
+eval { require Pass::OTP } or plan skip_all => 'Pass::OTP required to test one-time-passwords';
+
+my $secret_txt = 'hello';
+my $secret_b32 = 'NBSWY3DP';
+my $secret_b64 = 'aGVsbG8=';
+my $secret_hex = '68656c6c6f';
+my $when = 1655488780;
+
+for my $test (
+ {
+ name => 'HOTP - Basic',
+ input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer"},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer',
+ },
+ {
+ name => 'HOTP - Start from 42',
+ input => {
+ otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer",
+ 'HmacOtp-Counter' => 42,
+ },
+ codes => [qw(528783 171971 115730)],
+ uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&counter=42',
+ },
+ {
+ name => 'HOTP - 7 digits',
+ input => {otp => "otpauth://hotp/Issuer:user?secret=${secret_b32}&issuer=Issuer&digits=7"},
+ codes => [qw(3029578 9825147 9676217)],
+ uri => 'otpauth://hotp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Base32)',
+ input => {'HmacOtp-Secret-Base32' => $secret_b32},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Base64)',
+ input => {'HmacOtp-Secret-Base64' => $secret_b64},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Hex)',
+ input => {'HmacOtp-Secret-Hex' => $secret_hex},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2 storage (Text)',
+ input => {'HmacOtp-Secret' => $secret_txt},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'HOTP - KeePass 2, start from 42',
+ input => {'HmacOtp-Secret' => $secret_txt, 'HmacOtp-Counter' => 42},
+ codes => [qw(528783 171971 115730)],
+ uri => 'otpauth://hotp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&counter=42',
+ },
+ {
+ name => 'HOTP - Non-default attributes',
+ input => {'HmacOtp-Secret' => $secret_txt, Title => 'Website', UserName => 'foo!?'},
+ codes => [qw(029578 825147 676217)],
+ uri => 'otpauth://hotp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website',
+ },
+) {
+ my $entry = File::KDBX::Entry->new;
+ $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}};
+ is $entry->hmac_otp_uri, $test->{uri}, "$test->{name}: Valid URI";
+ for my $code (@{$test->{codes}}) {
+ my $counter = $entry->string_value('HmacOtp-Counter') || 'undef';
+ is $entry->hmac_otp, $code, "$test->{name}: Valid OTP ($counter)";
+ }
+}
+
+for my $test (
+ {
+ name => 'TOTP - Basic',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=6&issuer=Issuer"},
+ code => '875357',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer',
+ },
+ {
+ name => 'TOTP - SHA256',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&algorithm=SHA256"},
+ code => '630489',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&algorithm=SHA256',
+ },
+ {
+ name => 'TOTP - 60s period',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=60&digits=6&issuer=Issuer"},
+ code => '647601',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&period=60',
+ },
+ {
+ name => 'TOTP - 7 digits',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&period=30&digits=7&issuer=Issuer"},
+ code => '9875357',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&digits=7',
+ },
+ {
+ name => 'TOTP - Steam',
+ input => {otp => "otpauth://totp/Issuer:user?secret=${secret_b32}&issuer=Issuer&encoder=steam"},
+ code => '55YH2',
+ uri => 'otpauth://totp/Issuer:user?secret=NBSWY3DP&issuer=Issuer&encoder=steam',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32},
+ code => '875357',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage, SHA256',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Algorithm' => 'HMAC-SHA-256'},
+ code => '630489',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&algorithm=SHA256',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage, 60s period',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Period' => '60'},
+ code => '647601',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&period=60',
+ },
+ {
+ name => 'TOTP - KeePass 2 storage, 7 digits',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, 'TimeOtp-Length' => '7'},
+ code => '9875357',
+ uri => 'otpauth://totp/KDBX:none?secret=NBSWY3DP&issuer=KDBX&digits=7',
+ },
+ {
+ name => 'TOTP - Non-default attributes',
+ input => {'TimeOtp-Secret-Base32' => $secret_b32, Title => 'Website', UserName => 'foo!?'},
+ code => '875357',
+ uri => 'otpauth://totp/Website:foo%21%3F?secret=NBSWY3DP&issuer=Website',
+ },
+) {
+ my $entry = File::KDBX::Entry->new;
+ $entry->string($_ => $test->{input}{$_}) for keys %{$test->{input}};
+ is $entry->time_otp_uri, $test->{uri}, "$test->{name}: Valid URI";
+ is $entry->time_otp(now => $when), $test->{code}, "$test->{name}: Valid OTP";
+}
+
+{
+ my $entry = File::KDBX::Entry->new;
+ $entry->string('TimeOtp-Secret-Base32' => $secret_b32);
+ $entry->string('TimeOtp-Secret' => 'wat');
+ my $warning = warning { $entry->time_otp_uri };
+ like $warning, qr/Found multiple/, 'Alert if redundant secrets'
+ or diag 'Warnings: ', explain $warning;
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Entry;
+use File::KDBX;
+use Test::More;
+
+my $kdbx = File::KDBX->new;
+
+my $entry1 = $kdbx->add_entry(
+ title => 'Foo',
+ username => 'User {TITLE}',
+);
+my $entry2 = $kdbx->add_entry(
+ title => 'Bar',
+ username => sprintf('{REF:U@I:%s}', $entry1->id),
+ notes => 'notes {URL}',
+ url => 'url {NOTES}',
+);
+my $entry3 = $kdbx->add_entry(
+ username => sprintf('{REF:U@I:%s}', $entry2->id),
+ password => 'lyric:%LYRIC%',
+ notes => '%MISSING% %% %NOT AVAR% %LYRIC%',
+);
+
+is $entry1->expand_username, 'User Foo', 'Basic placeholder expansion';
+is $entry2->expand_username, 'User Foo', 'Reference to another entry';
+is $entry3->expand_username, 'User Foo', 'Reference to another entry through another';
+
+my $recursive_expected = 'url notes ' x 10 . 'url {NOTES}';
+my $recursive;
+my $warning = warning { $recursive = $entry2->expand_url };
+like $warning, qr/detected deep recursion/i, 'Deep recursion causes a warning'
+ or diag 'Warnings: ', explain $warning;
+is $recursive, $recursive_expected, 'Recursive placeholders resolve to... something';
+
+{
+ my $entry = File::KDBX::Entry->new(url => 'http://example.com?{EXPLODE}');
+ is $entry->expand_url, 'http://example.com?{EXPLODE}',
+ 'Unhandled placeholders are not replaced';
+
+ local $File::KDBX::PLACEHOLDERS{EXPLODE} = sub { 'boom' };
+ is $entry->expand_url, 'http://example.com?boom', 'Custom placeholders can be set';
+
+ $entry->url('{eXplOde}!!');
+ is $entry->expand_url, 'boom!!', 'Placeholder tags are match case-insensitively';
+}
+
+{
+ local $ENV{LYRIC} = 'I am the very model of a modern Major-General';
+ is $entry3->expand_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders';
+ is $entry3->expand_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}},
+ 'Do not replace things that look like environment variables but are not';
+}
+
+{
+ my $counter = 0;
+ local $File::KDBX::PLACEHOLDERS{'COUNTER'} = $File::KDBX::PLACEHOLDERS{'COUNTER:'} = sub {
+ (undef, my $arg) = @_;
+ return defined $arg ? $arg : ++$counter;
+ };
+ my $entry4 = $kdbx->add_entry(
+ url => '{COUNTER} {USERNAME}',
+ username => '{COUNTER}x{COUNTER}y{COUNTER:-1}',
+ );
+ like $entry4->expand_username, qr/^1x1y-1$/,
+ 'Each unique placeholder is evaluated once';
+ like $entry4->expand_url, qr/^2 3x3y-1$/,
+ 'Each unique placeholder is evaluated once per string';
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Util qw(query search simple_expression_query);
+use Test::Deep;
+use Test::More;
+
+my $list = [
+ {
+ id => 1,
+ name => 'Bob',
+ age => 34,
+ married => 1,
+ notes => 'Enjoys bowling on Thursdays',
+ },
+ {
+ id => 2,
+ name => 'Ken',
+ age => 17,
+ married => 0,
+ notes => 'Eats dessert first',
+ color => '',
+ },
+ {
+ id => 3,
+ name => 'Becky',
+ age => 25,
+ married => 1,
+ notes => 'Listens to rap music on repeat',
+ color => 'orange',
+ },
+ {
+ id => 4,
+ name => 'Bobby',
+ age => 5,
+ notes => 'Loves candy and running around like a crazy person',
+ color => 'blue',
+ },
+];
+
+subtest 'Declarative structure' => sub {
+ my $result = search($list, name => 'Bob');
+ cmp_deeply $result, [shallow($list->[0])], 'Find Bob'
+ or diag explain $result;
+
+ $result = search($list, name => 'Ken');
+ cmp_deeply $result, [$list->[1]], 'Find Ken'
+ or diag explain $result;
+
+ $result = search($list, age => 25);
+ cmp_deeply $result, [$list->[2]], 'Find Becky by age'
+ or diag explain $result;
+
+ $result = search($list, {name => 'Becky', age => 25});
+ cmp_deeply $result, [$list->[2]], 'Find Becky by name AND age'
+ or diag explain $result;
+
+ $result = search($list, {name => 'Becky', age => 99});
+ cmp_deeply $result, [], 'Miss Becky with wrong age'
+ or diag explain $result;
+
+ $result = search($list, [name => 'Becky', age => 17]);
+ cmp_deeply $result, [$list->[1], $list->[2]], 'Find Ken and Becky with different criteria'
+ or diag explain $result;
+
+ $result = search($list, name => 'Becky', age => 17);
+ cmp_deeply $result, [$list->[1], $list->[2]], 'Query list defaults to OR logic'
+ or diag explain $result;
+
+ $result = search($list, age => {'>=', 18});
+ cmp_deeply $result, [$list->[0], $list->[2]], 'Find adults'
+ or diag explain $result;
+
+ $result = search($list, name => {'=~', qr/^Bob/});
+ cmp_deeply $result, [$list->[0], $list->[3]], 'Find both Bobs'
+ or diag explain $result;
+
+ $result = search($list, -and => [name => 'Becky', age => 99]);
+ cmp_deeply $result, [], 'Specify AND logic explicitly'
+ or diag explain $result;
+
+ $result = search($list, {name => 'Becky', age => 99});
+ cmp_deeply $result, [], 'Specify AND logic implicitly'
+ or diag explain $result;
+
+ $result = search($list, '!' => 'married');
+ cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using normal operator)'
+ or diag explain $result;
+
+ $result = search($list, -false => 'married');
+ cmp_deeply $result, [$list->[1], $list->[3]], 'Find unmarried (using special operator)'
+ or diag explain $result;
+
+ $result = search($list, -true => 'married');
+ cmp_deeply $result, [$list->[0], $list->[2]], 'Find married persons (using special operator)'
+ or diag explain $result;
+
+ $result = search($list, -not => {name => {'=~', qr/^Bob/}});
+ cmp_deeply $result, [$list->[1], $list->[2]], 'What about Bob? Inverse a complex query'
+ or diag explain $result;
+
+ $result = search($list, -nonempty => 'color');
+ cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful'
+ or diag explain $result;
+
+ $result = search($list, color => {ne => undef});
+ cmp_deeply $result, [$list->[2], $list->[3]], 'Find the colorful (compare to undef)'
+ or diag explain $result;
+
+ $result = search($list, -empty => 'color');
+ cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color'
+ or diag explain $result;
+
+ $result = search($list, color => {eq => undef});
+ cmp_deeply $result, [$list->[0], $list->[1]], 'Find those without color (compare to undef)'
+ or diag explain $result;
+
+ $result = search($list, -defined => 'color');
+ cmp_deeply $result, [$list->[1], $list->[2], $list->[3]], 'Find defined colors'
+ or diag explain $result;
+
+ $result = search($list, -undef => 'color');
+ cmp_deeply $result, [$list->[0]], 'Find undefined colors'
+ or diag explain $result;
+
+ $result = search($list,
+ -and => [
+ name => {'=~', qr/^Bob/},
+ -and => {
+ name => {'ne', 'Bob'},
+ },
+ ],
+ -not => {'!' => 'Bobby'},
+ );
+ cmp_deeply $result, [$list->[3]], 'Complex query'
+ or diag explain $result;
+
+ my $query = query(name => 'Ken');
+ $result = search($list, $query);
+ cmp_deeply $result, [$list->[1]], 'Search using a pre-compiled query'
+ or diag explain $result;
+
+ my $custom_query = sub { shift->{name} eq 'Bobby' };
+ $result = search($list, $custom_query);
+ cmp_deeply $result, [$list->[3]], 'Search using a custom query subroutine'
+ or diag explain $result;
+};
+
+##############################################################################
+
+subtest 'Simple expressions' => sub {
+ my $simple_query = simple_expression_query('bob', qw{name notes});
+ my $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression'
+ or diag explain $result;
+
+ $result = search($list, \'bob', qw{name notes});
+ cmp_deeply $result, [$list->[0], $list->[3]], 'Basic one-term expression on search'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query(' Dessert ', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[1]], 'Whitespace is ignored'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('to music', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[2]], 'Multiple terms'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('"to music"', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [], 'One quoted term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('candy "CRAZY PERSON" ', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[3]], 'Multiple terms, one quoted term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query(" bob\tcandy\n\n", qw{name notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[3]], 'Multiple terms in different fields'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('music -repeat', qw{notes});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [], 'Multiple terms, one negative term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('-bob', qw{name});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[1], $list->[2]], 'Negative term'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('bob -bobby', qw{name});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[0]], 'Multiple mixed terms'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query(25, '==', qw{age});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[2]], 'Custom operator'
+ or diag explain $result;
+
+ $simple_query = simple_expression_query('-25', '==', qw{age});
+ $result = search($list, $simple_query);
+ cmp_deeply $result, [$list->[0], $list->[1], $list->[3]], 'Negative term, custom operator'
+ or diag explain $result;
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX;
+use Test::More;
+
+my $kdbx = File::KDBX->new;
+my $entry1 = $kdbx->add_entry(
+ title => 'Sun Valley Bank Inc.',
+ username => 'fred',
+ password => 'secr3t',
+);
+my $entry2 = $kdbx->add_entry(
+ title => 'Donut Shoppe',
+ username => 'freddy',
+ password => '1234',
+ testcustom => 'a custom string',
+);
+my $entry3 = $kdbx->add_entry(
+ title => 'Sun Clinic Inc.',
+ username => 'jerry',
+ password => 'password',
+ mycustom => 'this is another custom string',
+);
+
+for my $test (
+ ['{REF:U@T:donut}', 'freddy'],
+ ['U@T:donut', 'freddy'],
+ [[U => T => 'donut'], 'freddy', 'A reference can be pre-parsed parameters'],
+
+ ['{REF:U@T:sun inc}', 'fred'],
+ ['{REF:U@T:"Sun Clinic Inc."}', 'jerry'],
+
+ ['{REF:U@I:' . $entry2->id . '}', 'freddy', 'Resolve a field by UUID'],
+
+ ['{REF:U@O:custom}', 'freddy'],
+ ['{REF:U@O:"another custom"}', 'jerry'],
+
+ ['{REF:U@T:donut meh}', undef],
+ ['{REF:O@U:freddy}', undef],
+) {
+ my ($ref, $expected, $note) = @$test;
+ $note //= "Reference: $ref";
+ is $kdbx->resolve_reference(ref $ref eq 'ARRAY' ? @$ref : $ref), $expected, $note;
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use utf8;
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Safe;
+use Test::Deep;
+use Test::More;
+
+my $secret = 'secret';
+
+my @strings = (
+ {
+ value => 'classified',
+ },
+ {
+ value => 'bar',
+ meh => 'ignored',
+ },
+ {
+ value => '你好',
+ },
+);
+
+my $safe = File::KDBX::Safe->new([@strings, \$secret]);
+cmp_deeply \@strings, [
+ {
+ value => undef,
+ },
+ {
+ value => undef,
+ meh => 'ignored',
+ },
+ {
+ value => undef,
+ },
+], 'Encrypt strings in a safe' or diag explain \@strings;
+is $secret, undef, 'Scalar was set to undef';
+
+my $val = $safe->peek($strings[1]);
+is $val, 'bar', 'Peek at a string';
+
+$safe->unlock;
+cmp_deeply \@strings, [
+ {
+ value => 'classified',
+ },
+ {
+ value => 'bar',
+ meh => 'ignored',
+ },
+ {
+ value => '你好',
+ },
+], 'Decrypt strings in a safe' or diag explain \@strings;
+is $secret, 'secret', 'Scalar was set back to secret';
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use File::KDBX::Util qw(:all);
+use Test::More;
+
+can_ok('File::KDBX::Util', qw{
+ assert_64bit
+ can_fork
+ dumper
+ empty
+ erase
+ erase_scoped
+ format_uuid
+ generate_uuid
+ gunzip
+ gzip
+ load_optional
+ nonempty
+ pad_pkcs7
+ query
+ search
+ simple_expression_query
+ snakify
+ split_url
+ trim
+ uri_escape_utf8
+ uri_unescape_utf8
+ uuid
+});
+
+subtest 'Emptiness' => sub {
+ my @empty;
+ my @nonempty = 0;
+ ok empty(@empty), 'Empty array should be empty';
+ ok !nonempty(@empty), 'Empty array should be !nonempty';
+ ok !empty(@nonempty), 'Array should be !empty';
+ ok nonempty(@nonempty), 'Array should be nonempty';
+
+ my %empty;
+ my %nonempty = (a => 'b');
+ ok empty(%empty), 'Empty hash should be empty';
+ ok !nonempty(%empty), 'Empty hash should be !nonempty';
+ ok !empty(%nonempty), 'Hash should be !empty';
+ ok nonempty(%nonempty), 'Hash should be nonempty';
+
+ my $empty = '';
+ my $nonempty = '0';
+ my $eref1 = \$empty;
+ my $eref2 = \$eref1;
+ my $nref1 = \$nonempty;
+ my $nref2 = \$nref1;
+
+ for my $test (
+ [0, $empty, 'Empty string'],
+ [0, undef, 'Undef'],
+ [0, \undef, 'Reference to undef'],
+ [0, {}, 'Empty hashref'],
+ [0, [], 'Empty arrayref'],
+ [0, $eref1, 'Reference to empty string'],
+ [0, $eref2, 'Reference to reference to empty string'],
+ [0, \\\\\\\'', 'Deep reference to empty string'],
+ [1, $nonempty, 'String'],
+ [1, 'hi', 'String'],
+ [1, 1, 'Number'],
+ [1, 0, 'Zero'],
+ [1, {a => 'b'}, 'Hashref'],
+ [1, [0], 'Arrayref'],
+ [1, $nref1, 'Reference to string'],
+ [1, $nref2, 'Reference to reference to string'],
+ [1, \\\\\\\'z', 'Deep reference to string'],
+ ) {
+ my ($expected, $thing, $note) = @$test;
+ if ($expected) {
+ ok !empty($thing), "$note should be !empty";
+ ok nonempty($thing), "$note should be nonempty";
+ }
+ else {
+ ok empty($thing), "$note should be empty";
+ ok !nonempty($thing), "$note should be !nonempty";
+ }
+ }
+};
+
+subtest 'UUIDs' => sub {
+ my $uuid = "\x01\x23\x45\x67\x89\xab\xcd\xef\x01\x23\x45\x67\x89\xab\xcd\xef";
+ my $uuid1 = uuid('01234567-89AB-CDEF-0123-456789ABCDEF');
+ my $uuid2 = uuid('0123456789ABCDEF0123456789ABCDEF');
+ my $uuid3 = uuid('012-3-4-56-789AB-CDEF---012-34567-89ABC-DEF');
+
+ is $uuid1, $uuid, 'Formatted UUID is packed';
+ is $uuid2, $uuid, 'Formatted UUID does not need dashes';
+ is $uuid2, $uuid, 'Formatted UUID can have weird dashes';
+
+ is format_uuid($uuid), '0123456789ABCDEF0123456789ABCDEF', 'UUID unpacks to hex string';
+ is format_uuid($uuid, '-'), '01234567-89AB-CDEF-0123-456789ABCDEF', 'Formatted UUID can be delimited';
+
+ my %uuid_set = ($uuid => 'whatever');
+
+ my $new_uuid = generate_uuid(\%uuid_set);
+ isnt $new_uuid, $uuid, 'Generated UUID is not in set';
+
+ $new_uuid = generate_uuid(sub { !$uuid_set{$_} });
+ isnt $new_uuid, $uuid, 'Generated UUID passes a test function';
+
+ like generate_uuid(print => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (1)';
+ like generate_uuid(printable => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (2)';
+};
+
+subtest 'Snakification' => sub {
+ is snakify('FooBar'), 'foo_bar', 'Basic snakification';
+ is snakify('MyUUIDSet'), 'my_uuid_set', 'Acronym snakification';
+ is snakify('Numbers123'), 'numbers_123', 'Snake case with numbers';
+ is snakify('456Baz'), '456_baz', 'Prefixed numbers';
+};
+
+subtest 'Padding' => sub {
+ plan tests => 8;
+
+ is pad_pkcs7('foo', 2), "foo\x01", 'Pad one byte to fill the second block';
+ is pad_pkcs7('foo', 4), "foo\x01", 'Pad one byte to fill one block';
+ is pad_pkcs7('foo', 8), "foo\x05\x05\x05\x05\x05", 'Pad to fill one block';
+ is pad_pkcs7('moof', 4), "moof\x04\x04\x04\x04", 'Add a whole block of padding';
+ is pad_pkcs7('', 3), "\x03\x03\x03", 'Pad an empty string';
+ like exception { pad_pkcs7(undef, 8) }, qr/must provide a string/i, 'String must be defined';
+ like exception { pad_pkcs7('bar') }, qr/must provide block size/i, 'Size must defined';
+ like exception { pad_pkcs7('bar', 0) }, qr/must provide block size/i, 'Size must be non-zero';
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use lib 't/lib';
+use TestCommon;
+
+use Config;
+use File::KDBX::Key::YubiKey;
+use Test::More;
+
+$^O eq 'MSWin32' and plan skip_all => 'Non-Windows required to test YubiKeys';
+
+@ENV{qw(YKCHALRESP YKCHALRESP_FLAGS)} = ($Config{perlpath}, testfile(qw{bin ykchalresp}));
+@ENV{qw(YKINFO YKINFO_FLAGS)} = ($Config{perlpath}, testfile(qw{bin ykinfo}));
+
+{
+ my ($pre, $post);
+ my $key = File::KDBX::Key::YubiKey->new(
+ pre_challenge => sub { ++$pre },
+ post_challenge => sub { ++$post },
+ );
+ my $resp;
+ is exception { $resp = $key->challenge('foo') }, undef, 'Do not throw during non-blocking response';
+ is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a non-blocking challenge response';
+ is length($resp), 20, 'Response is the proper length';
+ is $pre, 1, 'The pre-challenge callback is called';
+ is $post, 1, 'The post-challenge callback is called';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new;
+ local $ENV{YKCHALRESP_MOCK} = 'error';
+ like exception { $key->challenge('foo') }, qr/Yubikey core error:/i,
+ 'Throw if challenge-response program errored out';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new;
+ local $ENV{YKCHALRESP_MOCK} = 'usberror';
+ like exception { $key->challenge('foo') }, qr/USB error:/i,
+ 'Throw if challenge-response program had a USB error';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new(timeout => 0, device => 3, slot => 2);
+ local $ENV{YKCHALRESP_MOCK} = 'block';
+
+ like exception { $key->challenge('foo') }, qr/operation would block/i,
+ 'Throw if challenge would block but we do not want to wait';
+
+ $key->timeout(1);
+ like exception { $key->challenge('foo') }, qr/timed out/i,
+ 'Timeout while waiting for response';
+
+ $key->timeout(-1);
+ my $resp;
+ is exception { $resp = $key->challenge('foo') }, undef,
+ 'Do not throw during blocking response';
+ is $resp, "\xf0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0", 'Get a blocking challenge response';
+}
+
+{
+ my $key = File::KDBX::Key::YubiKey->new(device => 0, slot => 1);
+ is $key->name, 'YubiKey NEO FIDO v2.0.0 [123] (slot #1)',
+ 'Get name for a new, unscanned key';
+ is $key->serial, 123, 'Get the serial number of the new key';
+}
+
+{
+ my ($key, @other) = File::KDBX::Key::YubiKey->scan;
+ is $key->name, 'YubiKey 4/5 OTP v3.0.1 [456] (slot #2)',
+ 'Find expected YubiKey';
+ is $key->serial, 456, 'Get the serial number of the scanned key';
+ is scalar @other, 0, 'Do not find any other YubiKeys';
+}
+
+{
+ local $ENV{YKCHALRESP} = testfile(qw{bin nonexistent});
+ local $ENV{YKCHALRESP_FLAGS} = undef;
+ my $key = File::KDBX::Key::YubiKey->new;
+ like exception { $key->challenge('foo') }, qr/failed to run|failed to receive challenge response/i,
+ 'Throw if the program failed to run';
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::CleanNamespaces 0.006
+
+use Test::More 0.94;
+use Test::CleanNamespaces 0.15;
+
+subtest all_namespaces_clean => sub {
+ namespaces_clean(
+ grep { my $mod = $_; not grep { $mod =~ $_ } qr/::Util|::KDF::AES$/ }
+ Test::CleanNamespaces->find_modules
+ );
+};
+
+done_testing;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc";
+all_critic_ok();
--- /dev/null
+#!perl
+# This file was automatically generated by Dist::Zilla::Plugin::MetaTests.
+
+use Test::CPAN::Meta;
+
+meta_yaml_ok();
--- /dev/null
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::EOL 0.19
+
+use Test::More 0.88;
+use Test::EOL;
+
+my @files = (
+ 'lib/File/KDBX.pm',
+ 'lib/File/KDBX/Cipher.pm',
+ 'lib/File/KDBX/Cipher/CBC.pm',
+ 'lib/File/KDBX/Cipher/Stream.pm',
+ 'lib/File/KDBX/Constants.pm',
+ 'lib/File/KDBX/Dumper.pm',
+ 'lib/File/KDBX/Dumper/KDB.pm',
+ 'lib/File/KDBX/Dumper/Raw.pm',
+ 'lib/File/KDBX/Dumper/V3.pm',
+ 'lib/File/KDBX/Dumper/V4.pm',
+ 'lib/File/KDBX/Dumper/XML.pm',
+ 'lib/File/KDBX/Entry.pm',
+ 'lib/File/KDBX/Error.pm',
+ 'lib/File/KDBX/Group.pm',
+ 'lib/File/KDBX/IO.pm',
+ 'lib/File/KDBX/IO/Crypt.pm',
+ 'lib/File/KDBX/IO/HashBlock.pm',
+ 'lib/File/KDBX/IO/HmacBlock.pm',
+ 'lib/File/KDBX/Iterator.pm',
+ 'lib/File/KDBX/KDF.pm',
+ 'lib/File/KDBX/KDF/AES.pm',
+ 'lib/File/KDBX/KDF/Argon2.pm',
+ 'lib/File/KDBX/Key.pm',
+ 'lib/File/KDBX/Key/ChallengeResponse.pm',
+ 'lib/File/KDBX/Key/Composite.pm',
+ 'lib/File/KDBX/Key/File.pm',
+ 'lib/File/KDBX/Key/Password.pm',
+ 'lib/File/KDBX/Key/YubiKey.pm',
+ 'lib/File/KDBX/Loader.pm',
+ 'lib/File/KDBX/Loader/KDB.pm',
+ 'lib/File/KDBX/Loader/Raw.pm',
+ 'lib/File/KDBX/Loader/V3.pm',
+ 'lib/File/KDBX/Loader/V4.pm',
+ 'lib/File/KDBX/Loader/XML.pm',
+ 'lib/File/KDBX/Object.pm',
+ 'lib/File/KDBX/Safe.pm',
+ 'lib/File/KDBX/Transaction.pm',
+ 'lib/File/KDBX/Util.pm',
+ 't/00-compile.t',
+ 't/00-report-prereqs.dd',
+ 't/00-report-prereqs.t',
+ 't/crypt.t',
+ 't/database.t',
+ 't/entry.t',
+ 't/erase.t',
+ 't/error.t',
+ 't/files/bin/ykchalresp',
+ 't/files/bin/ykinfo',
+ 't/group.t',
+ 't/hash-block.t',
+ 't/hmac-block.t',
+ 't/iterator.t',
+ 't/kdb.t',
+ 't/kdbx2.t',
+ 't/kdbx3.t',
+ 't/kdbx4.t',
+ 't/kdf-aes-pp.t',
+ 't/kdf.t',
+ 't/keys.t',
+ 't/lib/TestCommon.pm',
+ 't/memory-protection.t',
+ 't/object.t',
+ 't/otp.t',
+ 't/placeholders.t',
+ 't/query.t',
+ 't/references.t',
+ 't/safe.t',
+ 't/util.t',
+ 't/yubikey.t',
+ 'xt/author/clean-namespaces.t',
+ 'xt/author/critic.t',
+ 'xt/author/distmeta.t',
+ 'xt/author/eol.t',
+ 'xt/author/minimum-version.t',
+ 'xt/author/no-tabs.t',
+ 'xt/author/pod-coverage.t',
+ 'xt/author/pod-no404s.t',
+ 'xt/author/pod-syntax.t',
+ 'xt/author/portability.t',
+ 'xt/release/cpan-changes.t'
+);
+
+eol_unix_ok($_, { trailing_whitespace => 1 }) foreach @files;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::MinimumVersion;
+all_minimum_version_ok( qq{5.10.1} );
--- /dev/null
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15
+
+use Test::More 0.88;
+use Test::NoTabs;
+
+my @files = (
+ 'lib/File/KDBX.pm',
+ 'lib/File/KDBX/Cipher.pm',
+ 'lib/File/KDBX/Cipher/CBC.pm',
+ 'lib/File/KDBX/Cipher/Stream.pm',
+ 'lib/File/KDBX/Constants.pm',
+ 'lib/File/KDBX/Dumper.pm',
+ 'lib/File/KDBX/Dumper/KDB.pm',
+ 'lib/File/KDBX/Dumper/Raw.pm',
+ 'lib/File/KDBX/Dumper/V3.pm',
+ 'lib/File/KDBX/Dumper/V4.pm',
+ 'lib/File/KDBX/Dumper/XML.pm',
+ 'lib/File/KDBX/Entry.pm',
+ 'lib/File/KDBX/Error.pm',
+ 'lib/File/KDBX/Group.pm',
+ 'lib/File/KDBX/IO.pm',
+ 'lib/File/KDBX/IO/Crypt.pm',
+ 'lib/File/KDBX/IO/HashBlock.pm',
+ 'lib/File/KDBX/IO/HmacBlock.pm',
+ 'lib/File/KDBX/Iterator.pm',
+ 'lib/File/KDBX/KDF.pm',
+ 'lib/File/KDBX/KDF/AES.pm',
+ 'lib/File/KDBX/KDF/Argon2.pm',
+ 'lib/File/KDBX/Key.pm',
+ 'lib/File/KDBX/Key/ChallengeResponse.pm',
+ 'lib/File/KDBX/Key/Composite.pm',
+ 'lib/File/KDBX/Key/File.pm',
+ 'lib/File/KDBX/Key/Password.pm',
+ 'lib/File/KDBX/Key/YubiKey.pm',
+ 'lib/File/KDBX/Loader.pm',
+ 'lib/File/KDBX/Loader/KDB.pm',
+ 'lib/File/KDBX/Loader/Raw.pm',
+ 'lib/File/KDBX/Loader/V3.pm',
+ 'lib/File/KDBX/Loader/V4.pm',
+ 'lib/File/KDBX/Loader/XML.pm',
+ 'lib/File/KDBX/Object.pm',
+ 'lib/File/KDBX/Safe.pm',
+ 'lib/File/KDBX/Transaction.pm',
+ 'lib/File/KDBX/Util.pm',
+ 't/00-compile.t',
+ 't/00-report-prereqs.dd',
+ 't/00-report-prereqs.t',
+ 't/crypt.t',
+ 't/database.t',
+ 't/entry.t',
+ 't/erase.t',
+ 't/error.t',
+ 't/files/bin/ykchalresp',
+ 't/files/bin/ykinfo',
+ 't/group.t',
+ 't/hash-block.t',
+ 't/hmac-block.t',
+ 't/iterator.t',
+ 't/kdb.t',
+ 't/kdbx2.t',
+ 't/kdbx3.t',
+ 't/kdbx4.t',
+ 't/kdf-aes-pp.t',
+ 't/kdf.t',
+ 't/keys.t',
+ 't/lib/TestCommon.pm',
+ 't/memory-protection.t',
+ 't/object.t',
+ 't/otp.t',
+ 't/placeholders.t',
+ 't/query.t',
+ 't/references.t',
+ 't/safe.t',
+ 't/util.t',
+ 't/yubikey.t',
+ 'xt/author/clean-namespaces.t',
+ 'xt/author/critic.t',
+ 'xt/author/distmeta.t',
+ 'xt/author/eol.t',
+ 'xt/author/minimum-version.t',
+ 'xt/author/no-tabs.t',
+ 'xt/author/pod-coverage.t',
+ 'xt/author/pod-no404s.t',
+ 'xt/author/pod-syntax.t',
+ 'xt/author/portability.t',
+ 'xt/release/cpan-changes.t'
+);
+
+notabs_ok($_) foreach @files;
+done_testing;
--- /dev/null
+#!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' });
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+use Test::More;
+
+foreach my $env_skip ( qw(
+ SKIP_POD_NO404S
+ AUTOMATED_TESTING
+) ){
+ plan skip_all => "\$ENV{$env_skip} is set, skipping"
+ if $ENV{$env_skip};
+}
+
+eval "use Test::Pod::No404s";
+if ( $@ ) {
+ plan skip_all => 'Test::Pod::No404s required for testing POD';
+}
+else {
+ all_pod_files_ok();
+}
--- /dev/null
+#!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();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+eval 'use Test::Portability::Files';
+plan skip_all => 'Test::Portability::Files required for testing portability'
+ if $@;
+
+run_tests();
--- /dev/null
+use strict;
+use warnings;
+
+# this test was generated with Dist::Zilla::Plugin::Test::CPAN::Changes 0.012
+
+use Test::More 0.96 tests => 1;
+use Test::CPAN::Changes;
+subtest 'changes_ok' => sub {
+ changes_file_ok('Changes');
+};
projects / chaz / p5-File-KDBX / commitdiff
